var tipuesearch = {"pages":[{"title":" OpenQP Fortran API ","text":"OpenQP Fortran API OpenQP Fortran API This reference is generated from the current OpenQP main branch. It covers\nthe native Fortran implementation, including the electronic-structure,\nresponse, dynamics, optimization, integral, and interoperability modules. For installation instructions, workflows, and input keywords, see the OpenQP manual . Developer Info OpenQP Team","tags":"home","url":"index.html"},{"title":"io_constants – OpenQP Fortran API","text":"","tags":"","url":"module/io_constants.html"},{"title":"logger – OpenQP Fortran API","text":"Uses iso_fortran_env","tags":"","url":"module/logger.html"},{"title":"atomic_structure_m – OpenQP Fortran API","text":"Uses iso_c_binding","tags":"","url":"module/atomic_structure_m.html"},{"title":"population_analysis – OpenQP Fortran API","text":"","tags":"","url":"module/population_analysis.html"},{"title":"messages – OpenQP Fortran API","text":"Todo Remove it Uses comm_PAR precision comm_IOFILE","tags":"","url":"module/messages.html"},{"title":"tdhf_sf_z_vector_mod – OpenQP Fortran API","text":"","tags":"","url":"module/tdhf_sf_z_vector_mod.html"},{"title":"mod_dft_fuzzycell – OpenQP Fortran API","text":"Uses mod_dft_molgrid mod_dft_partfunc basis_tools precision","tags":"","url":"module/mod_dft_fuzzycell.html"},{"title":"nmr_giao_debug_mod – OpenQP Fortran API","text":"","tags":"","url":"module/nmr_giao_debug_mod.html"},{"title":"guess_hcore_mod – OpenQP Fortran API","text":"","tags":"","url":"module/guess_hcore_mod.html"},{"title":"tdhf_z_vector_mod – OpenQP Fortran API","text":"Uses zvector_common oqp_linalg mod_dft_molgrid tdhf_lib int2_compute io_constants basis_tools types precision ieee_arithmetic","tags":"","url":"module/tdhf_z_vector_mod.html"},{"title":"oqp_linalg – OpenQP Fortran API","text":"Uses lapack_wrap blas_wrap","tags":"","url":"module/oqp_linalg.html"},{"title":"qmmm_mod – OpenQP Fortran API","text":"Uses resp_mod oqp_linalg","tags":"","url":"module/qmmm_mod.html"},{"title":"bragg_slater_radii – OpenQP Fortran API","text":"Uses precision","tags":"","url":"module/bragg_slater_radii.html"},{"title":"guess_json_mod – OpenQP Fortran API","text":"This module provides routines to load the JSON formatted SCF guess,\nretrieve basis set and molecular orbital data, compute the initial\ndensity matrix for RHF or ROHF/UHF calculations, and broadcast the\ncomputed data in a parallel environment.","tags":"","url":"module/guess_json_mod.html"},{"title":"boys_lut – OpenQP Fortran API","text":"","tags":"","url":"module/boys_lut.html"},{"title":"grd1 – OpenQP Fortran API","text":"Uses iso_c_binding cart2sph ecp_tool mod_shell_tools mathlib constants types io_constants precision basis_tools atomic_structure_m mod_1e_primitives","tags":"","url":"module/grd1.html"},{"title":"libint_f – OpenQP Fortran API","text":"Uses iso_c_binding","tags":"","url":"module/libint_f.html"},{"title":"tdhf_mrsf_z_vector_mod – OpenQP Fortran API","text":"Uses ieee_arithmetic precision zvector_common","tags":"","url":"module/tdhf_mrsf_z_vector_mod.html"},{"title":"mod_dft_gridint_tdxc_grad – OpenQP Fortran API","text":"Uses mod_dft_gridint precision","tags":"","url":"module/mod_dft_gridint_tdxc_grad.html"},{"title":"mathlib – OpenQP Fortran API","text":"Uses precision oqp_linalg","tags":"","url":"module/mathlib.html"},{"title":"grd2 – OpenQP Fortran API","text":"Uses constants grd2_rys io_constants basis_tools precision int2_compute","tags":"","url":"module/grd2.html"},{"title":"guess_sap_mod – OpenQP Fortran API","text":"","tags":"","url":"module/guess_sap_mod.html"},{"title":"fock_deriv_mod – OpenQP Fortran API","text":"@brief Two-electron derivative-Fock contraction  tr(M . F&#94;x[P])  for the\n  CPHF nuclear right-hand side, built natively on top of the validated 2e\n  gradient driver (grd2_driver) with no changes to the Rys internals and no\n  libint. The 2e gradient driver contracts the derivative ERIs d(uv|ls)/dx with a\n  four-index density product supplied by a grd2_compute_data_t extension. The\n  standard (energy-gradient) extension forms D (x) D. Here we instead form a\n  MIXED product M (x) P, so the same driver returns, for each nuclear\n  coordinate x,\n    g_x = sum_{uvls} d(uv|ls)/dx * [ 4 c M_uv P_ls - x_hf ( M_ul P_vs + M_us P_vl ) ]\n  which is exactly  sum_uv M_uv F&#94;x_uv[P]  for the closed-shell response Fock\n  F&#94;x[P] = J&#94;x[P] - 1/2 K&#94;x[P] (Coulomb scaled by c, exchange by x_hf=HFscale),\n  summed over the two equivalent index orderings that the driver already\n  exploits. M is the \"probe\" matrix; for a CPHF RHS element B&#94;x_{ia} the probe\n  is the symmetric AO matrix C_{.,i} C_{.,a}&#94;T + C_{.,a} C_{.,i}&#94;T. This is the F&#94;x building block of the native CPHF chain. It is validated by\n  the trace identity tr(P . F&#94;x[P]) = (2e part of dE/dx), i.e. against the\n  already-validated grd2_driver energy gradient (exact, non-iterative). Uses grd2 constants types basis_tools precision","tags":"","url":"module/fock_deriv_mod.html"},{"title":"tdhf_energy_mod – OpenQP Fortran API","text":"","tags":"","url":"module/tdhf_energy_mod.html"},{"title":"rys_lut – OpenQP Fortran API","text":"","tags":"","url":"module/rys_lut.html"},{"title":"tdhf_mrsf_gradient_mod – OpenQP Fortran API","text":"Uses grd2 printing constants basis_tools precision","tags":"","url":"module/tdhf_mrsf_gradient_mod.html"},{"title":"util – OpenQP Fortran API","text":"Uses precision","tags":"","url":"module/util.html"},{"title":"int2_pure_generated – OpenQP Fortran API","text":"Uses constants precision","tags":"","url":"module/int2_pure_generated.html"},{"title":"minao_lut – OpenQP Fortran API","text":"Loads spherically-averaged neutral-atom density matrices in a fixed minimal\nreference basis (STO-3G, Cartesian) from the OpenQP data file\n(basis_sets/minao_sto3g.dat, generated offline by\ntools/minao/generate_minao_data.py from PySCF's atomic HF densities). These\nare superposed block-diagonally and projected onto the target basis to form\nthe MINAO initial guess. Uses precision","tags":"","url":"module/minao_lut.html"},{"title":"int2e_rotaxis – OpenQP Fortran API","text":"Uses int2_pairs constants basis_tools precision boys_lut Used by Descendants: int2e_rotaxis_pure","tags":"","url":"module/int2e_rotaxis.html"},{"title":"basis_projection_mod – OpenQP Fortran API","text":"C-binding wrapper for the MO/DM projection routine. Main subroutine for MO and DM projection between basis sets. This routine projects molecular orbitals (MO) and density matrices (DM)\n from a primary basis set to an alternative (initial) basis set. It performs:\n   - Overlap matrix computation and normalization,\n   - Corresponding orbital projection,\n   - Orbital orthogonalization,\n   - Density matrix calculation (for both RHF and ROHF/UHF cases), Input Data:\n   - OQP::VEC_MO_A, OQP::DM_A for the alpha\n   - OQP::VEC_MO_B, OQP::DM_B for the beta (if applicable). Output Data:\n   - OQP::VEC_MO_A_tmp, OQP::DM_A_tmp for the alpha spin channel.\n   - OQP::VEC_MO_B_tmp, OQP::DM_B_tmp for the beta spin channel (if applicable). molecular properties, and control parameters.","tags":"","url":"module/basis_projection_mod.html"},{"title":"libxc – OpenQP Fortran API","text":"Todo add LC-, CAM- free coefficient functionals Todo add meta-GGA functionals with laplacian of electron density Uses xc_f03_lib_m xc_f03_funcs_m functionals precision","tags":"","url":"module/libxc.html"},{"title":"guess_minao_mod – OpenQP Fortran API","text":"","tags":"","url":"module/guess_minao_mod.html"},{"title":"int2e_libint – OpenQP Fortran API","text":"Uses iso_c_binding int2_pairs libint_f constants precision","tags":"","url":"module/int2e_libint.html"},{"title":"apply_basis_mod – OpenQP Fortran API","text":"","tags":"","url":"module/apply_basis_mod.html"},{"title":"trah_native – OpenQP Fortran API","text":"Algorithm: trust - region Newton . Each macro step solves the subproblem min_p g . p + 1 / 2 p . H p s . t . | p | <= Delta by the Steihaug - Toint preconditioned conjugate - gradient method ( preconditioner M = diag ( h_diag )); the step is accepted / rejected and Delta updated from the ratio of actual to predicted energy reduction . H . p is formed matrix - free via calc_h_op ( a Fock - like contraction ); H is never built . Convention: calc_g_h / calc_h_op return half the true orbital gradient / Hessian ( same as otr_interface , which scales by 2 ), so we scale by 2. Note E1 implementation (CG-Steihaug + basic trust control). Hardening of the\n       micro-solver for pathological/negative-gap cases (Jacobi-Davidson,\n       restarts, random trial vectors) is Phase-E2. Uses scf_converger mod_dft_molgrid scf_addons types precision basis_tools io_constants guess","tags":"","url":"module/trah_native.html"},{"title":"parallel – OpenQP Fortran API","text":"buffer_types defines a list of data types used in parallel communication.\nEach entry specifies:\n(1) A human-readable name for the data type,\n(2) The corresponding MPI data type for communication,\n(3) The Fortran data type (with the appropriate kind),\n(4) The array rank or shape (e.g., scalar, 1D, 2D, etc.).\nThese types are used for creating allreduce/bcast buffers in MPI operations. Uses iso_c_binding iso_fortran_env precision","tags":"","url":"module/parallel.html"},{"title":"mod_gauss_hermite – OpenQP Fortran API","text":"Uses precision","tags":"","url":"module/mod_gauss_hermite.html"},{"title":"vibrational_intensities_mod – OpenQP Fortran API","text":"Uses iso_c_binding","tags":"","url":"module/vibrational_intensities_mod.html"},{"title":"tdhf_sf_lib – OpenQP Fortran API","text":"Uses oqp_linalg ieee_arithmetic precision","tags":"","url":"module/tdhf_sf_lib.html"},{"title":"oqp_tagarray_driver – OpenQP Fortran API","text":"Uses iso_c_binding tagarray","tags":"","url":"module/oqp_tagarray_driver.html"},{"title":"mod_dft_gridint_grad – OpenQP Fortran API","text":"Uses mod_dft_gridint precision","tags":"","url":"module/mod_dft_gridint_grad.html"},{"title":"oqp_banner_mod – OpenQP Fortran API","text":"","tags":"","url":"module/oqp_banner_mod.html"},{"title":"electric_moments_mod – OpenQP Fortran API","text":"","tags":"","url":"module/electric_moments_mod.html"},{"title":"mod_dft_gridint_phi_cache – OpenQP Fortran API","text":"derivatives), together with the grid weights and the per-slice\nsignificant-AO pruning metadata, depends ONLY on geometry + basis + grid\n+ integration thresholds -- NOT on the electron density. It is therefore\nidentical on every SCF iteration, yet the native grid loop recomputes it\n(compAOs / pruneAOs) on every Fock build. This module stores the\npost-pruning Phi block per grid slice once per geometry and replays it on\nsubsequent iterations, mirroring the incremental reuse OpenQP already does\nfor the J/K (HF) part of the Fock matrix. The cache is OPT-IN (env var OQP_XC_PHI_CACHE) and is only populated by the\nrepeated SCF energy/Fock build (mod_dft_gridint_energy::dmatd_blk); one-shot\nconsumers (gradients, response) never set the opt-in flag. Validity is keyed\nby a geometry hash + derivative order + DFT threshold, so any change\ntransparently rebuilds the cache. The replayed Phi is bit-for-bit identical\nto the recomputed Phi, so the converged energy/gradient are unchanged. Uses precision","tags":"","url":"module/mod_dft_gridint_phi_cache.html"},{"title":"dft_radial_grid_types – OpenQP Fortran API","text":"Uses precision","tags":"","url":"module/dft_radial_grid_types.html"},{"title":"grd2_rys – OpenQP Fortran API","text":"Uses constants basis_tools precision","tags":"","url":"module/grd2_rys.html"},{"title":"hf_hessian_mod – OpenQP Fortran API","text":"","tags":"","url":"module/hf_hessian_mod.html"},{"title":"resp_mod – OpenQP Fortran API","text":"Uses oqp_linalg","tags":"","url":"module/resp_mod.html"},{"title":"mp2_lib – OpenQP Fortran API","text":"energy for RHF / UHF / ROHF references . The correlation energy is built in the spin-blocked (aa, bb, ab) form on\nsemicanonicalized orbitals, reusing the validated two-electron driver\n( int2_compute ) via per-occupied-MO-pair Coulomb builds -- so no full O(N&#94;4)\nMO integral tensor is ever stored.  A ROHF reference is semicanonicalized first\n(occ-occ and vir-vir Fock blocks diagonalized) so the canonical MP2 amplitude\ndenominators are well defined.  Validated to 1e-8 Ha against PySCF UMP2. Uses precision","tags":"","url":"module/mp2_lib.html"},{"title":"huckel – OpenQP Fortran API","text":"Uses precision oqp_linalg","tags":"","url":"module/huckel.html"},{"title":"scf_converger – OpenQP Fortran API","text":"Uses iso_c_binding iso_fortran_env scf_addons mod_dft_molgrid messages io_constants precision types mathlib","tags":"","url":"module/scf_converger.html"},{"title":"mathlib_types – OpenQP Fortran API","text":"","tags":"","url":"module/mathlib_types.html"},{"title":"functionals – OpenQP Fortran API","text":"Uses xc_f03_lib_m iso_c_binding precision","tags":"","url":"module/functionals.html"},{"title":"huckel_lut – OpenQP Fortran API","text":"Uses iso_fortran_env","tags":"","url":"module/huckel_lut.html"},{"title":"namd_mod – OpenQP Fortran API","text":"@details\n  Faithful port of the surface-hopping numerics from the GAMESS namd.src module (S. Lee), restructured into clean, argument-based modern Fortran so\n  the kernels are unit-testable and free of COMMON-block / dynamic-memory\n  coupling.  The physics mirrors the original exactly: - time - derivative couplings ( TDC ) from wavefunction overlaps between consecutive nuclear steps [ GAMESS NACVFD ] - RK4 propagation of the electronic amplitudes i * hbar * \\ dot { c } = ( E - i * sigma ) c [ GAMESS PPTDECOE / NDDTCR / NDDTCC ] - cumulative Tully hopping probabilities [ GAMESS FSSHPRST / FSSHPR ] - fewest - switches hop decision + isotropic velocity rescaling ( energy conservation ) [ GAMESS FSSH / FSSHT / RESCALV ] - kinetic energy [ GAMESS MDQKIN ] Internal-conversion accuracy upgrades, added per a verified literature\n  survey (see session RESEARCH_ic_isc_methods.md) and absent from the GAMESS\n  reference:\n    - energy-based decoherence correction (EDC) — Granucci & Persico,\n      J. Chem. Phys. 126, 134114 (2007); the SHARC default decoherence scheme\n    - trivial / unavoided-crossing detection with diabatic state following,\n      in the spirit of SC-FSSH — Wang & Prezhdo, JPCL 5, 713 (2014) Planned next (documented, not yet implemented here):\n    - norm-preserving interpolation (NPI) time-derivative couplings\n      (Meek & Levine, JPCL 5, 2351 (2014)): rigorous multistate form is the\n      real antisymmetric matrix logarithm of the Loewdin-orthonormalised\n      step overlap, T = logm(orth(S))/dt, which reduces to the exact 2-state\n      identity T*dt = arcsin(S_10).  Will replace namd_state_tdc when wired.\n    - intersystem crossing (ISC) via the SHARC spin-adiabatic representation:\n      diagonalise H = H_MCH + H_SOC, hop on the diagonal states, propagate\n      c_diag = U' . P_MCH . U . c_diag.  Requires MRSF Breit-Pauli SOC\n      matrix elements as input. Deliberate, documented deviations from the original (\"the GAMESS code may\n  not be perfect\"):\n    * Everything is in consistent atomic units (energies in Hartree,\n      velocities in bohr/atomic-time, masses in electron masses).  The\n      original mixed Hartree (FSSH) and kcal/mol (FSSHT, QM/MM) paths; here a\n      single code path is used and the caller converts units once.\n    * The O(nstate&#94;2 * nsub) per-substep probability buffer of FSSHPR is\n      dropped: probabilities are accumulated on the fly, then clamped and\n      row-normalised once — numerically identical to the original sum. Uses precision","tags":"","url":"module/namd_mod.html"},{"title":"qmat_cache – OpenQP Fortran API","text":"Uses precision","tags":"","url":"module/qmat_cache.html"},{"title":"tdhf_lib – OpenQP Fortran API","text":"Uses oqp_linalg basis_tools int2_compute ieee_arithmetic precision","tags":"","url":"module/tdhf_lib.html"},{"title":"tdhf_sf_energy_mod – OpenQP Fortran API","text":"","tags":"","url":"module/tdhf_sf_energy_mod.html"},{"title":"blas_wrap – OpenQP Fortran API","text":"Uses mathlib_types messages precision","tags":"","url":"module/blas_wrap.html"},{"title":"blas_thread – OpenQP Fortran API","text":"the thread-count setter/getter of the linked BLAS library (OpenBLAS,\nMKL, BLIS) at run time via dlsym().  Use it to switch BLAS to\nsingle-threaded mode around OpenMP-parallel regions that issue many\nsmall BLAS calls, where a BLAS-internal thread pool (e.g. pthread\nbuilds of OpenBLAS) oversubscribes the machine and serializes on its\npool lock. If the BLAS library is not recognized, blas_thread_count returns -1\nand blas_thread_set is a no-op, so the calls are always safe: nSaved = blas_thread_count()\n  call blas_thread_set(1_c_int64_t)\n  !$omp parallel\n  ...\n  !$omp end parallel\n  call blas_thread_set(nSaved)  ! no-op if nSaved == -1 Uses iso_c_binding","tags":"","url":"module/blas_thread.html"},{"title":"boys – OpenQP Fortran API","text":"Uses boys_lut precision","tags":"","url":"module/boys.html"},{"title":"guess – OpenQP Fortran API","text":"Uses precision oqp_linalg","tags":"","url":"module/guess.html"},{"title":"nmr_giao_shielding_mod – OpenQP Fortran API","text":"Uses precision","tags":"","url":"module/nmr_giao_shielding_mod.html"},{"title":"elements – OpenQP Fortran API","text":"Uses strings iso_fortran_env physical_constants","tags":"","url":"module/elements.html"},{"title":"basis_library – OpenQP Fortran API","text":"Uses iso_fortran_env elements constants strings io_constants","tags":"","url":"module/basis_library.html"},{"title":"int2e_rys – OpenQP Fortran API","text":"Uses constants basis_tools precision int2_pure_generated","tags":"","url":"module/int2e_rys.html"},{"title":"minres_mod – OpenQP Fortran API","text":"Uses iso_c_binding precision ieee_arithmetic","tags":"","url":"module/minres_mod.html"},{"title":"mod_dft_xclib – OpenQP Fortran API","text":"Uses functionals precision","tags":"","url":"module/mod_dft_xclib.html"},{"title":"mod_dft_incdft – OpenQP Fortran API","text":"matrix incrementally from the density change (scf.F90 dold/fold), but the XC\nmatrix is rebuilt from the full density on every iteration. As the SCF\nconverges the density change dP sparsifies and the XC contribution stops\nchanging, so rebuilding it is wasted quadrature. XC is NONLINEAR in the density, so the reused matrix is an APPROXIMATION\nthat must be refreshed. This module reuses the most recent full XC build\n(V_xc[D_ref], E_xc[D_ref]) only inside a controlled \"late-SCF\" window of the\nDIIS error, with a periodic forced full rebuild (drift hygiene, mirroring\nthe J/K incremental reset cadence) and -- crucially -- a return to FULL XC\nbuilds once the error drops below incdft_stop , so the converged density is\nthe true fixed point of the exact Fock and the converged energy/gradient are\nunchanged from the non-incremental baseline. Opt-in via env OQP_XC_INCDFT (default off). Complementary to the Phi cache\n(Opt 1): the Phi cache removes the geometry-only collocation cost from every\nXC build, while IncDFT skips the density-driven XC work entirely on reused\niterations. Uses precision","tags":"","url":"module/mod_dft_incdft.html"},{"title":"get_structures_ao_overlap_mod – OpenQP Fortran API","text":"basis sets (Atomic Orbitals) of two different geometries. It includes\n   calculations for AO overlap and then Molecular Orbital (MO) overlap. Note The matrices mol.data[\"OQP::xyz_old\"],\n                   mol.data[\"OQP::xyz\"],\n                   mol.data[\"OQP::VEC_MO_A_old\"],\n                   mol.data[\"OQP::VEC_MO_A\"],\n                   mol.data[\"OQP::E_MO_A_old\"],\n                   mol.data[\"OQP::E_MO_A\"]\n      must be defined in advance before running this program.\n      Output AO overlap will be written to\n                   mol.data[\"OQP::overlap_ao_non_orthogonal\"]\n      Output MO overlap will be written to\n                   mol.data[\"OQP::overlap_mo_non_orthogonal\"]","tags":"","url":"module/get_structures_ao_overlap_mod.html"},{"title":"physical_constants – OpenQP Fortran API","text":"Uses iso_fortran_env","tags":"","url":"module/physical_constants.html"},{"title":"hf_gradient_mod – OpenQP Fortran API","text":"Uses grd2 constants types basis_tools precision","tags":"","url":"module/hf_gradient_mod.html"},{"title":"mod_grid_storage – OpenQP Fortran API","text":"Uses precision","tags":"","url":"module/mod_grid_storage.html"},{"title":"mod_shell_tools – OpenQP Fortran API","text":"Uses constants basis_tools precision","tags":"","url":"module/mod_shell_tools.html"},{"title":"mod_dft_gridint_sap – OpenQP Fortran API","text":"Builds the SAP potential matrix\n    V_{mu,nu} = sum_g w_g phi_mu(r_g) V_SAP(r_g) phi_nu(r_g),\n    V_SAP(r) = sum_A V_A(|r - R_A|) = sum_A -Z_eff&#94;A(|r - R_A|)/|r - R_A|,\non the existing DFT molecular grid, reusing the AO-on-grid evaluation and\nAO-pruning machinery of mod_dft_gridint (run_grid_aos). The construction\nmirrors the Kohn-Sham matrix accumulation in mod_dft_gridint_energy. Reference: S. Lehtola, \"Assessment of Initial Guesses for Self-Consistent\nField Calculations. Superposition of Atomic Potentials: Simple yet\nEfficient\", J. Chem. Theory Comput. 15, 1593 (2019). Uses mod_dft_gridint precision oqp_linalg sap_lut","tags":"","url":"module/mod_dft_gridint_sap.html"},{"title":"mod_dft_molgrid – OpenQP Fortran API","text":"Legacy Fortran wrappers Uses mod_grid_storage bragg_slater_radii precision lebedev","tags":"","url":"module/mod_dft_molgrid.html"},{"title":"precision – OpenQP Fortran API","text":"@author  Vladimir Mironov @brief   Contains constants for floating\n         point number precision\n@date May, 2016 Initial release Uses iso_fortran_env","tags":"","url":"module/precision.html"},{"title":"scf – OpenQP Fortran API","text":"Uses precision","tags":"","url":"module/scf.html"},{"title":"tdhf_gradient_mod – OpenQP Fortran API","text":"Uses grd2 constants types basis_tools precision io_constants","tags":"","url":"module/tdhf_gradient_mod.html"},{"title":"mod_dft_gridint – OpenQP Fortran API","text":"Uses blas_wrap oqp_linalg mod_dft_molgrid mod_dft_xc_libxc functionals parallel io_constants basis_tools precision mod_dft_gridint_phi_cache","tags":"","url":"module/mod_dft_gridint.html"},{"title":"nlopt – OpenQP Fortran API","text":"","tags":"","url":"module/nlopt.html"},{"title":"mod_dft_gridint_giao – OpenQP Fortran API","text":"Uses mod_dft_gridint precision oqp_linalg","tags":"","url":"module/mod_dft_gridint_giao.html"},{"title":"mod_dft_gridint_energy – OpenQP Fortran API","text":"Uses mod_dft_gridint precision oqp_linalg","tags":"","url":"module/mod_dft_gridint_energy.html"},{"title":"tdhf_mrsf_energy_mod – OpenQP Fortran API","text":"","tags":"","url":"module/tdhf_mrsf_energy_mod.html"},{"title":"tdhf_mrsf_lib – OpenQP Fortran API","text":"Uses basis_tools int2_compute precision oqp_linalg","tags":"","url":"module/tdhf_mrsf_lib.html"},{"title":"pcg_mod – OpenQP Fortran API","text":"Uses iso_c_binding precision ieee_arithmetic","tags":"","url":"module/pcg_mod.html"},{"title":"zvector_common – OpenQP Fortran API","text":"Shared helpers for the TDHF/SF/MRSF z-vector (CPHF/CPKS) solvers. These routines were previously duplicated, one copy per response module\n( tdhf_z_vector , tdhf_sf_z_vector , tdhf_mrsf_z_vector ). They are\ncollected here so the three z-vector drivers share a single, tested\nimplementation. Uses ieee_arithmetic precision","tags":"","url":"module/zvector_common.html"},{"title":"guess_huckel_mod – OpenQP Fortran API","text":"","tags":"","url":"module/guess_huckel_mod.html"},{"title":"int2e_mod – OpenQP Fortran API","text":"Uses int2_compute precision","tags":"","url":"module/int2e_mod.html"},{"title":"solvent_pcm – OpenQP Fortran API","text":"declares the iso_c_binding interfaces to the two production C adapter\nentry points (source/solvent_ddx_adapter.c) and orchestrates the closed\nreaction-field loop inside a single SCF Fock build: D -> phi_cav -> ddX q_cav -> V_pcm -> Fock / E_pcm The C adapter returns status 2 when OpenQP was built without OQP_ENABLE_DDX,\nso a PCM-enabled run on a non-ddX build aborts here with a clear message\nrather than silently producing a vacuum result. SOURCE CONSISTENCY (ddX forward Phi vs adjoint Psi):\n  * Phi (forward solve RHS): the EXACT total solute potential phi_cav at the\n    cavity points, built from the full AO density (electrostatic_potential_\n    unweighted) plus the analytic nuclear term.\n  * Psi (adjoint solve source): a FULL-DENSITY source. Atom-centered real\n    solid-harmonic multipoles M_lm are accumulated for l = 0..PCM_PSI_LMAX\n    (=8) from the full AO density by numerical quadrature over a dedicated\n    source-projection molecular grid that reproduces the reference\n    ddCOSMO/ddPCM density partition: per-atom (PARENT-ATOM) point\n    assignment with Becke-original (3-iteration) fuzzy-cell weights and\n    Treutler-Ahlrichs sqrt(R_i/R_j) atomic-size shifting over the Becke\n    Bragg-Slater table (H = 0.35 A), WITH the literature outside-sphere\n    leak continuation q rsph&#94;(2l+1)/r&#94;(l+1) for r>rsph\n    (build_full_density_multipoles / pcm_grid_update). The moments are in\n    the exact ddX harmonic convention -- the real-solid-harmonic basis is\n    evaluated by ddX's OWN routines (use ddx_harmonics: ylmscale, ylmbas)\n    so ddX stays an external, dynamically-linked dependency and no harmonic\n    code is vendored into OpenQP; only the interior/exterior leak\n    bookkeeping in pcm_accumulate_leak is OpenQP's. They are then mapped\n    to psi by the ddX rule psi(lm,isph)=4 pi/((2l+1) rsph&#94;l) M_lm(isph)\n    using the production cavity radii (oqp_ddx_pcm_radii). The production\n    q_cav is the ddX adjoint charge from oqp_ddx_pcm_solve_psi(psi,\n    phi_cav): both the forward RHS and the adjoint source are full-density\n    quantities. This is recorded by \"PCM diag pcm_source_mode=full_density_\n    multipoles_lmax8_exact_phi\" and \"PCM diag psi_source=full_density_grid_\n    multipoles_lmax8_becke3_treutler_parent_atom_leak\".\n  * NOTE: the per-sphere moments are partition-defined integrals\n    (Becke-original/Treutler cells), the same convention the reference\n    ddPCM implementations project on their per-atom Becke grids; the two\n    codes agree in the fine-grid limit, with only quadrature-mesh\n    differences remaining (it is NOT claimed to be bit-identical to\n    PySCF's grid-projected psi).\n  * The legacy l<=2 atom-centered Mulliken multipole solve (Phi AND Psi from\n    the l<=2 source) is still run as a DIAGNOSTIC only, to report the\n    source-vs-exact phi residual and the q_cav shift between the old l<=2 psi\n    and the new full-density psi (PCM diag q_cav_ vs _rms). VALIDATED SCALAR CONVENTIONS (analytic Born-ion/ddX oracle gate):\n  * phi_cav sign:  phi_total = sum_k Z_k/|r-R_k| + phi_elec\n  * q_cav sign/scale: ddX cavity-projected adjoint charge (ddx_get_xi) used\n    directly as the external-charge vector for external_charge_potential.\n  * E_pcm: -0.5 * dot_product(phi_cav, q_cav), with NO additional dielectric\n    factor: ddX folds the full dielectric response into its ddPCM R_eps\n    operators, so -0.5 = ddx_pcm_energy = the PHYSICAL\n    solvation free energy. Proven by the Born-ion oracle (point charge q\n    centered in a single sphere of radius R): -0.5 reproduces\n    -(1/2)(1-1/eps)*q&#94;2/R to machine precision at eps = 78.3553 and eps = 2.\n    An extra f(eps) = (eps-1)/eps here (as in PySCF's solvent.ddpcm) would\n    double-count the dielectric scaling, by -1.3% at eps=78 and -50% at eps=2.\nThe single canonical runtime path and these conventions are pinned by\ntests/test_pcm_canonical_runtime_path.py. Uses iso_c_binding mod_dft_gridint dft oqp_tagarray_driver mathlib mod_dft_molgrid messages mod_dft_partfunc ieee_arithmetic basis_tools types precision io_constants int1","tags":"","url":"module/solvent_pcm.html"},{"title":"tdhf_mrsf_ekt_mod – OpenQP Fortran API","text":"","tags":"","url":"module/tdhf_mrsf_ekt_mod.html"},{"title":"int2_compute – OpenQP Fortran API","text":"Uses int2e_rys int2_pairs int2e_libint messages parallel basis_tools precision atomic_structure_m","tags":"","url":"module/int2_compute.html"},{"title":"types – OpenQP Fortran API","text":"Uses iso_c_binding tagarray functionals parallel precision basis_tools atomic_structure_m","tags":"","url":"module/types.html"},{"title":"tdhf_hessian_mod – OpenQP Fortran API","text":"","tags":"","url":"module/tdhf_hessian_mod.html"},{"title":"base64 – OpenQP Fortran API","text":"Uses iso_c_binding iso_fortran_env","tags":"","url":"module/base64.html"},{"title":"xyz_order – OpenQP Fortran API","text":"","tags":"","url":"module/xyz_order.html"},{"title":"mod_dft_gridint_gxc – OpenQP Fortran API","text":"Uses mod_dft_gridint mod_dft_gridint_fxc precision oqp_linalg","tags":"","url":"module/mod_dft_gridint_gxc.html"},{"title":"eigen – OpenQP Fortran API","text":"Uses mathlib_types messages precision oqp_linalg","tags":"","url":"module/eigen.html"},{"title":"int2_pairs – OpenQP Fortran API","text":"Uses precision","tags":"","url":"module/int2_pairs.html"},{"title":"c_interop – OpenQP Fortran API","text":"Uses messages iso_c_binding types","tags":"","url":"module/c_interop.html"},{"title":"mod_1e_primitives – OpenQP Fortran API","text":"to compute one-electron integrals and their derivatives Todo Unify interfaces Cleanup redundant subroutines Uses mod_gauss_hermite iso_fortran_env mod_shell_tools rys constants xyz_order","tags":"","url":"module/mod_1e_primitives.html"},{"title":"otr_interface – OpenQP Fortran API","text":"Uses iso_c_binding scf_converger opentrustregion scf_addons mod_dft_molgrid precision types basis_tools mathlib guess","tags":"","url":"module/otr_interface.html"},{"title":"mod_dft_partfunc – OpenQP Fortran API","text":"Uses precision","tags":"","url":"module/mod_dft_partfunc.html"},{"title":"basis_tools – OpenQP Fortran API","text":"onto pair of S and P shells. It significantly simplifies code for\none- and two-electron integrals. Uses cart2sph iso_fortran_env constants parallel precision io_constants atomic_structure_m","tags":"","url":"module/basis_tools.html"},{"title":"printing – OpenQP Fortran API","text":"Uses precision","tags":"","url":"module/printing.html"},{"title":"rys_deriv – OpenQP Fortran API","text":"Uses constants precision","tags":"","url":"module/rys_deriv.html"},{"title":"errcode – OpenQP Fortran API","text":"","tags":"","url":"module/errcode.html"},{"title":"cphf_mod – OpenQP Fortran API","text":"@brief Native coupled-perturbed Hartree-Fock / Kohn-Sham (CPHF/CPKS) solver\n  for closed-shell (RHF/RKS) references. The static CPHF A-matrix is the orbital Hessian (A+B)_{ia,jb}, the same\n  operator the TDDFT Z-vector solver applies. This module reuses that exact\n  operator -- built from the native Rys 2e engine via int2_td_data_t plus the\n  DFT XC kernel (tddft_fxc) -- so it has no libint dependency. It drives the\n  existing pcg solver with:\n    update  : U(MO,occ-vir) -> AO density (iatogen) -> response Fock (A+B)\n              -> MO occ-vir (mntoia) + orbital-energy diagonal (e_a-e_i) U\n    precond : diagonal 1/(e_a-e_i)\n  to solve  A U = B  for an arbitrary occ-vir right-hand side B. cphf_solve is the reusable entry point (used by the analytic Hessian for the\n  nuclear-perturbation response). cphf_polarizability_selftest validates the\n  solver end to end against a known property: it solves with the dipole\n  right-hand side and forms the static dipole polarizability, written to a file\n  for comparison against an external reference (no geometry derivatives required). Uses iso_c_binding mod_dft_molgrid pcg_mod int2_compute types basis_tools precision tdhf_lib io_constants","tags":"","url":"module/cphf_mod.html"},{"title":"soc_mrsf_mod – OpenQP Fortran API","text":"Uses precision","tags":"","url":"module/soc_mrsf_mod.html"},{"title":"tdhf_sf_hessian_mod – OpenQP Fortran API","text":"","tags":"","url":"module/tdhf_sf_hessian_mod.html"},{"title":"dk_scalar_mod – OpenQP Fortran API","text":"the non-relativistic H_core = T + V with the scalar relativistic H&#94;DK.\nThe DK transformation is carried out in the momentum (p) representation\nobtained by diagonalising the kinetic energy matrix T. Pipeline (called once per SCF):\n  1. Compute pVp integrals 2. Build p-space basis:   S&#94;{-1/2} -> XU, SXU, p&#94;2 eigenvalues\n  3. Compute kinematic factors: E_p, A, R\n  4. Transform V and pVp to p-space\n  5. Build H&#94;DK1 in p-space (DK1 correction)\n  6. Add H&#94;DK2 correction in p-space (DK2 correction)\n  7. Back-transform to AO basis -> overwrite OQP::Hcore","tags":"","url":"module/dk_scalar_mod.html"},{"title":"ecp_tool – OpenQP Fortran API","text":"Uses iso_c_binding libecpint_wrapper iso_fortran_env constants basis_tools libecp_result precision","tags":"","url":"module/ecp_tool.html"},{"title":"strings – OpenQP Fortran API","text":"Uses iso_c_binding","tags":"","url":"module/strings.html"},{"title":"cart2sph – OpenQP Fortran API","text":"unit-normalized Cartesian components of a shell (OpenQP's\ncanonical bf_names order; see constants::CART_X/Y/Z) onto the\n2l+1 real solid harmonics in CCA/libint order (m = -l..+l). Convention is identical to the validated Python reference in\npyoqp/oqp/library/symmetry.py (_solid_harmonic_coefficients):\neach column of C2S_x holds the Cartesian coefficients of one\nspherical component, orthonormal against the intra-shell metric\nS of unit-normalized Cartesian Gaussians (B S B&#94;T = I). The\nmatrices below were generated from that reference and are\nre-verified at runtime by c2s_selftest(). The transform is applied to integrals that are already in the\nunit-normalized Cartesian basis (e.g. 2e blocks AFTER the\nrotation/Rys/libint normalization in int2::shellquartet, where\nall backends agree). s and p shells are passed through unchanged\n(Cartesian == spherical up to the trivial 1:1 / 3:3 mapping). Uses constants precision","tags":"","url":"module/cart2sph.html"},{"title":"scf_addons – OpenQP Fortran API","text":"Uses precision","tags":"","url":"module/scf_addons.html"},{"title":"dftd4_interface – OpenQP Fortran API","text":"Native DFT-D4 dispersion interface for OpenQP. Thin bind(C) shim over the dftd4 Fortran library (statically linked into\nliboqp). Replaces the former dftd4 Python (cffi) package, which is capped\nat Python <= 3.12. This routine has no Python dependency and is called\ndirectly through the existing cffi boundary (see include/oqp.h). Uses iso_c_binding dftd4 iso_fortran_env mctc_io","tags":"","url":"module/dftd4_interface.html"},{"title":"hf_energy_mod – OpenQP Fortran API","text":"","tags":"","url":"module/hf_energy_mod.html"},{"title":"tdhf_sf_gradient_mod – OpenQP Fortran API","text":"Uses grd2 constants types basis_tools precision","tags":"","url":"module/tdhf_sf_gradient_mod.html"},{"title":"int1 – OpenQP Fortran API","text":"calculation. Uses cart2sph iso_fortran_env mod_shell_tools constants messages basis_tools mod_1e_primitives","tags":"","url":"module/int1.html"},{"title":"mod_dft_gridint_fxc – OpenQP Fortran API","text":"Uses blas_wrap mod_dft_gridint precision oqp_linalg","tags":"","url":"module/mod_dft_gridint_fxc.html"},{"title":"lebedev – OpenQP Fortran API","text":"Uses precision","tags":"","url":"module/lebedev.html"},{"title":"basis_api – OpenQP Fortran API","text":"Uses libecpint_wrapper iso_c_binding iso_fortran_env physical_constants","tags":"","url":"module/basis_api.html"},{"title":"rys – OpenQP Fortran API","text":"Uses constants rys_lut precision","tags":"","url":"module/rys.html"},{"title":"sap_lut – OpenQP Fortran API","text":"Loads Susi Lehtola's tabulated effective atomic charges Z_eff(r) from the\nOpenQP data file (basis_sets/sap_grasp.dat, generated offline by\ntools/sap/generate_sap_data.py from pyscf.dft.sap_data) and evaluates the\nSAP potential of a neutral atom,\n    V_A(r) = -Z_eff(r) / r,\nby linear interpolation, matching the reference implementation\n(S. Lehtola, J. Chem. Theory Comput. 15, 1593 (2019)). Uses precision","tags":"","url":"module/sap_lut.html"},{"title":"lapack_wrap – OpenQP Fortran API","text":"Uses mathlib_types messages precision","tags":"","url":"module/lapack_wrap.html"},{"title":"dft – OpenQP Fortran API","text":"Uses mod_dft_molgrid messages io_constants basis_tools precision","tags":"","url":"module/dft.html"},{"title":"mp2_energy_mod – OpenQP Fortran API","text":"MP2 is a post-SCF ground-state correlation correction: the SCF reference\n(RHF/UHF/ROHF) is converged first by the usual PyOQP reference step, and\nthis driver adds the second-order Moller-Plesset correlation energy on top,\nreusing the validated two-electron driver via mp2_lib .  It is dispatched\nfrom Python as [input] method = mp2 (a ground-state post-SCF method that\nreports no excitations).","tags":"","url":"module/mp2_energy_mod.html"},{"title":"libecp_result – OpenQP Fortran API","text":"Uses iso_c_binding","tags":"","url":"module/libecp_result.html"},{"title":"libecpint_wrapper – OpenQP Fortran API","text":"Uses iso_c_binding","tags":"","url":"module/libecpint_wrapper.html"},{"title":"int1e_mod – OpenQP Fortran API","text":"","tags":"","url":"module/int1e_mod.html"},{"title":"nmr_shielding_mod – OpenQP Fortran API","text":"","tags":"","url":"module/nmr_shielding_mod.html"},{"title":"get_state_overlap_mod – OpenQP Fortran API","text":"","tags":"","url":"module/get_state_overlap_mod.html"},{"title":"constants – OpenQP Fortran API","text":"Uses iso_c_binding precision","tags":"","url":"module/constants.html"},{"title":"mod_dft_xc_libxc – OpenQP Fortran API","text":"Uses mod_dft_xclib precision","tags":"","url":"module/mod_dft_xc_libxc.html"},{"title":"int2e_rotaxis_pure – OpenQP Fortran API","text":"the lab frame index-by-index (r30s1d) and, for harmonic-flagged shells,\nprojects 6d Cartesian components to 5d pure components in a second pass\n(genr22_reduce_pure). Both steps are linear maps acting on one shell\nindex at a time, so they are fused here: each index is transformed once\nby T = C * R&#94;T, where R is the per-shell rotated->lab rotation in the\nengine's component convention and C the Cartesian->pure projection.\nPure 5d blocks are written directly; the 6d lab-frame Cartesian block\nis never materialized, and s-shell (identity) indices are skipped. Component conventions (must match r30s1d_NN and the projection tables):\nd order xx,yy,zz,xy,xz,yz; rotated-frame cross components carry no\nsqrt(3) normalization while lab cross components do - the sqrt(3) is\nfolded into the rotation, exactly as in r30s1d_07. Uses Ancestors: int2e_rotaxis","tags":"","url":"module/int2e_rotaxis_pure.html"},{"title":"constants_io.F90 – OpenQP Fortran API","text":"Source Code module io_constants implicit none !  File numbers for outputs !  IW : OUTPUT integer , parameter :: IW = 6 end module io_constants","tags":"","url":"sourcefile/constants_io.f90.html"},{"title":"logger.F90 – OpenQP Fortran API","text":"Source Code module logger use , intrinsic :: iso_fortran_env , only : error_unit implicit none private type , public :: logger_t integer :: log_unit = error_unit character (:), allocatable :: log_file_name contains procedure :: log_open procedure :: log_close procedure :: timestamp final :: finalize end type contains subroutine timestamp ( this , message ) class ( logger_t ) :: this character ( * ), intent ( in ) :: message character ( 8 ) :: date character ( 10 ) :: time character ( 5 ) :: zone call date_and_time ( date , time , zone ) write ( this % log_unit , '(\"[ \",2(a,\"-\"),a,x,2(a,\":\"),a,\" ]  \",a)' ) & date ( 1 : 4 ), date ( 5 : 6 ), date ( 7 : 8 ), & time ( 1 : 2 ), time ( 3 : 4 ), time ( 5 : 6 ), message !        write(this%log_unit,'(x,a,2x,\"[ \",2(a,\"-\"),a,x,2(a,\":\"),a,\"(\",a,\") ]\")') & !                message, date(1:4), date(5:6), date(7:8), & !                time(1:2), time(3:4), time(5:), zone end subroutine function log_open ( this , fname ) result ( res ) class ( logger_t ) :: this character ( * ), intent ( in ) :: fname integer :: res integer :: iunit character (:), allocatable :: trim_fname character ( 7 ) :: is_ro res = this % log_close () trim_fname = trim ( adjustl ( fname )) inquire ( file = trim_fname , number = iunit , read = is_ro ) if ( iunit /= - 1 ) then open ( file = trim_fname , newunit = this % log_unit , iostat = res ) call move_alloc ( trim_fname , this % log_file_name ) else if ( is_ro /= 'YES' ) then this % log_unit = iunit call move_alloc ( trim_fname , this % log_file_name ) else write ( error_unit , * ) \"File: '\" , trim_fname , \"', is already opened for -reading-\" write ( error_unit , * ) \"Close this file prior to opening it again\" write ( error_unit , * ) \"Log unit unchanged\" res = 1 end if end if end function function log_close ( this ) result ( res ) class ( logger_t ) :: this integer :: res res = 0 if ( this % log_unit /= error_unit ) then close ( this % log_unit , iostat = res ) if ( res == 0 ) deallocate ( this % log_file_name ) this % log_unit = error_unit end if end function subroutine finalize ( this ) type ( logger_t ) :: this integer :: res res = this % log_close () if ( res /= 0 ) then write ( error_unit , * ) \"Cannot close file: '\" , this % log_file_name , \"'\" error stop \"See above\" end if end subroutine end module","tags":"","url":"sourcefile/logger.f90.html"},{"title":"atomic_structure.F90 – OpenQP Fortran API","text":"Source Code module atomic_structure_m use , intrinsic :: iso_c_binding , only : c_double , c_int , c_int64_t implicit none !  Structured Data types for basis set index type , public :: atomic_structure real ( c_double ), allocatable :: zn (:) !< atomic number or nuclear charge real ( c_double ), allocatable :: mass (:) !< atomic mass real ( c_double ), allocatable :: grad (:,:) !< Gradient real ( c_double ), allocatable :: xyz (:,:) !< Atomic coordinates !      character(len=2) :: Symbol   !< Atomic symbol !      character(len=8) :: SHTYPS   !< Shell type of basis set contains procedure , non_overridable :: init => atomic_structure_init procedure , non_overridable :: clean => atomic_structure_clean procedure , non_overridable :: center => atomic_structure_center end type atomic_structure contains function atomic_structure_init ( self , natoms ) result ( ok ) class ( atomic_structure ) :: self integer ( c_int64_t ), intent ( in ) :: natoms integer ( c_int ) :: ok ok = self % clean () if ( ok /= 0 ) return allocate ( self % zn ( natoms ) & , self % mass ( natoms ) & , self % grad ( 3 , natoms ) & , self % xyz ( 3 , natoms ) & , stat = ok ) !      character(len=2) :: Symbol   !< Atomic symbol end function atomic_structure_init function atomic_structure_clean ( self ) result ( ok ) class ( atomic_structure ) :: self integer ( c_int ) :: ok ok = 0 if ( allocated ( self % zn )) deallocate ( self % zn , stat = ok ) if ( ok /= 0 ) return if ( allocated ( self % mass )) deallocate ( self % mass , stat = ok ) if ( ok /= 0 ) return if ( allocated ( self % grad )) deallocate ( self % grad , stat = ok ) if ( ok /= 0 ) return if ( allocated ( self % xyz )) deallocate ( self % xyz , stat = ok ) end function atomic_structure_clean function atomic_structure_center ( self , weight ) result ( r ) use strings , only : to_upper implicit none class ( atomic_structure ) :: self character ( len =* ), optional :: weight real ( c_double ) :: r ( 3 ) character ( len = 8 ) :: wtype character ( len = 8 ), parameter :: WTYPE_NONE = 'NONE' character ( len = 8 ), parameter :: WTYPE_MASS = 'MASS' wtype = WTYPE_NONE if ( present ( weight )) wtype = to_upper ( weight ) r = 0 select case ( wtype ) case ( WTYPE_NONE ) r = sum ( self % xyz , 2 ) / ubound ( self % xyz , 2 ) case ( WTYPE_MASS ) r = matmul ( self % xyz , self % mass ) / sum ( self % mass ) case default error stop \"Unknown weight type in atomic_structure_center: \" // wtype end select end function atomic_structure_center end module atomic_structure_m","tags":"","url":"sourcefile/atomic_structure.f90.html"},{"title":"population_analysis.F90 – OpenQP Fortran API","text":"Source Code module population_analysis implicit none character ( len =* ), parameter :: module_name = \"population_analysis\" integer , parameter :: POP_MULLIKEN = 0 integer , parameter :: POP_LOWDIN = 1 private public mulliken public lowdin public run_population_analysis public POP_MULLIKEN public POP_LOWDIN public mulliken_excited !-------------------------------------------------------------------------------- contains !-------------------------------------------------------------------------------- subroutine mulliken_C ( c_handle ) bind ( C , name = \"mulliken\" ) use c_interop , only : oqp_handle_t , oqp_handle_get_info , oqp_handle_refresh_ptr use strings , only : Cstring use types , only : information type ( oqp_handle_t ) :: c_handle type ( information ), pointer :: inf inf => oqp_handle_get_info ( c_handle ) call mulliken ( inf ) end subroutine mulliken_C !-------------------------------------------------------------------------------- subroutine mulliken_excited_C ( c_handle ) bind ( C , name = \"mulliken_excited\" ) use c_interop , only : oqp_handle_t , oqp_handle_get_info , oqp_handle_refresh_ptr use strings , only : Cstring use types , only : information type ( oqp_handle_t ) :: c_handle type ( information ), pointer :: inf inf => oqp_handle_get_info ( c_handle ) call mulliken_excited ( inf ) end subroutine mulliken_excited_C !-------------------------------------------------------------------------------- subroutine lowdin_C ( c_handle ) bind ( C , name = \"lowdin\" ) use c_interop , only : oqp_handle_t , oqp_handle_get_info , oqp_handle_refresh_ptr use strings , only : Cstring use types , only : information type ( oqp_handle_t ) :: c_handle type ( information ), pointer :: inf inf => oqp_handle_get_info ( c_handle ) call lowdin ( inf ) end subroutine lowdin_C !-------------------------------------------------------------------------------- !-------------------------------------------------------------------------------- !> @brief Mulliken population analysis for MRSF-TDDFT excited states !> !> Computes Mulliken charges for a target excited state using: !>   P_excited = P_ground + Delta_P !> where Delta_P is the excited-state difference density (relaxed or unrelaxed). !> !> @param[in]  infos   OQP handle !> !> @author   Mohsen !> !> REVISION HISTORY: !> @date _Apr, 2026_ Initial release !-------------------------------------------------------------------------------- subroutine mulliken_excited ( infos ) use precision , only : dp use io_constants , only : iw use basis_tools , only : basis_set use messages , only : show_message , with_abort use types , only : information use oqp_tagarray_driver use mathlib , only : unpack_matrix implicit none character ( len =* ), parameter :: module_name = \"mulliken_excited\" type ( information ), target , intent ( inout ) :: infos type ( basis_set ), pointer :: basis real ( kind = dp ), allocatable :: orbital_pop (:) real ( kind = dp ), allocatable :: chg (:) real ( kind = dp ), allocatable :: dens (:,:), tmp (:) integer :: nat , nbf , nbf2 , ok , istate logical :: urohf , use_relaxed ! tagarray pointers real ( kind = dp ), contiguous , pointer :: dmat_a (:), dmat_b (:), smat (:) real ( kind = dp ), contiguous , pointer :: td_p (:,:), td_abxc (:) !    character(len=*), parameter :: tags_required(8) = (/ character(len=80) :: & !      OQP_FOCK_A, OQP_E_MO_A, OQP_VEC_MO_A, OQP_FOCK_B, OQP_VEC_MO_B, OQP_td_bvec_mo, OQP_td_t, & !      OQP_td_energies /) character ( len =* ), parameter :: tags_required ( 5 ) = ( / character ( len = 80 ) :: & OQP_DM_A , OQP_DM_B , OQP_TD_P , OQP_TD_ABXC , OQP_SM / ) character ( len =* ), parameter :: subroutine_name = \"mulliken_excited\" open ( unit = IW , file = infos % log_filename , position = \"append\" ) basis => infos % basis basis % atoms => infos % atoms nat = ubound ( infos % atoms % zn , 1 ) nbf = basis % nbf nbf2 = nbf * ( nbf + 1 ) / 2 urohf = infos % control % scftype == 2 . or . infos % control % scftype == 3 istate = infos % tddft % target_state use_relaxed = . true . allocate ( orbital_pop ( nbf ), & chg ( nat ), & tmp ( nbf2 ), & dens ( nbf , nbf ), & source = 0.0d0 , stat = ok ) if ( ok /= 0 ) call show_message ( 'Cannot allocate memory' , WITH_ABORT ) call data_has_tags ( infos % dat , tags_required , module_name , subroutine_name , WITH_ABORT ) call tagarray_get_data ( infos % dat , OQP_DM_A , dmat_a ) tmp = dmat_a if ( urohf ) then call tagarray_get_data ( infos % dat , OQP_DM_B , dmat_b ) tmp = tmp + dmat_b end if if ( use_relaxed ) then ! Try to get the relaxed density first call tagarray_get_data ( infos % dat , OQP_TD_P , td_p ) tmp = tmp + td_p (:, 1 ) + td_p (:, 2 ) write ( iw , '(4x,a)' ) 'Using RELAXED difference density (Z-vector)' else ! Fall back to unrelaxed density call tagarray_get_data ( infos % dat , OQP_TD_ABXC , td_abxc ) tmp = tmp + td_abxc write ( iw , '(4x,a)' ) 'Using UNRELAXED difference density' end if call tagarray_get_data ( infos % dat , OQP_SM , smat ) call unpack_matrix ( tmp , dens ) call get_orb_pop_mulliken ( smat , dens , orbital_pop ) call get_atomic_pop ( basis , orbital_pop , chg ) chg = infos % atoms % zn - infos % basis % ecp_zn_num - chg !   ----------------------------------------------------------------------- !   Print results !   ----------------------------------------------------------------------- write ( iw , '(2/)' ) write ( iw , '(4x,a)' ) '=============================================' write ( iw , '(4x,a,i4)' ) 'Mulliken population analysis for state ' , istate write ( iw , '(4x,a)' ) '=============================================' call flush ( iw ) write ( iw , '(/,2X,A,I4)' ) 'Gross AO population (Mulliken) - State ' , istate call print_ao_pop ( infos , orbital_pop ) write ( iw , '(/,2X,A,I4)' ) 'Atomic partial charges (Mulliken) - State ' , istate call print_charges ( infos , chg ) close ( iw ) deallocate ( orbital_pop , chg , tmp , dens ) end subroutine mulliken_excited !> @brief Store a per-atom charge vector to a tagarray so it can be written !>   to the reference/restart JSON and regression-tested from Python. subroutine store_atom_charges ( infos , tag , comment , chg ) use precision , only : dp use types , only : information use oqp_tagarray_driver , only : tagarray_get_data , TA_TYPE_REAL64 type ( information ), target , intent ( inout ) :: infos character ( len =* ), intent ( in ) :: tag , comment real ( kind = dp ), intent ( in ) :: chg (:) real ( kind = dp ), contiguous , pointer :: chgout (:) integer :: nat nat = size ( chg ) call infos % dat % alloc_or_die ( tag , ( / nat / ), chgout , description = comment ) chgout ( 1 : nat ) = chg ( 1 : nat ) end subroutine store_atom_charges subroutine mulliken ( infos ) use precision , only : dp use io_constants , only : iw use basis_tools , only : basis_set use messages , only : show_message , with_abort use types , only : information use strings , only : Cstring , fstring use oqp_tagarray_driver , only : OQP_mulliken_charges , OQP_mulliken_charges_comment implicit none type ( information ), target , intent ( inout ) :: infos type ( basis_set ), pointer :: basis real ( kind = dp ), allocatable :: orbital_pop (:) real ( kind = dp ), allocatable :: chg (:) integer :: nat , ok open ( unit = IW , file = infos % log_filename , position = \"append\" ) !   Load basis set basis => infos % basis basis % atoms => infos % atoms nat = ubound ( infos % atoms % zn , 1 ) allocate ( orbital_pop ( basis % nbf ), & chg ( nat ), & source = 0.0d0 , stat = ok ) if ( ok /= 0 ) call show_message ( 'Cannot allocate memory' , WITH_ABORT ) write ( iw , '(2/)' ) write ( iw , '(4x,a)' ) '============================' write ( iw , '(4x,a)' ) 'Mulliken population analysis' write ( iw , '(4x,a)' ) '============================' call flush ( iw ) call run_population_analysis ( infos , basis , orbital_pop , chg , POP_MULLIKEN ) write ( iw , '(/,2X,A)' ) 'Gross AO population (Mulliken)' call print_ao_pop ( infos , orbital_pop ) write ( iw , '(/,2X,A)' ) 'Atomic partial charges (Mulliken)' call print_charges ( infos , chg ) call store_atom_charges ( infos , OQP_mulliken_charges , & OQP_mulliken_charges_comment , chg ) close ( iw ) end subroutine mulliken !-------------------------------------------------------------------------------- subroutine lowdin ( infos ) use precision , only : dp use io_constants , only : iw use basis_tools , only : basis_set use messages , only : show_message , with_abort use types , only : information use strings , only : Cstring , fstring use oqp_tagarray_driver , only : OQP_lowdin_charges , OQP_lowdin_charges_comment implicit none type ( information ), target , intent ( inout ) :: infos type ( basis_set ), pointer :: basis real ( kind = dp ), allocatable :: orbital_pop (:) real ( kind = dp ), allocatable :: chg (:) integer :: nat , ok open ( unit = IW , file = infos % log_filename , position = \"append\" ) !   Load basis set basis => infos % basis basis % atoms => infos % atoms nat = ubound ( infos % atoms % zn , 1 ) allocate ( orbital_pop ( basis % nbf ), & chg ( nat ), & source = 0.0d0 , stat = ok ) if ( ok /= 0 ) call show_message ( 'Cannot allocate memory' , WITH_ABORT ) write ( iw , '(2/)' ) write ( iw , '(4x,a)' ) '==========================' write ( iw , '(4x,a)' ) 'Lowdin population analysis' write ( iw , '(4x,a)' ) '==========================' call flush ( iw ) call run_population_analysis ( infos , basis , orbital_pop , chg , POP_LOWDIN ) write ( iw , '(/,2X,A)' ) 'Gross AO population (Lowdin)' call print_ao_pop ( infos , orbital_pop ) write ( iw , '(/,2X,A)' ) 'Atomic partial charges (Lowdin)' call print_charges ( infos , chg ) call store_atom_charges ( infos , OQP_lowdin_charges , & OQP_lowdin_charges_comment , chg ) close ( iw ) end subroutine lowdin !-------------------------------------------------------------------------------- !> @brief Run population analysis !> !> @param[in]      infos        QOP handle, fortran !> @param[in]      basis        basis set !> @param[out]     orbital_pop  AO population !> @param[out]     chg          atomic partial charges !> @param[in]      sel          Mulliken(0) or Lowdin(1) analysis selector ! !> @author   Vladimir Mironov ! !     REVISION HISTORY: !> @date _Mar, 2023_ Initial release subroutine run_population_analysis ( infos , basis , orbital_pop , chg , sel ) use precision , only : dp use oqp_tagarray_driver use types , only : information use basis_tools , only : basis_set use messages , only : show_message , with_abort use mathlib , only : unpack_matrix implicit none character ( len =* ), parameter :: subroutine_name = \"run_population_analysis\" type ( information ), intent ( inout ) :: infos type ( basis_set ), intent ( in ) :: basis real ( kind = dp ), allocatable , intent ( inout ) :: orbital_pop (:), chg (:) integer , intent ( in ) :: sel integer :: nbf , nbf2 , ok logical :: urohf real ( kind = dp ), allocatable :: dens (:,:), tmp (:) ! tagarray real ( kind = dp ), contiguous , pointer :: dmat_a (:), dmat_b (:), smat (:) character ( len =* ), parameter :: tags_alpha ( 2 ) = ( / character ( len = 80 ) :: & OQP_SM , OQP_DM_A / ) character ( len =* ), parameter :: tags_beta ( 1 ) = ( / character ( len = 80 ) :: & OQP_DM_B / ) ! Allocate memory nbf = basis % nbf nbf2 = nbf * ( nbf + 1 ) / 2 urohf = infos % control % scftype == 2 . or . infos % control % scftype == 3 allocate ( tmp ( nbf2 ), dens ( nbf , nbf ), source = 0.0d0 , stat = ok ) if ( ok /= 0 ) call show_message ( 'Cannot allocate memory' , WITH_ABORT ) call data_has_tags ( infos % dat , tags_alpha , module_name , subroutine_name , WITH_ABORT ) call tagarray_get_data ( infos % dat , OQP_DM_A , dmat_a ) call tagarray_get_data ( infos % dat , OQP_SM , smat ) tmp = dmat_a if ( urohf ) then call data_has_tags ( infos % dat , tags_beta , module_name , subroutine_name , WITH_ABORT ) call tagarray_get_data ( infos % dat , OQP_DM_B , dmat_b ) tmp = tmp + dmat_b end if ! Make density matrix call unpack_matrix ( tmp , dens ) ! Run the analysis select case ( sel ) case ( POP_MULLIKEN ) call get_orb_pop_mulliken ( smat , dens , orbital_pop ) case ( POP_LOWDIN ) call get_orb_pop_lowdin ( smat , dens , orbital_pop ) case default call show_message ( 'Unknown population analysis method' , WITH_ABORT ) end select ! Get electronic populations on aotms call get_atomic_pop ( basis , orbital_pop , chg ) ! Compute partial charges chg = infos % atoms % zn - infos % basis % ecp_zn_num - chg end subroutine !-------------------------------------------------------------------------------- !> @brief Compute Mulliken's atomic orbital population !> !> @brief Compute atomic population from orbital population !> !> @param[in]      s            overlap matrix, packed !> @param[in]      d            density matrix, square !> @param[out]     pop          AO population ! !> @author   Vladimir Mironov ! !     REVISION HISTORY: !> @date _Mar, 2023_ Initial release subroutine get_atomic_pop ( basis , ao_pop , at_pop ) use precision , only : dp use basis_tools , only : basis_set use constants , only : NUM_CART_BF implicit none type ( basis_set ), intent ( in ) :: basis real ( kind = dp ), intent ( in ) :: ao_pop (:) real ( kind = dp ), intent ( out ) :: at_pop (:) integer :: i , iatom , i0 , i1 do i = 1 , basis % nshell iatom = basis % origin ( i ) i0 = basis % ao_offset ( i ) i1 = basis % ao_offset ( i ) + basis % naos ( i ) - 1 ! AO count per shell (spherical-aware) at_pop ( iatom ) = at_pop ( iatom ) + sum ( ao_pop ( i0 : i1 )) end do end subroutine !-------------------------------------------------------------------------------- !> @brief Compute Mulliken's atomic orbital population !> !> @param[in]      s            overlap matrix, packed !> @param[in]      d            density matrix, square !> @param[out]     pop          AO population ! !> @author   Vladimir Mironov ! !     REVISION HISTORY: !> @date _Mar, 2023_ Initial release subroutine get_orb_pop_mulliken ( s , d , pop ) use precision , only : dp use mathlib , only : unpack_matrix implicit none real ( kind = dp ), intent ( in ) :: s (:), d (:,:) real ( kind = dp ), intent ( out ) :: pop (:) real ( kind = dp ), allocatable :: stmp (:,:) integer :: nbf nbf = ubound ( d , 1 ) allocate ( stmp ( nbf , nbf )) call unpack_matrix ( s , stmp ) pop = sum ( d * stmp , dim = 2 ) end subroutine !-------------------------------------------------------------------------------- !> @brief Compute orbital population using Lowdin's symmetrically !>        orthogonalized basis set !> !> @param[in]      s            overlap matrix, packed !> @param[in]      d            density matrix, square !> @param[out]     pop          AO population ! !> @author   Vladimir Mironov ! !     REVISION HISTORY: !> @date _Mar, 2023_ Initial release subroutine get_orb_pop_lowdin ( s , d , pop ) use precision , only : dp use eigen , only : diag_symm_packed use mathlib , only : unpack_matrix use oqp_linalg implicit none real ( kind = dp ), intent ( in ) :: s (:), d (:,:) real ( kind = dp ), intent ( out ) :: pop (:) real ( kind = dp ), allocatable :: stmp (:), tmp (:,:), & eval (:), evec (:,:), ovlsqrt (:,:) integer :: ierr integer :: nbf , i nbf = ubound ( d , 1 ) allocate ( eval ( nbf ), evec ( nbf , nbf ), tmp ( nbf , nbf ), ovlsqrt ( nbf , nbf )) ! Compute S&#94;{1/2} stmp = s call diag_symm_packed ( 1 , nbf , nbf , nbf , stmp , eval , evec , ierr ) do i = 1 , nbf tmp (:, i ) = evec (:, i ) * sqrt ( eval ( i )) end do call dgemm ( 'n' , 't' , nbf , nbf , nbf , & 1.0d0 , evec , nbf , & tmp , nbf , & 0.0d0 , ovlsqrt , nbf ) ! Compute Tr(S&#94;{1/2}*dens*S&#94;{1/2}) call dgemm ( 'n' , 't' , nbf , nbf , nbf , & 1.0d0 , ovlsqrt , nbf , & d , nbf , & 0.0d0 , tmp , nbf ) pop = sum ( tmp * ovlsqrt , dim = 2 ) end subroutine !-------------------------------------------------------------------------------- !> @brief Print partial charges !> !> @param[in]      infos        OQP handle !> @param[in]      chg          atomic partial charges ! !> @author   Vladimir Mironov ! !     REVISION HISTORY: !> @date _Mar, 2023_ Initial release subroutine print_charges ( infos , chg ) use precision , only : dp use elements , only : ELEMENTS_SHORT_NAME use types , only : information type ( information ), intent ( in ) :: infos real ( kind = dp ), intent ( in ) :: chg (:) integer :: i , elem , nat nat = ubound ( infos % atoms % zn , 1 ) write ( * , '(/,30(\"&#94;\"))' ) write ( * , '(/a8,a8,a14)' ) '#' , 'Name' , 'Charge' write ( * , '(30(\"-\"))' ) do i = 1 , nat elem = nint ( infos % atoms % zn ( i )) write ( * , '(i8,a8,f14.6)' ) i , ELEMENTS_SHORT_NAME ( elem ), chg ( i ) end do write ( * , '(30(\"=\"))' ) end subroutine print_charges !-------------------------------------------------------------------------------- !> @brief Print gross AO population !> !> @param[in]      infos        OQP handle !> @param[in]      pop          atomic orbital population ! !> @author   Vladimir Mironov ! !     REVISION HISTORY: !> @date _Mar, 2023_ Initial release subroutine print_ao_pop ( infos , pop ) use precision , only : dp use types , only : information type ( information ), intent ( in ) :: infos real ( kind = dp ), intent ( in ) :: pop (:) integer :: i , nbf nbf = infos % basis % nbf write ( * , '(/,34(\"&#94;\"))' ) write ( * , '(/a8,a11,a15)' ) '#' , 'A  N  L' , 'Population' write ( * , '(34(\"-\"))' ) do i = 1 , nbf write ( * , '(i8,a12,f14.6)' ) i , infos % basis % bf_label ( i ), pop ( i ) end do write ( * , '(34(\"=\"))' ) end subroutine print_ao_pop !-------------------------------------------------------------------------------- end module population_analysis","tags":"","url":"sourcefile/population_analysis.f90.html"},{"title":"messages.F90 – OpenQP Fortran API","text":"MODULE messages Source Code !*MODULE messages !> @brief   This module provides routines where the output is !> @details Mostly, this file is needed for simplifying of usage !>            the LibXC interface in different software !>          For GAMESS(US), this file can be expanded for other messages !>            For example, aborting with printing custom message !> @author  Igor S. Gerasimov !> @date    July, 2021 - Initial release - !> @todo    Remove it !> @params  WITH_ABORT    - logical key for stopmode; stop will be !> @params  WITHOUT_ABORT - logical key for stopmode; stop will not be module messages use precision , only : dp #ifdef OQP use io_constants , only : write_unit => iw #else use comm_IOFILE , only : write_unit => IW use comm_PAR , only : master_worker => MASWRK #endif implicit none private logical , parameter :: WITH_ABORT = . true . logical , parameter :: WITHOUT_ABORT = . false . interface show_message module procedure show_message_text , & show_message_with_integer , & show_message_with_double , & show_message_with_double_and_text , & show_message_with_integer_and_text , & show_message_with_keys end interface show_message public show_message , with_abort , without_abort contains !> @brief   Print simple message !> @author  Igor S. Gerasimov !> @date    July, 2021 - Initial release - !> @params  message  (in)           - message for displaying !> @params  stopmode (in, optional) - is aborting required? subroutine show_message_text ( message , stopmode ) character ( len =* ), intent ( in ) :: message logical , intent ( in ), optional :: stopmode logical :: stopmode_ if (. not . present ( stopmode )) then stopmode_ = WITHOUT_ABORT else stopmode_ = stopmode end if #ifndef OQP if ( master_worker ) & #endif write ( write_unit , \"(A)\" ) message call abort ( stopmode_ ) end subroutine show_message_text !> @brief   Print simple message !> @details write( ,format) message, value !> @author  Igor S. Gerasimov !> @date    July, 2021 - Initial release - !> @params  format   (in)           - format for displaying !> @params  message  (in)           - message for displaying !> @params  value    (in)           - value for displaying !> @params  stopmode (in, optional) - is aborting required? subroutine show_message_with_integer ( format , message , value , stopmode ) character ( len =* ), intent ( in ) :: format character ( len =* ), intent ( in ) :: message integer , intent ( in ) :: value logical , intent ( in ), optional :: stopmode logical :: stopmode_ if (. not . present ( stopmode )) then stopmode_ = WITHOUT_ABORT else stopmode_ = stopmode end if #ifndef OQP if ( master_worker ) & #endif write ( write_unit , format ) message , value call abort ( stopmode_ ) end subroutine show_message_with_integer !> @brief   Print simple message !> @details write( ,format) message, value !> @author  Igor S. Gerasimov !> @date    July, 2021 - Initial release - !> @params  format   (in)           - format for displaying !> @params  message  (in)           - message for displaying !> @params  value    (in)           - value for displaying !> @params  stopmode (in, optional) - is aborting required? subroutine show_message_with_double ( format , message , value , stopmode ) character ( len =* ), intent ( in ) :: format character ( len =* ), intent ( in ) :: message real ( dp ), intent ( in ) :: value logical , intent ( in ), optional :: stopmode logical :: stopmode_ if (. not . present ( stopmode )) then stopmode_ = WITHOUT_ABORT else stopmode_ = stopmode end if #ifndef OQP if ( master_worker ) & #endif write ( write_unit , format ) message , value call abort ( stopmode_ ) end subroutine show_message_with_double !> @brief   Print simple message !> @details write( ,format) message1, value, message2 !> @author  Igor S. Gerasimov !> @date    July, 2021 - Initial release - !> @params  format   (in)           - format for displaying !> @params  message1 (in)           - message for displaying !> @params  value    (in)           - value for displaying !> @params  message2 (in)           - message for displaying !> @params  stopmode (in, optional) - is aborting required? subroutine show_message_with_double_and_text ( format , message1 , value , message2 , stopmode ) character ( len =* ), intent ( in ) :: format character ( len =* ), intent ( in ) :: message1 , message2 real ( kind = dp ), intent ( in ) :: value logical , intent ( in ), optional :: stopmode logical :: stopmode_ if (. not . present ( stopmode )) then stopmode_ = WITHOUT_ABORT else stopmode_ = stopmode end if #ifndef OQP if ( master_worker ) & #endif write ( write_unit , format ) message1 , value , message2 call abort ( stopmode_ ) end subroutine show_message_with_double_and_text !> @brief   Print simple message !> @details write( ,format) message1, value, message2 !> @author  Igor S. Gerasimov !> @date    July, 2021 - Initial release - !> @params  format   (in)           - format for displaying !> @params  message1 (in)           - message for displaying !> @params  value    (in)           - value for displaying !> @params  message2 (in)           - message for displaying !> @params  stopmode (in, optional) - is aborting required? subroutine show_message_with_integer_and_text ( format , message1 , value , message2 , stopmode ) character ( len =* ), intent ( in ) :: format character ( len =* ), intent ( in ) :: message1 , message2 integer , intent ( in ) :: value logical , intent ( in ), optional :: stopmode logical :: stopmode_ if (. not . present ( stopmode )) then stopmode_ = WITHOUT_ABORT else stopmode_ = stopmode end if #ifndef OQP if ( master_worker ) & #endif write ( write_unit , format ) message1 , value , message2 call abort ( stopmode_ ) end subroutine show_message_with_integer_and_text !> @brief   Print simple message !> @details write( ,'(A)') message !>          write( ,format) keys !> @author  Igor S. Gerasimov !> @date    July, 2021 - Initial release - !> @params  message  (in)           - message for displaying !> @params  format   (in)           - format for displaying !> @params  keys     (in)           - keys for displaying !> @params  stopmode (in, optional) - is aborting required? subroutine show_message_with_keys ( message , format , keys , stopmode ) character ( len =* ), intent ( in ) :: message character ( len =* ), intent ( in ) :: format character ( len =* ), intent ( in ), optional :: keys (:) logical , intent ( in ), optional :: stopmode logical :: stopmode_ if (. not . present ( stopmode )) then stopmode_ = WITHOUT_ABORT else stopmode_ = stopmode end if #ifndef OQP if ( master_worker ) then #endif write ( write_unit , \"(A)\" ) message write ( write_unit , format ) keys #ifndef OQP end if #endif call abort ( stopmode_ ) end subroutine show_message_with_keys subroutine abort ( stopmode ) logical , intent ( in ) :: stopmode flush ( write_unit ) if ( stopmode ) then #ifdef OQP #ifdef __GFORTRAN__ call backtrace #endif error stop \"See above\" #else call abrt #endif end if end subroutine abort end module messages","tags":"","url":"sourcefile/messages.f90.html"},{"title":"tdhf_sf_z_vector.F90 – OpenQP Fortran API","text":"Source Code module tdhf_sf_z_vector_mod implicit none character ( len =* ), parameter :: module_name = \"tdhf_sf_z_vector_mod\" contains subroutine tdhf_sf_z_vector_C ( c_handle ) bind ( C , name = \"tdhf_sf_z_vector\" ) use c_interop , only : oqp_handle_t , oqp_handle_get_info use types , only : information type ( oqp_handle_t ) :: c_handle type ( information ), pointer :: inf inf => oqp_handle_get_info ( c_handle ) call tdhf_sf_z_vector ( inf ) end subroutine tdhf_sf_z_vector_C subroutine tdhf_sf_z_vector ( infos ) use precision , only : dp use , intrinsic :: ieee_arithmetic , only : ieee_is_finite use io_constants , only : iw use oqp_tagarray_driver use types , only : information use strings , only : Cstring , fstring use basis_tools , only : basis_set use messages , only : show_message , with_abort use util , only : measure_time use int2_compute , only : int2_compute_t use tdhf_lib , only : int2_td_data_t use tdhf_lib , only : int2_tdgrd_data_t use tdhf_lib , only : iatogen , mntoia use tdhf_sf_lib , only : sfrorhs , & sfromcal , sfrogen , sfrolhs , pcgrbpini , & pcgb , sfropcal , sfrowcal , sfdmat use dft , only : dft_initialize , dftclean use mod_dft_gridint_fxc , only : utddft_fxc use mathlib , only : symmetrize_matrix , orthogonal_transform_sym , orthogonal_transform use mod_dft_molgrid , only : dft_grid_t use mathlib , only : pack_matrix , unpack_matrix use oqp_linalg use printing , only : print_module_info use zvector_common , only : sanitize_zvector_preconditioner , & zv_opts_t , zv_read_opts , zv_prog_tau implicit none character ( len =* ), parameter :: subroutine_name = \"tdhf_sf_z_vector\" real ( kind = dp ), parameter :: SF_ZVEC_DENOMINATOR_FLOOR = 1.0d-12 type ( zv_opts_t ) :: zvo real ( kind = dp ) :: zv_rc_tight type ( basis_set ), pointer :: basis type ( information ), target , intent ( inout ) :: infos integer :: ok real ( kind = dp ), allocatable :: ab1_mo_a (:,:) real ( kind = dp ), allocatable :: ab1_mo_b (:,:) real ( kind = dp ), allocatable :: xm (:) real ( kind = dp ), pointer :: ab2 (:,:,:) real ( kind = dp ), pointer :: ab1 (:,:,:) real ( kind = dp ), allocatable :: fa (:,:), fb (:,:) real ( kind = dp ), pointer :: bvec (:,:,:) real ( kind = dp ), pointer :: wmo (:,:) integer :: nocca , nvira , noccb , nvirb integer :: nbf , nbf_tri integer :: iter real ( kind = dp ) :: cnvtol , scale_exch , scale_exch2 logical :: roref = . false . type ( int2_compute_t ) :: int2_driver class ( int2_td_data_t ), allocatable , target :: int2_data type ( dft_grid_t ) :: molGrid ! scr data real ( kind = dp ), allocatable , target :: wrk1 (:,:), wrk2 (:,:), wrk3 (:,:) real ( kind = dp ), pointer :: wrk1t (:) ! SF-TD Gradient data real ( kind = dp ), allocatable :: & rhs (:), lhs (:), xminv (:), xk (:), pk (:), errv (:), & hxa (:,:), hxb (:,:), tij (:,:), ppija (:,:), ppijb (:,:), tab (:,:) real ( kind = dp ), allocatable , target :: pa (:,:,:) integer :: nsocc , lzdim ! General data real ( kind = dp ) :: alpha , error , pap logical :: dft , zvector_breakdown integer :: scf_type , mol_mult ! tagarray real ( kind = dp ), contiguous , pointer :: & fock_a (:), mo_a (:,:), mo_energy_a (:), td_abxc (:,:), & fock_b (:), mo_b (:,:), & wao (:), td_p (:,:), td_t (:,:), & ta (:), tb (:), bvec_mo (:,:), sf_energies (:) character ( len =* ), parameter :: tags_alloc ( 3 ) = ( / character ( len = 80 ) :: & OQP_WAO , OQP_td_p , OQP_td_abxc / ) character ( len =* ), parameter :: tags_required ( 8 ) = ( / character ( len = 80 ) :: & OQP_FOCK_A , OQP_E_MO_A , OQP_VEC_MO_A , OQP_FOCK_B , OQP_VEC_MO_B , OQP_td_bvec_mo , OQP_td_t , & OQP_td_energies / ) mol_mult = infos % mol_prop % mult !   if (.not. (mol_mult == 3 .or. mol_mult == 4)) then !     call show_message( & !       'SF-TDDFT only supports mult=3 (triplet) or mult=4 (quartet) references', & !       with_abort) !   end if scf_type = infos % control % scftype if ( scf_type == 3 ) roref = . true . dft = infos % control % hamilton == 20 ! Files open ! 3. LOG: Write: Main output file open ( unit = IW , file = infos % log_filename , position = \"append\" ) ! call print_module_info ( 'SF_TDHF_Z_Vector' , 'Solving Z-Vector for SF-TDDFT' ) ! Readings ! Load basis set basis => infos % basis basis % atoms => infos % atoms nbf = basis % nbf nbf_tri = nbf * ( nbf + 1 ) / 2 if ( dft ) call dft_initialize ( infos , basis , molGrid ) ! Parameter it should be inputed later ! convergence tolerance in the iterative TD-DFT step. cnvtol = infos % tddft % zvconv ! Shared z-vector perf opt-ins (env OQP_SF_ZV_*); progressive screening ! default ON, zvconv override default off (see zvector_common). call zv_read_opts ( zvo , \"SF\" ) if ( zvo % conv_user > 0.0_dp ) cnvtol = zvo % conv_user nocca = infos % mol_prop % nelec_A nvira = nbf - noccA noccb = infos % mol_prop % nelec_B nvirb = nbf - noccB nsocc = nocca - noccb lzdim = noccb * ( nsocc + nvira ) + nsocc * nvira allocate (& ! for Z-vector xminv ( lzdim ), & rhs ( lzdim ), & lhs ( lzdim ), & xm ( lzdim ), & xk ( lzdim ), & pk ( lzdim ), & errv ( lzdim ), & ! for gradient hxa ( nbf , nocca ), & hxb ( nbf , nbf ), & tij ( nocca , nocca ), & tab ( nvirb , nvirb ), & ppija ( nocca , nocca ), & ppijb ( noccb , noccb ), & pa ( nbf , nbf , 2 ), & ! Allocate TDDFT variables fa ( nbf , nbf ), & ! Temporary matrix for diagonalization fb ( nbf , nbf ), & ! Temporary matrix for diagonalization ab1_MO_a ( nocca , nvirb ), & ab1_MO_b ( noccb , nvirb ), & !   For scratch wrk1 ( nbf , nbf ), & wrk2 ( nbf , nbf ), & wrk3 ( nbf , nbf ), & stat = ok , & source = 0.0_dp ) if ( ok /= 0 ) call show_message ( 'Cannot allocate memory' , with_abort ) call infos % dat % alloc_or_die ( OQP_WAO , ( / nbf_tri / ), wao , description = OQP_WAO_comment ) call infos % dat % alloc_or_die ( OQP_td_p , ( / nbf_tri , 2 / ), td_p , description = OQP_td_p_comment ) call infos % dat % alloc_or_die ( OQP_td_abxc , ( / nbf , nbf / ), td_abxc , description = OQP_td_abxc ) call data_has_tags ( infos % dat , tags_required , module_name , subroutine_name , WITH_ABORT ) call tagarray_get_data ( infos % dat , OQP_FOCK_A , fock_a ) call tagarray_get_data ( infos % dat , OQP_FOCK_B , fock_b ) call tagarray_get_data ( infos % dat , OQP_E_MO_A , mo_energy_a ) call tagarray_get_data ( infos % dat , OQP_VEC_MO_A , mo_a ) call tagarray_get_data ( infos % dat , OQP_VEC_MO_B , mo_b ) call tagarray_get_data ( infos % dat , OQP_td_bvec_mo , bvec_mo ) call tagarray_get_data ( infos % dat , OQP_td_t , td_t ) call tagarray_get_data ( infos % dat , OQP_td_energies , sf_energies ) ta => td_t (:, 1 ) tb => td_t (:, 2 ) ! Save unrelaxed density matrices and the `b=A*x` vector for target state call sfdmat ( bvec_mo (:, infos % tddft % target_state ), td_abxc , mo_a , ta , tb , nocca , noccb ) ! Initialize ERI calculations ! Progressive screening keeps init at the tight cutoff (full pair list) and ! ramps the run-time threshold per CG iteration; restore tight for the tail. zv_rc_tight = infos % control % int2e_cutoff call int2_driver % init ( basis , infos ) call int2_driver % set_screening () write ( * , '(/1x,71(\"-\")& &/19x,\"SF-DFT ENERGY GRADIENT CALCULATION\"& &/1x,71(\"-\")/)' ) write ( iw , fmt = '(5x,a/& &5x,16(\"-\")/& &5x,a,x,i0,x,f17.10,x,\"Hartree\"/& &5x,a,x,e10.4/& &5x,a,x,i0)' ) & 'Z-vector options' & , 'Target state       is' , infos % tddft % target_state , infos % mol_energy % energy + sf_energies ( infos % tddft % target_state ) & , 'Convergence        is' , infos % tddft % zvconv & , 'Maximum iterations is' , infos % control % maxit_zv call flush ( iw ) bvec ( 1 : nbf , 1 : nbf , 1 : 1 ) => td_abxc ! Prepare for ROHF ! Fock matrices A and B if ( roref ) then wrk1t ( 1 : nbf * nbf ) => wrk1 !   Alapha call orthogonal_transform_sym ( nbf , nbf , fock_a , mo_a , nbf , wrk1 ) call unpack_matrix ( wrk1t , fa ) !   Beta call orthogonal_transform_sym ( nbf , nbf , fock_b , mo_b , nbf , wrk1 ) call unpack_matrix ( wrk1t , fb ) end if ! Make density like part call unpack_matrix ( ta , pa (:,:, 1 )) call unpack_matrix ( tb , pa (:,:, 2 )) ! Initialize ERI calculations scale_exch = 1.0_dp scale_exch2 = 1.0_dp if ( dft ) then scale_exch = infos % dft % HFscale ! Reference HF exchange scale_exch2 = infos % tddft % HFscale ! Response HF exchange end if int2_data = int2_tdgrd_data_t ( d2 = pa , & int_apb = . true ., & int_amb = . false ., & tamm_dancoff = . false ., & scale_exchange = scale_exch ) call int2_driver % run ( int2_data , & cam = dft . and . infos % dft % cam_flag , & alpha = infos % dft % cam_alpha , & beta = infos % dft % cam_beta ,& mu = infos % dft % cam_mu ) ab1 => int2_data % apb (:,:,:, 1 ) pa = pa * 2 call utddft_fxc ( basis = basis , & molGrid = molGrid , & isVecs = . true ., & wfa = MO_A , & wfb = MO_B , & fxa = ab1 (:,:, 1 : 1 ), & fxb = ab1 (:,:, 2 : 2 ), & dxa = pa (:,:, 1 : 1 ), & dxb = pa (:,:, 2 : 2 ), & nmtx = 1 , & !threshold=1.0d-15, & threshold = 0.0d0 , & infos = infos ) !   ALPHA: AO(M,N) -> MO(IA+) call mntoia ( ab1 (:,:, 1 ), ab1_mo_a , mo_a , mo_a , nocca , nocca ) call mntoia ( ab1 (:,:, 2 ), ab1_mo_b , mo_b , mo_b , noccb , noccb ) ! Initialize ERI calculations call int2_data % clean () deallocate ( int2_data ) int2_data = int2_td_data_t ( d2 = bvec , & int_apb = . false ., & int_amb = . false ., & tamm_dancoff = . true ., & scale_exchange = scale_exch2 ) call int2_driver % run ( int2_data , & cam = dft . and . infos % dft % cam_flag , & alpha = infos % tddft % cam_alpha , & beta = infos % tddft % cam_beta ,& mu = infos % tddft % cam_mu ) ab2 => int2_data % amb (:,:,:, 1 ) call orthogonal_transform ( 'n' , nbf , mo_a , ab2 (:,:, 1 ), wrk2 , wrk1 ) call iatogen ( bvec_mo (:, infos % tddft % target_state ), wrk3 , nocca , noccb ) call dgemm ( 'n' , 't' , nbf , nocca , nbf , & 2.0_dp , wrk2 , nbf , & wrk3 , nbf , & 0.0_dp , hxa , nbf ) call dgemm ( 't' , 'n' , nbf , nbf , nocca , & 2.0_dp , wrk2 , nbf , & wrk3 , nbf , & 0.0_dp , hxb , nbf ) !   Unrelaxed difference density matries T_ij and T_ab !     Ta(i+,j+):= -X(i+,a-)*X(j+,a-) for singlet and triplet call dgemm ( 'n' , 't' , nocca , nocca , nvirb , & - 1.0_dp , bvec_mo (:, infos % tddft % target_state ), nocca , & bvec_mo (:, infos % tddft % target_state ), nocca , & 0.0_dp , tij , nocca ) ! Tb(a-,b-):= X(i+,a-)*X(i+,b-) for singlet and triplet call dgemm ( 't' , 'n' , nvirb , nvirb , nocca , & 1.0_dp , bvec_mo (:, infos % tddft % target_state ), nocca , & bvec_mo (:, infos % tddft % target_state ), nocca , & 0.0_dp , tab , nvirb ) call sfrorhs ( rhs , hxa , hxb , ab1_mo_a , ab1_mo_b , & Tij , Tab , Fa , Fb , nocca , noccb ) write ( * , '(/3x,25(\"-\")& &/6x,\"START Z-VECTOR LOOP\"& &/3x,25(\"-\")/)' ) call flush ( iw ) call run_sf_cg_zvector () if ( zvo % prog_on ) call int2_driver % set_cutoff ( zv_rc_tight ) ! ----------------------------------------------- if ( zvector_breakdown ) then infos % mol_energy % Z_Vector_converged = . false . write ( * , '(/3x,24(\"-\")& &/6x,\"Z-Vector breakdown\"& &/3x,24(\"-\")/)' ) else if ( error > cnvtol ) then infos % mol_energy % Z_Vector_converged = . false . write ( * , '(/3x,24(\"-\")& &/6x,\"Z-Vector not converged\"& &/3x,24(\"-\")/)' ) else infos % mol_energy % Z_Vector_converged = . true . write ( * , '(/3x,24(\"-\")& &/6x,\"Z-Vector converged\"& &/3x,24(\"-\")/)' ) endif call flush ( iw ) if ( zvector_breakdown ) then call int2_driver % clean () if ( dft ) call dftclean ( infos ) call measure_time ( print_total = 1 , log_unit = iw ) close ( iw ) return end if call sfropcal ( wrk1 , wrk2 , tij , tab , xk , nocca , noccb ) !  Update density for alpha call orthogonal_transform ( 't' , nbf , mo_a , wrk1 , pa (:,:, 1 ), wrk3 ) !  Update density for beta call orthogonal_transform ( 't' , nbf , mo_b , wrk2 , pa (:,:, 2 ), wrk3 ) call int2_data % clean () deallocate ( int2_data ) int2_data = int2_tdgrd_data_t ( d2 = pa , & int_apb = . true ., int_amb = . false ., tamm_dancoff = . false ., & scale_exchange = scale_exch ) call int2_driver % run ( int2_data , & cam = dft . and . infos % dft % cam_flag , & alpha = infos % dft % cam_alpha , & beta = infos % dft % cam_beta ,& mu = infos % dft % cam_mu ) ab1 => int2_data % apb (:,:,:, 1 ) call symmetrize_matrix ( pa (:,:, 1 ), nbf ) call symmetrize_matrix ( pa (:,:, 2 ), nbf ) call pack_matrix ( pa (:,:, 1 ), td_p (:, 1 )) call pack_matrix ( pa (:,:, 2 ), td_p (:, 2 )) td_p = 0.5_dp * td_p call utddft_fxc ( basis = basis , & molGrid = molGrid , & isVecs = . true ., & wfa = MO_A , & wfb = MO_B , & fxa = ab1 (:,:, 1 : 1 ), & fxb = ab1 (:,:, 2 : 2 ), & dxa = pa (:,:, 1 : 1 ), & dxb = pa (:,:, 2 : 2 ), & nmtx = 1 , & !threshold=1.0d-15, & threshold = 0.0d0 , & infos = infos ) !   ALPHA AO(M,N) -> MO(I-,J-) ... LPPIJA call dgemm ( 'n' , 'n' , nbf , nocca , nbf , & 1.0_dp , ab1 (:,:, 1 ), nbf , & mo_a , nbf , & 0.0_dp , wrk2 , nbf ) call dgemm ( 't' , 'n' , nocca , nocca , nbf , & 1.0_dp , mo_a , nbf , & wrk2 , nbf , & 0.0_dp , ppija , nocca ) !   BETA: AO(M,N) -> MO(I-,J-) ... LPPIJB call dgemm ( 'n' , 'n' , nbf , noccb , nbf , & 1.0_dp , ab1 (:,:, 2 ), nbf , & mo_a , nbf , & 0.0_dp , wrk2 , nbf ) call dgemm ( 't' , 'n' , noccb , noccb , nbf , & 1.0_dp , mo_a , nbf , & wrk2 , nbf , & 0.0_dp , ppijb , noccb ) !   Calculate W (in MO basis) wmo => wrk3 wmo = 0 call sfrowcal ( wmo , sf_energies ( infos % tddft % target_state ), & mo_energy_a , fa , fb , bvec_mo (:, infos % tddft % target_state ), xk , & hxa , hxb , ppija , ppijb , & nocca , noccb ) call orthogonal_transform ( 't' , nbf , mo_a , wmo , wrk2 , wrk1 ) call symmetrize_matrix ( wrk2 , nbf ) call pack_matrix ( wrk2 , wao ) wao = wao * 0.5_dp !   ROHF, half one more time: wao = wao * 0.5_dp call int2_driver % clean () if ( dft ) call dftclean ( infos ) call measure_time ( print_total = 1 , log_unit = iw ) close ( iw ) contains ! Preconditioned CG z-vector solve.  All state is reached by host ! association, so this is behaviorally identical to the inline version. subroutine run_sf_cg_zvector () call sfromcal ( xm , xminv , mo_energy_a , fa , fb , nocca , noccb ) call sanitize_zvector_preconditioner ( xm , xminv , iw , SF_ZVEC_DENOMINATOR_FLOOR , \"SF\" ) call pcgrbpini ( errv , pk , error , rhs , xminv , lhs ) zvector_breakdown = . false . if (. not . ieee_is_finite ( error ) . or . any (. not . ieee_is_finite ( errv )) . or . & any (. not . ieee_is_finite ( pk )) . or . any (. not . ieee_is_finite ( lhs ))) then zvector_breakdown = . true . write ( * , '(/3x,24(\"-\")& &/6x,\"Z-Vector breakdown: non-finite initial PCG state\"& &/3x,24(\"-\")/)' ) end if write ( * , '(\" INITIAL ERROR =\",3X,1P,E10.3,1X,\"/\",1P,E10.3)' ) error , cnvtol ! ----------------------------------------------- do iter = 1 , infos % control % maxit_zv if ( zvector_breakdown ) exit call sfrogen ( wrk1 , wrk2 , pk , nocca , noccb ) !     Alpha call orthogonal_transform ( 't' , nbf , mo_a , wrk1 , pa (:,:, 1 ), wrk3 ) !     Beta call orthogonal_transform ( 't' , nbf , mo_b , wrk2 , pa (:,:, 2 ), wrk3 ) !     Progressive screening: loosen cutoff while the residual is large, pinned !     tight near convergence (zv_prog_tau); restored after the loop. if ( zvo % prog_on ) call int2_driver % set_cutoff ( zv_prog_tau ( zvo , error , zv_rc_tight )) !     (A+B)*PK call int2_data % clean () deallocate ( int2_data ) int2_data = int2_tdgrd_data_t ( d2 = pa , & int_apb = . true ., & int_amb = . false ., & tamm_dancoff = . false ., & scale_exchange = scale_exch ) call int2_driver % run ( int2_data , & cam = dft . and . infos % dft % cam_flag , & alpha = infos % dft % cam_alpha , & beta = infos % dft % cam_beta ,& mu = infos % dft % cam_mu ) ab1 => int2_data % apb (:,:,:, 1 ) !ab1 = ab1/2 call symmetrize_matrix ( pa (:,:, 1 ), nbf ) call symmetrize_matrix ( pa (:,:, 2 ), nbf ) call utddft_fxc ( basis = basis , & molGrid = molGrid , & isVecs = . true ., & wfa = MO_A , & wfb = MO_B , & fxa = ab1 (:,:, 1 : 1 ), & fxb = ab1 (:,:, 2 : 2 ), & dxa = pa (:,:, 1 : 1 ), & dxb = pa (:,:, 2 : 2 ), & nmtx = 1 , & !threshold=1.0d-15, & threshold = 0.0d0 , & infos = infos ) !     ALPHA: AO(M,N) -> MO(IA+) ... LPTMOA call mntoia ( ab1 (:,:, 1 ), ab1_mo_a , mo_a , mo_a , nocca , nocca ) call mntoia ( ab1 (:,:, 2 ), ab1_mo_b , mo_a , mo_a , noccb , noccb ) call sfrolhs ( lhs , pk , mo_energy_a , fa , fb , ab1_mo_a , ab1_mo_b , & nocca , noccb ) if ( any (. not . ieee_is_finite ( lhs )) . or . any (. not . ieee_is_finite ( pk ))) then zvector_breakdown = . true . write ( * , '(\" Z-Vector breakdown: non-finite SF PCG operator state at iter\", I4)' ) iter exit end if pap = dot_product ( pk , lhs ) if (. not . ieee_is_finite ( pap ) . or . abs ( pap ) < SF_ZVEC_DENOMINATOR_FLOOR ) then zvector_breakdown = . true . write ( * , '(\" Z-Vector breakdown: unsafe SF PCG denominator at iter\", I4, 1x, 1p,e12.4)' ) iter , pap exit end if alpha = 1.0_dp / pap if (. not . ieee_is_finite ( alpha )) then zvector_breakdown = . true . write ( * , '(\" Z-Vector breakdown: non-finite SF PCG alpha at iter\", I4)' ) iter exit end if xk = xk + pk * alpha errv = errv - alpha * lhs if ( any (. not . ieee_is_finite ( xk )) . or . any (. not . ieee_is_finite ( errv ))) then zvector_breakdown = . true . write ( * , '(\" Z-Vector breakdown: non-finite SF PCG update at iter\", I4)' ) iter exit end if error = dot_product ( errv , errv ) if (. not . ieee_is_finite ( error )) then zvector_breakdown = . true . write ( * , '(\" Z-Vector breakdown: non-finite SF PCG residual at iter\", I4)' ) iter exit end if write ( * , '(\" ITER#\",I2,\" ERROR =\",3X,1P,E10.3,1X,\"/\",1P,E10.3)' ) & iter , error , cnvtol call flush ( iw ) if ( error < cnvtol ) exit call pcgb ( pk , errv , xminv ) if ( any (. not . ieee_is_finite ( pk ))) then zvector_breakdown = . true . write ( * , '(\" Z-Vector breakdown: non-finite SF PCG search direction at iter\", I4)' ) iter exit end if end do end subroutine run_sf_cg_zvector end subroutine tdhf_sf_z_vector end module tdhf_sf_z_vector_mod","tags":"","url":"sourcefile/tdhf_sf_z_vector.f90.html"},{"title":"dft_fuzzycell.F90 – OpenQP Fortran API","text":"Source Code module mod_dft_fuzzycell use precision , only : fp use basis_tools , only : basis_set use mod_dft_partfunc , only : partition_function use mod_dft_molgrid , only : dft_grid_t implicit none real ( KIND = fp ), parameter :: HUGEFP = huge ( 1.0_fp ) real ( KIND = fp ), parameter :: PI = 3.141592653589793238463_fp real ( KIND = fp ), parameter :: FOUR_PI = 4.0_fp * PI private public prune_basis public dft_fc_blk contains !------------------------------------------------------------------------------- !> @brief Find shells and primitives which are significant in a given set !>  of 3D coordinates !  TODO: move to basis set related source file !> @author Vladimir Mironov subroutine prune_basis ( inBas , xyzv , xyzat , nSh , nPrim , nBf , & outSh , outShNG , outPrim , atoms ) use constants , only : num_cart_bf use atomic_structure_m , only : atomic_structure type ( basis_set ), intent ( IN ) :: inBas real ( KIND = fp ), intent ( IN ) :: xyzv (:, :), xyzat (:) integer , intent ( OUT ) :: nSh , nPrim , nBf integer , contiguous , intent ( OUT ) :: outSh (:), outShNG (:), outPrim (:) type ( atomic_structure ), intent ( in ) :: atoms !    integer :: nat, ich, mul, num, nqmt, ne, na, nb, ian !    real(KIND=fp) :: zan, c integer :: ish , ig , nCur nSh = 0 nPrim = 0 nBf = 0 do ish = 1 , inBas % nshell associate ( ncontr => inBas % ncontr ( ish ), & g0 => inBas % g_offset ( ish ), & am => inBas % am ( ish ), & xyz => atoms % xyz ( 1 : 3 , inBas % origin ( ish )) - xyzat ( 1 : 3 )) nCur = 0 do ig = g0 , g0 + ncontr - 1 if ( bfnz ( xyz , xyzv , ig )) then nPrim = nPrim + 1 nCur = nCur + 1 outPrim ( nPrim ) = ig end if end do if ( nCur > 0 ) then nSh = nSh + 1 nBf = nBf + num_cart_bf ( am ) outSh ( nSh ) = ish outShNG ( nSh ) = nCur end if end associate end do contains logical function bfnz ( xyz , xyzv , iPrim ) real ( KIND = fp ), intent ( IN ) :: xyz (:), xyzv (:, :) integer , intent ( IN ) :: iPrim integer :: i bfnz = . false . do i = 1 , ubound ( xyzv , 1 ) bfnz = sum (( xyz ( 1 : 3 ) - xyzv ( i , 1 : 3 )) ** 2 ) < inBas % prim_mx_dist2 ( iPrim ) if ( bfnz ) exit end do end function end subroutine !------------------------------------------------------------------------------- !> @brief Assemble numerical atomic DFT grids to a molecular grid !> @param[in]    atmxvec  array of atomic X coordinates !> @param[in]    atmyvec  array of atomic Y coordinates !> @param[in]    atmzvec  array of atomic Z coordinates !> @param[in]    rij      interatomic distances !> @param[in]    nat      number of atoms !> @param[in]    curAt    index of current atom !> @param[in]    rad      effective (e.g. Bragg-Slater) radius of current atom !> @param[inout] wtab     normalized cell function values for LRD !> @param[in]    aij      surface shifting factors for Becke's method !> @author Vladimir Mironov subroutine dft_fc_blk ( molGrid , dft_partfun , atmxyz , at_mx_dist2 , rij , nat , wtab , aij ) !$  use omp_lib, only: omp_get_num_threads, omp_get_thread_num use basis_tools , only : basis_set type ( dft_grid_t ), intent ( inout ) :: molGrid integer , intent ( IN ) :: dft_partfun integer , intent ( IN ) :: nat real ( KIND = fp ), intent ( IN ) :: rij ( nat , nat ), atmxyz (:,:), at_mx_dist2 (:) real ( KIND = fp ), allocatable , intent ( INOUT ) :: wtab (:,:,:) real ( KIND = fp ), intent ( IN ), contiguous , optional :: aij (:,:) real ( KIND = fp ), allocatable :: rijInv (:, :), ri (:), wtintr (:) integer :: me , nProc integer :: iChunk , iSlice integer :: maxSize , maxPts , nMolPts type ( partition_function ) :: partfunc !   Set up selected partition function call partfunc % set ( dft_partfun ) !   Initialize temporary space for atomic cell functions !   and point-to-atom distances allocate ( wtintr ( nat ), ri ( nat )) !   Compute inverse interatomic distances allocate ( rijInv ( nat , nat )) where ( rij /= 0.0_fp ) rijInv = 1.0_fp / rij elsewhere rijInv = 0.0_fp end where !   Clear point counters maxSize = 0 maxPts = 0 nMolPts = 0 nProc = 1 me = 0 !   Compute total weights for grid points !   MPI - static LB, OpenMP - dynamic LB !$omp parallel do & !$omp   private(iSlice, iChunk, ri, wtintr) & !$omp   reduction(max:maxPts, maxSize) & !$omp   reduction(+:nMolPts) & !$omp   schedule(dynamic) do iChunk = 1 , molGrid % nSlices , nProc iSlice = iChunk + me if ( iSlice <= molGrid % nSlices ) then !         Apply selected algorithm on the current slice call do_bfcSlice ( molGrid , iSlice , partfunc , nat , & atmxyz , at_mx_dist2 , & ri , rij , rijInv , wtintr , wtab , aij ) !         Count points: nMolPts = nMolPts + molGrid % nTotPts ( iSlice ) maxPts = max ( maxPts , molGrid % nTotPts ( iSlice )) maxSize = max ( maxSize , molGrid % nAngPts ( iSlice ) & * molGrid % nRadPts ( iSlice )) end if end do !$omp end parallel do !   Finalize grid info molGrid % maxNRadTimesNAng = maxSize molGrid % maxSlicePts = maxPts molGrid % nMolPts = nMolPts end subroutine !> @brief Compute total weights for points in a slice !> @param[in]    iSlice    index of current slice !> @param[in]    partfunc  partition function !> @param[in]    nat       number of atoms !> @param[in]    atmxvec   array of atomic X coordinates !> @param[in]    atmyvec   array of atomic Y coordinates !> @param[in]    atmzvec   array of atomic Z coordinates !> @param[inout] ri        tmp array to store point to atoms distances !> @param[in]    rij       interatomic distances !> @param[in]    rijInv    inverse interatomic distances !> @param[inout] wtintr    tmp array to store cell function values !> @param[inout] wtab      normalized cell function values for LRD !> @param[in]    aij       surface shifting factors for Becke's method !> @author Vladimir Mironov subroutine do_bfcSlice ( molGrid , iSlice , partfunc , nAt , & atmxyz , at_mx_dist2 , & ri , rij , rijInv , wtintr , wtab , aij ) use mod_grid_storage , only : grid_3d_t type ( dft_grid_t ), intent ( inout ) :: molGrid integer , intent ( IN ) :: iSlice , nAt type ( partition_function ), intent ( IN ) :: partfunc real ( KIND = fp ), contiguous :: atmxyz (:,:), at_mx_dist2 (:), & ri (:), rij (:, :), rijInv (:, :), wtintr (:) real ( KIND = fp ), allocatable :: wtab (:,:,:) real ( KIND = fp ), intent ( IN ), contiguous , optional :: aij (:, :) type ( grid_3d_t ), pointer :: curGrid integer :: iAng , iRad , iPt , iAtm real ( KIND = fp ) :: radwt , r1 , ptxyz ( 3 ), wtAngRad real ( KIND = fp ) :: wtnrm logical :: lrd_flag lrd_flag = allocated ( wtab ) associate ( & dummyAtom => molGrid % dummyAtom , & rInner => molGrid % rInner , & iAngStart => molGrid % iAngStart ( iSlice ), & iRadStart => molGrid % iRadStart ( iSlice ), & nAngPts => molGrid % nAngPts ( iSlice ), & nRadPts => molGrid % nRadPts ( iSlice ), & wtStart => molGrid % wtStart ( iSlice ) - 1 , & totWts => molGrid % totWts , & ntp => molGrid % nTotPts ( iSlice ), & isInner => molGrid % isInner ( iSlice ), & curAt => molGrid % idOrigin ( iSlice ), & iTyp => molGrid % radTypeId ( molGrid % idOrigin ( iSlice )), & rad => molGrid % rAtm ( iSlice )) ntp = 0 isInner = 0 if ( molGrid % rad_pts ( iRadStart + nRadPts - 1 , iTyp ) * rad < rInner ( curAt )) then !           Weights of the whole slice are unchanged isInner = 1 ntp = nAngPts * nRadPts !           Nothing left to do for inner slice return end if curGrid => molGrid % spherical_grids % getbyid ( molGrid % idAng ( iSlice )) associate ( & xAng => curGrid % x ( iAngStart : iAngStart + nAngPts - 1 ), & yAng => curGrid % y ( iAngStart : iAngStart + nAngPts - 1 ), & zAng => curGrid % z ( iAngStart : iAngStart + nAngPts - 1 ), & wAng => curGrid % w ( iAngStart : iAngStart + nAngPts - 1 )) do iAng = 1 , nAngPts rloop : do iRad = 1 , nRadPts r1 = rad * molGrid % rad_pts ( iRadStart + iRad - 1 , iTyp ) radWt = rad * rad * rad * molGrid % rad_wts ( iRadStart + iRad - 1 , iTyp ) wtAngRad = FOUR_PI * radWt * wAng ( iAng ) iPt = ( iAng - 1 ) * nRadPts + iRad !               Quick check for inner quadrature points if ( r1 < rInner ( curAt )) then !                   Point weight is unchanged totWts ( wtStart + iPt , curAt ) = wtAngRad ntp = ntp + 1 !                   Next point cycle rloop end if ptxyz ( 1 ) = r1 * xAng ( iAng ) + atmxyz ( 1 , curAt ) ptxyz ( 2 ) = r1 * yAng ( iAng ) + atmxyz ( 2 , curAt ) ptxyz ( 3 ) = r1 * zAng ( iAng ) + atmxyz ( 3 , curAt ) do iAtm = 1 , nAt if ( dummyAtom ( iAtm )) cycle ri ( iAtm ) = norm2 ( ptxyz - atmxyz (:, iAtm )) !                   Check if the point belongs to any other atom if ( iAtm /= curAt . and . & ( r1 - ri ( iAtm ) > rij ( iAtm , curAt ) * & 0.5d0 * ( 1.0d0 + partfunc % limit ))) then !                       This and all next points along the same direction !                       belong to another atom. Switch to the next angular !                       point. It is never happen when Becke's function is !                       selected. exit rloop end if end do !           Pre-screen small density. !           Other points may be significant. Skip to next !           iteration of radial loop. !           Note, weight is set non-zero to discriminate between !           points, belonging to the space of another atom. if ( ALL ( ri * ri > at_mx_dist2 . or . dummyAtom )) then totWts ( wtStart + iPt , curAt ) = tiny ( 1.0_fp ) cycle rloop end if !               If screening fails, follow regular BFC procedure and check !               all atom pairs call do_bfc ( totWts ( wtStart + iPt , curAt ), wtnrm , wtintr , wtAngRad , & ri , rijInv , nAt , curAt , dummyAtom , partfunc , aij ) if ( lrd_flag ) wtab ( 1 : nat , curAt , iPt ) = wtintr ( 1 : nat ) * wtnrm !               Same as before, if weight is zero, the current and !               all next points along the same direction belong !               to another atom. Switch to the next angular point. !               It is never happen when Becke's function is selected. if ( totWts ( wtStart + iPt , curAt ) == 0.0d0 ) then exit rloop end if ntp = ntp + 1 end do rloop end do end associate end associate end subroutine !------------------------------------------------------------------------------- !> @brief Compute total weight of a grid point !> @param[out]   wt        total weight !> @param[out]   wtNorm    sum of cell function values !> @param[out]   cells     array of cell function values !> @param[in]    wtAngRad  unmodified weight !> @param[inout] ri        tmp array to store point to atoms distances !> @param[in]    dummyAtom array to indicate which atoms are \"dummy\" !> @param[in]    rijInv    inverse interatomic distances !> @param[in]    numAt     number of atoms !> @param[in]    curAtom   current atom !> @param[in]    partfunc  partition function !> @param[in]    aij       surface shifting factors for Becke's method !> @author Vladimir Mironov subroutine do_bfc ( wt , wtNorm , cells , wtAngRad , & ri , rijInv , numAt , curAtom , dummyAtom , partfunc , aij ) logical , contiguous , intent ( IN ) :: dummyAtom (:) real ( KIND = fp ), contiguous , intent ( IN ) :: ri (:), rijInv (:, :) integer , intent ( IN ) :: numAt , curAtom real ( KIND = fp ), intent ( IN ) :: wtAngRad type ( partition_function ), intent ( IN ) :: partfunc real ( KIND = fp ), intent ( OUT ) :: wt , wtNorm real ( KIND = fp ), contiguous , intent ( OUT ) :: cells (:) real ( KIND = fp ), contiguous , intent ( IN ), optional :: aij (:, :) integer :: i , j real ( KIND = fp ) :: f , mu where ( dummyAtom ) cells = 0.0d0 elsewhere cells = 1.0d0 end where do i = 2 , numAt if ( dummyAtom ( i )) cycle do j = 1 , i - 1 if ( dummyAtom ( j )) cycle mu = ( ri ( i ) - ri ( j )) * rijInv ( j , i ) if ( present ( aij )) mu = mu + aij ( j , i ) * ( 1.0d0 - mu * mu ) f = partfunc % eval ( mu ) cells ( i ) = cells ( i ) * abs ( f ) cells ( j ) = cells ( j ) * abs ( 1.0d0 - f ) end do end do wtNorm = 1.0d0 / sum ( cells ( 1 : numAt )) wt = cells ( curAtom ) * wtNorm * wtAngRad end subroutine !------------------------------------------------------------------------------- end module mod_dft_fuzzycell","tags":"","url":"sourcefile/dft_fuzzycell.f90.html"},{"title":"nmr_giao_debug.F90 – OpenQP Fortran API","text":"Source Code module nmr_giao_debug_mod implicit none private public giao_h10_twoe_matrix contains !> @brief Native RHF GIAO two-electron magnetic-field-derivative Fock matrices. !> @details Returns the real coefficients of the imaginary first-order (wrt the !>  uniform field B) two-electron Fock contributions for x/y/z, contracted with !>  the ground-state density dm: the Coulomb-like image vj, the exchange-like !>  image vk, and the RHF combination h10 = vj - 0.5*vk.  Each block is !>  antisymmetric in its AO indices.  Validated against an independent !>  two-electron GIAO-derivative reference.  This is the production-reusable core !>  of nmr_giao_h10_twoe_debug; it computes integrals only and emits nothing. subroutine giao_h10_twoe_matrix ( basis , infos , dm , vj , vk , h10 ) use basis_tools , only : basis_set , bas_norm_matrix , build_cart_density use constants , only : cart_x , cart_y , cart_z , HARMONIC_ACTIVE , num_cart_bf use int2_compute , only : int2_compute_t use int2e_rys , only : int2_rys_compute_ordered_am , int2_rys_data_t use messages , only : show_message , with_abort use precision , only : dp use types , only : information implicit none type ( basis_set ), intent ( in ) :: basis type ( information ), target , intent ( inout ) :: infos real ( kind = dp ), intent ( in ) :: dm (:,:) real ( kind = dp ), intent ( out ) :: vj (:,:,:), vk (:,:,:), h10 (:,:,:) type ( int2_compute_t ), target :: int2_driver type ( int2_rys_data_t ) :: gdat real ( kind = dp ), allocatable :: dm_norm (:,:), dm_cart (:,:), dm_work (:,:) real ( kind = dp ), allocatable :: vj_work (:,:,:), vk_work (:,:,:), h10_work (:,:,:), vk_pre (:,:,:) real ( kind = dp ), allocatable , target :: eri0 (:), erir (:) real ( kind = dp ), pointer :: p0 (:,:,:,:), pr (:,:,:,:) real ( kind = dp ) :: g ( 3 ), d ( 3 ), rij ( 3 ), norm4 , ket_fac , base_val integer , allocatable :: loc (:), cart_off (:) integer :: i , j , m , nbf , nshell , maxang , maxcart , nbf_work integer :: si , sj , sk , sl , ni , nj , nk , nl , mu , nu , kap , lam integer :: ii , jj , kk , ll , axis , mapr , ids ( 4 ), am0 ( 4 ), amr ( 4 ), ok logical :: zero_shq , usecart nbf = basis % nbf nshell = basis % nshell maxang = maxval ( basis % am ) if ( maxang + 1 > 6 ) call show_message ( 'GIAO two-electron: angular momentum too high' , with_abort ) maxcart = num_cart_bf ( maxang + 1 ) usecart = HARMONIC_ACTIVE if ( usecart ) then dm_norm = dm call bas_norm_matrix ( dm_norm , basis % bfnrm , basis % nbf ) call build_cart_density ( basis , dm_norm , dm_cart , cart_off , nbf_work ) dm_work = dm_cart loc = cart_off else nbf_work = nbf dm_work = dm allocate ( loc ( nshell )) loc = basis % ao_offset end if vj = 0.0_dp vk = 0.0_dp h10 = 0.0_dp allocate ( vj_work ( 3 , nbf_work , nbf_work ), source = 0.0_dp ) allocate ( vk_work ( 3 , nbf_work , nbf_work ), h10_work ( 3 , nbf_work , nbf_work ), source = 0.0_dp ) allocate ( vk_pre ( 3 , nbf_work , nbf_work ), source = 0.0_dp ) allocate ( eri0 ( maxcart ** 4 ), erir ( maxcart ** 4 ), source = 0.0_dp ) call int2_driver % init ( basis , infos ) int2_driver % rys_only = . true . ! NMR is Rys-only by construction ! The magnetic derivative is ordered/antisymmetric in the bra pair.  Rebuild ! pair data without angular-momentum reordering so the Rys recurrence sees ! PA/PB vectors in the same shell order as the explicit ids below. call int2_driver % ppairs % compute ( basis , int2_driver % cutoffs , noswap = . true .) call gdat % init ( maxang + 1 , int2_driver % cutoffs , ok ) if ( ok /= 0 ) call show_message ( 'GIAO two-electron: cannot allocate Rys workspace' , with_abort ) do si = 1 , nshell if ( usecart ) then ni = NUM_CART_BF ( basis % am ( si )) else ni = basis % naos ( si ) end if do sj = 1 , si if ( usecart ) then nj = NUM_CART_BF ( basis % am ( sj )) else nj = basis % naos ( sj ) end if rij = basis % shell_centers ( si , 1 : 3 ) - basis % shell_centers ( sj , 1 : 3 ) if ( maxval ( abs ( rij )) < 1.0d-14 ) cycle do sk = 1 , nshell if ( usecart ) then nk = NUM_CART_BF ( basis % am ( sk )) else nk = basis % naos ( sk ) end if do sl = 1 , sk if ( usecart ) then nl = NUM_CART_BF ( basis % am ( sl )) else nl = basis % naos ( sl ) end if ket_fac = merge ( 1.0_dp , 2.0_dp , sk == sl ) ids = [ si , sj , sk , sl ] am0 = basis % am ( ids ) eri0 = 0.0_dp call int2_rys_compute_ordered_am ( eri0 , gdat , int2_driver % ppairs , ids , am0 , zero_shq ) if ( zero_shq ) cycle p0 ( 1 : nl , 1 : nk , 1 : nj , 1 : ni ) => eri0 ( 1 : nl * nk * nj * ni ) ! The raised-bra quartet depends only on (ids, am0 + 1 on the bra); ! it is identical for all three axes and all (ii,jj,kk,ll), so ! compute it ONCE per shell quartet.  (It was previously recomputed ! 3*ni*nj*nk*nl times inside the loops below, which made d/f-basis ! GIAO NMR intractable.)  Only the Cartesian component index mapr ! depends on (ii, axis). amr = am0 amr ( 1 ) = amr ( 1 ) + 1 erir = 0.0_dp call int2_rys_compute_ordered_am ( erir , gdat , int2_driver % ppairs , ids , amr , zero_shq ) pr ( 1 : nl , 1 : nk , 1 : nj , 1 : num_cart_bf ( amr ( 1 ))) => erir ( 1 : nl * nk * nj * num_cart_bf ( amr ( 1 ))) do ii = 1 , ni mu = loc ( si ) + ii - 1 do jj = 1 , nj nu = loc ( sj ) + jj - 1 do kk = 1 , nk kap = loc ( sk ) + kk - 1 do ll = 1 , nl lam = loc ( sl ) + ll - 1 norm4 = 1.0_dp if (. not . usecart ) norm4 = basis % bfnrm ( mu ) * basis % bfnrm ( nu ) * basis % bfnrm ( kap ) * basis % bfnrm ( lam ) base_val = p0 ( ll , kk , jj , ii ) do axis = 1 , 3 mapr = raised_cart_index ( ii , am0 ( 1 ), axis ) d ( axis ) = ( pr ( ll , kk , jj , mapr ) + basis % shell_centers ( si , axis ) * base_val ) * norm4 end do g ( 1 ) = - 0.5_dp * ( rij ( 2 ) * d ( 3 ) - rij ( 3 ) * d ( 2 )) g ( 2 ) = - 0.5_dp * ( rij ( 3 ) * d ( 1 ) - rij ( 1 ) * d ( 3 )) g ( 3 ) = - 0.5_dp * ( rij ( 1 ) * d ( 2 ) - rij ( 2 ) * d ( 1 )) do m = 1 , 3 vj_work ( m , mu , nu ) = vj_work ( m , mu , nu ) - ket_fac * g ( m ) * dm_work ( lam , kap ) vk_pre ( m , mu , lam ) = vk_pre ( m , mu , lam ) + g ( m ) * dm_work ( nu , kap ) if ( sk /= sl ) vk_pre ( m , mu , kap ) = vk_pre ( m , mu , kap ) + g ( m ) * dm_work ( nu , lam ) if ( si /= sj ) then vj_work ( m , nu , mu ) = vj_work ( m , nu , mu ) + ket_fac * g ( m ) * dm_work ( lam , kap ) vk_pre ( m , nu , lam ) = vk_pre ( m , nu , lam ) - g ( m ) * dm_work ( mu , kap ) if ( sk /= sl ) vk_pre ( m , nu , kap ) = vk_pre ( m , nu , kap ) - g ( m ) * dm_work ( mu , lam ) end if end do end do end do end do end do nullify ( p0 ) nullify ( pr ) end do end do end do end do do m = 1 , 3 do i = 1 , nbf_work do j = 1 , nbf_work vk_work ( m , i , j ) = - ( vk_pre ( m , i , j ) - vk_pre ( m , j , i )) h10_work ( m , i , j ) = vj_work ( m , i , j ) - 0.5_dp * vk_work ( m , i , j ) end do end do end do if ( usecart ) then call reduce_cart_giao_matrix ( basis , cart_off , vj_work , vj ) call reduce_cart_giao_matrix ( basis , cart_off , vk_work , vk ) call reduce_cart_giao_matrix ( basis , cart_off , h10_work , h10 ) else vj = vj_work vk = vk_work h10 = h10_work end if call gdat % clean () call int2_driver % clean () deallocate ( vj_work , vk_work , h10_work , vk_pre , eri0 , erir ) end subroutine giao_h10_twoe_matrix subroutine reduce_cart_giao_matrix ( basis , cart_off , cart , sph ) use basis_tools , only : basis_set , bas_norm_matrix use cart2sph , only : cart2sph_mat use constants , only : num_cart_bf use precision , only : dp implicit none type ( basis_set ), intent ( in ) :: basis integer , intent ( in ) :: cart_off (:) real ( kind = dp ), intent ( in ) :: cart (:,:,:) real ( kind = dp ), intent ( out ) :: sph (:,:,:) real ( kind = dp ), allocatable :: blk (:) integer :: m , si , sj , ii , jj , nci , ncj , nsi , nsj , coi , coj , soi , soj , idx sph = 0.0_dp do m = 1 , 3 do sj = 1 , basis % nshell ncj = NUM_CART_BF ( basis % am ( sj )) nsj = basis % naos ( sj ) coj = cart_off ( sj ) soj = basis % ao_offset ( sj ) do si = 1 , basis % nshell nci = NUM_CART_BF ( basis % am ( si )) nsi = basis % naos ( si ) coi = cart_off ( si ) soi = basis % ao_offset ( si ) allocate ( blk ( nci * ncj )) idx = 0 do jj = 1 , ncj do ii = 1 , nci idx = idx + 1 blk ( idx ) = cart ( m , coi + ii - 1 , coj + jj - 1 ) end do end do if ( basis % harmonic ( si ) == 1 . or . basis % harmonic ( sj ) == 1 ) & call cart2sph_mat ( blk , basis % am ( si ), basis % harmonic ( si ), basis % am ( sj ), basis % harmonic ( sj )) idx = 0 do jj = 1 , nsj do ii = 1 , nsi idx = idx + 1 sph ( m , soi + ii - 1 , soj + jj - 1 ) = blk ( idx ) end do end do deallocate ( blk ) end do end do call bas_norm_matrix ( sph ( m ,:,:), basis % bfnrm , basis % nbf ) end do end subroutine reduce_cart_giao_matrix integer function raised_cart_index ( idx , am , axis ) result ( match ) use constants , only : cart_x , cart_y , cart_z , num_cart_bf integer , intent ( in ) :: idx , am , axis integer :: i , tx , ty , tz tx = cart_x ( idx , am ) ty = cart_y ( idx , am ) tz = cart_z ( idx , am ) if ( axis == 1 ) tx = tx + 1 if ( axis == 2 ) ty = ty + 1 if ( axis == 3 ) tz = tz + 1 match = 0 do i = 1 , num_cart_bf ( am + 1 ) if ( cart_x ( i , am + 1 ) == tx . and . cart_y ( i , am + 1 ) == ty . and . cart_z ( i , am + 1 ) == tz ) then match = i return end if end do error stop 'raised_cart_index failed' end function raised_cart_index end module nmr_giao_debug_mod","tags":"","url":"sourcefile/nmr_giao_debug.f90.html"},{"title":"guess_hcore.F90 – OpenQP Fortran API","text":"Source Code module guess_hcore_mod implicit none character ( len =* ), parameter :: module_name = \"guess_hcore_mod\" contains subroutine guess_hcore_C ( c_handle ) bind ( C , name = \"guess_hcore\" ) use c_interop , only : oqp_handle_t , oqp_handle_get_info use types , only : information type ( oqp_handle_t ) :: c_handle type ( information ), pointer :: inf inf => oqp_handle_get_info ( c_handle ) call guess_hcore ( inf ) end subroutine guess_hcore_C subroutine guess_hcore ( infos ) use precision , only : dp use types , only : information use io_constants , only : IW use oqp_tagarray_driver use basis_tools , only : basis_set use guess , only : get_ab_initio_density , & get_ab_initio_orbital use qmat_cache , only : get_qmat_cached use util , only : measure_time use messages , only : show_message , WITH_ABORT use strings , only : Cstring , fstring use printing , only : print_module_info implicit none character ( len =* ), parameter :: subroutine_name = \"guess_hcore\" type ( information ), target , intent ( inout ) :: infos ! integer :: nbf2 , nbf , ok ! real ( kind = dp ), allocatable :: qmat (:,:) type ( basis_set ), pointer :: basis ! ! tagarray real ( kind = dp ), contiguous , pointer :: & Hcore (:), Smat (:), & dmat_a (:), mo_a (:,:), mo_energy_a (:), & dmat_b (:), mo_b (:,:), mo_energy_b (:) character ( len =* ), parameter :: tags_alpha ( 3 ) = ( / character ( len = 80 ) :: & OQP_DM_A , OQP_E_MO_A , OQP_VEC_MO_A / ) character ( len =* ), parameter :: tags_beta ( 3 ) = ( / character ( len = 80 ) :: & OQP_DM_B , OQP_E_MO_B , OQP_VEC_MO_B / ) character ( len =* ), parameter :: tags_general ( 2 ) = ( / character ( len = 80 ) :: & OQP_SM , OQP_Hcore / ) ! Files open ! 1. XYZ: Read : Geometric data, ATOMS ! 3. LOG: Read Write: Main output file ! open ( unit = IW , file = infos % log_filename , position = \"append\" ) ! ! call print_module_info ( 'guess_Hcore' , 'Initial Guess using H Matrix' ) ! load basis set basis => infos % basis basis % atoms => infos % atoms !  Allocate H, S ,T and D matrices nbf = basis % nbf nbf2 = nbf * ( nbf + 1 ) / 2 allocate ( qmat ( nbf , nbf ), stat = ok ) if ( ok /= 0 ) call show_message ( 'Cannot allocate memory' , WITH_ABORT ) ! load general data call data_has_tags ( infos % dat , tags_general , module_name , subroutine_name , WITH_ABORT ) call tagarray_get_data ( infos % dat , OQP_SM , smat ) call tagarray_get_data ( infos % dat , OQP_Hcore , hcore ) ! allocate alpha call infos % dat % alloc_or_die ( OQP_DM_A , ( / nbf2 / ), dmat_a , description = OQP_DM_A_comment ) call infos % dat % alloc_or_die ( OQP_E_MO_A , ( / nbf / ), mo_energy_a , description = OQP_E_MO_A_comment ) call infos % dat % alloc_or_die ( OQP_VEC_MO_A , ( / nbf , nbf / ), mo_a , description = OQP_VEC_MO_A_comment ) ! UHF/ROHF if ( infos % control % scftype >= 2 ) then ! allocate beta call infos % dat % alloc_or_die ( OQP_DM_B , ( / nbf2 / ), dmat_b , description = OQP_DM_B_comment ) call infos % dat % alloc_or_die ( OQP_E_MO_B , ( / nbf / ), mo_energy_b , description = OQP_E_MO_B_comment ) call infos % dat % alloc_or_die ( OQP_VEC_MO_B , ( / nbf , nbf / ), mo_b , description = OQP_VEC_MO_B_comment ) end if !  End of Readings................................. ! call get_qmat_cached ( infos , smat , qmat , nbf ) ! !  Calculate Hcore MO call Get_ab_initio_orbital ( Hcore , MO_A , MO_Energy_A , QMat ) !  For ROHF/UHF if ( INFOS % control % scftype >= 2 ) MO_B = MO_A ! ! Calculate Density Matrix ! RHF if ( INFOS % control % scftype == 1 ) then call get_ab_initio_density ( Dmat_A , MO_A , infos = infos , basis = basis ) ! ROHF/UHF else call get_ab_initio_density ( Dmat_A , MO_A , Dmat_B , MO_B , infos , basis ) end if write ( IW , 9090 ) call measure_time ( print_total = 1 , log_unit = iw ) close ( IW ) 9090 format ( / 1 x , '...... End Of Initial Orbital Guess ......' / ) end subroutine guess_hcore end module guess_hcore_mod","tags":"","url":"sourcefile/guess_hcore.f90.html"},{"title":"tdhf_z_vector.F90 – OpenQP Fortran API","text":"Source Code module tdhf_z_vector_mod use types , only : information use precision , only : dp use basis_tools , only : basis_set use int2_compute , only : int2_compute_t use io_constants , only : iw use tdhf_lib , only : int2_td_data_t , & int2_fock_data_t , int2_tdgrd_data_t use mod_dft_molgrid , only : dft_grid_t use oqp_linalg use , intrinsic :: ieee_arithmetic , only : ieee_is_finite use zvector_common , only : sanitize_zvector_preconditioner , & zv_opts_t , zv_read_opts , zv_prog_tau implicit none character ( len =* ), parameter :: module_name = \"tdhf_z_vector_mod\" real ( kind = dp ), parameter :: ZVEC_PRECOND_FLOOR = 1.0d-12 private public tdhf_z_vector_C public oqp_tdhf_z_vector type :: tdhf_cg_data type ( information ), pointer :: infos type ( int2_compute_t ), pointer :: int2_driver class ( int2_fock_data_t ), pointer :: int2_data type ( dft_grid_t ), pointer :: molGrid real ( kind = dp ), pointer :: wrk (:,:) real ( kind = dp ), pointer :: mo (:,:) real ( kind = dp ), pointer :: pa (:,:,:) real ( kind = dp ), pointer :: xm (:) real ( kind = dp ), pointer :: xminv (:) integer :: nbf integer :: nocc logical :: dft end type contains !############################################################################### subroutine tdhf_z_vector_C ( c_handle ) bind ( C , name = \"tdhf_z_vector\" ) use types , only : information use c_interop , only : oqp_handle_t , oqp_handle_get_info use strings , only : Cstring type ( oqp_handle_t ) :: c_handle type ( information ), pointer :: inf inf => oqp_handle_get_info ( c_handle ) call oqp_tdhf_z_vector ( inf ) end subroutine !############################################################################### subroutine oqp_tdhf_z_vector ( infos ) use oqp_tagarray_driver use strings , only : Cstring , fstring use messages , only : show_message , with_abort use util , only : measure_time use tdhf_lib , only : iatogen , mntoia , esum , & tdhf_unrelaxed_density use tdhf_sf_lib , only : sfrorhs , & sfromcal , sfrogen , sfrolhs , & pcgb , sfropcal , sfrowcal use dft , only : dft_initialize , dftclean use mod_dft_gridint_fxc , only : tddft_fxc use mod_dft_gridint_gxc , only : tddft_gxc use mathlib , only : symmetrize_matrix , orthogonal_transform use mod_dft_molgrid , only : dft_grid_t use mathlib , only : pack_matrix , unpack_matrix use mathlib , only : triangular_to_full use tdhf_lib , only : int2_rpagrd_data_t use pcg_mod use printing , only : print_module_info implicit none character ( len =* ), parameter :: subroutine_name = \"oqp_tdhf_z_vector\" type ( basis_set ), pointer :: basis type ( information ), target , intent ( inout ) :: infos type ( dft_grid_t ), target :: molGrid type ( int2_compute_t ), target :: int2_driver class ( int2_fock_data_t ), allocatable , target :: int2_data type ( tdhf_cg_data ) :: cgdata type ( pcg_t ) :: pcg real ( kind = dp ), allocatable :: hpp (:,:,:), hpt (:,:,:), hmm (:,:,:), gxp (:,:,:) real ( kind = dp ), allocatable , target :: wrk1 (:,:), & rhs (:), xm (:), zvec (:), xminv (:), pa (:,:,:) real ( kind = dp ), contiguous , pointer :: ppa (:,:,:,:), & pxm (:,:), prhs (:,:), wmo (:,:) logical :: dft , tda integer :: scf_type , mol_mult integer :: i , j , iter , ok integer :: nocc , nvir , lexc , nbf , nbf2 real ( kind = dp ) :: cnvtol , scale_exch type ( zv_opts_t ) :: zvo real ( kind = dp ) :: zv_rc_tight ! tagarray real ( kind = dp ), contiguous , pointer :: & mo_a (:,:), mo_energy_a (:), wao (:), td_p (:,:), td_t (:,:), & ta (:), xpy (:,:), xmy (:,:), td_energies (:) character ( len =* ), parameter :: & tags_required ( * ) = [ character ( len = 80 ) :: & OQP_E_MO_A , OQP_VEC_MO_A , OQP_TD_T , OQP_TD_XPY , OQP_TD_XMY , & OQP_td_energies & ] ! Log file open ( unit = IW , file = infos % log_filename , position = \"append\" ) ! call print_module_info ( 'TDHF_Z_Vector' , 'Solving Z-Vector for TDDFT' ) mol_mult = infos % mol_prop % mult scf_type = infos % control % scftype dft = infos % control % hamilton == 20 tda = infos % tddft % tda ! Load basis set basis => infos % basis basis % atoms => infos % atoms nbf = basis % nbf nbf2 = nbf * ( nbf + 1 ) / 2 if ( dft ) call dft_initialize ( infos , basis , molGrid ) ! Parameter it should be inputed later ! convergence tolerance in the iterative TD-DFT step. cnvtol = infos % tddft % zvconv ! Shared z-vector perf opt-ins (env OQP_TDHF_ZV_*); progressive screening ! default ON, zvconv override default off (see zvector_common). call zv_read_opts ( zvo , \"TDHF\" ) if ( zvo % conv_user > 0.0_dp ) cnvtol = zvo % conv_user nocc = infos % mol_prop % nocc nvir = nbf - nocc lexc = nocc * nvir allocate (& rhs ( lexc ), & pa ( nbf , nbf , 1 ), & wrk1 ( nbf , nbf ), & stat = ok , & source = 0.0_dp ) if ( ok /= 0 ) call show_message ( 'Cannot allocate memory' , with_abort ) call data_has_tags ( infos % dat , tags_required , module_name , subroutine_name , WITH_ABORT ) call tagarray_get_data ( infos % dat , OQP_E_MO_A , mo_energy_a ) call tagarray_get_data ( infos % dat , OQP_VEC_MO_A , mo_a ) call tagarray_get_data ( infos % dat , OQP_TD_T , td_t ) call tagarray_get_data ( infos % dat , OQP_TD_XPY , xpy ) call tagarray_get_data ( infos % dat , OQP_TD_XMY , xmy ) call tagarray_get_data ( infos % dat , OQP_td_energies , td_energies ) ta => td_t (:, 1 ) write ( iw , '(/1x,71(\"-\")& &/19x,\"TD-DFT ENERGY GRADIENT CALCULATION\"& &/1x,71(\"-\")/)' ) write ( iw , fmt = '(5x,a/& &5x,16(\"-\")/& &5x,a,x,i0,x,f17.10,x,\"Hartree\"/& &5x,a,x,i0/& &5x,a,x,e10.4/& &5x,a,x,i0)' ) & 'Z-vector options' & , 'Target state       is' , infos % tddft % target_state , infos % mol_energy % energy + td_energies ( infos % tddft % target_state ) & , 'Multiplicity       is' , infos % tddft % mult & , 'Convergence        is' , infos % tddft % zvconv & , 'Maximum iterations is' , infos % control % maxit_zv call flush ( iw ) !   1. Compute right-hand side of Z-vector equation allocate ( hpp ( nbf , nbf , 1 ), & ! H+[X+Y] hpt ( nbf , nbf , 1 ), & ! H+[T] hmm ( nbf , nbf , 1 ), & ! H-[X-Y] gxp ( nbf , nbf , 1 ), & ! g_xc[X+Y][X+Y] source = 0.0d0 ) call tdhf_unrelaxed_density ( xmy (:, infos % tddft % target_state ), xpy (:, infos % tddft % target_state ), mo_a , td_t (:, 1 ), nocc , tda ) ! Initialize ERI calculations (tight; progressive screening ramps the ! run-time threshold per CG step and is restored tight for the tail). zv_rc_tight = infos % control % int2e_cutoff call int2_driver % init ( basis , infos ) call int2_driver % set_screening () ! Compute H+[X+Y], H+[T], H-[X-Y], and G_xc call compute_r_terms ( infos , basis , int2_driver , molGrid , mo_a , xpy (:, infos % tddft % target_state ), & xmy (:, infos % tddft % target_state ), ta , hpp , hpt , hmm , gxp ) ! Transform Gxc to MO basis call orthogonal_transform ( 'n' , nbf , mo_a , gxp (:,:, 1 )) ! Assemble RHS in MO basis prhs ( 1 : nocc , 1 : nvir ) => rhs ( 1 :) call compute_r_mo ( prhs , mo_a , xpy (:, infos % tddft % target_state ), xmy (:, infos % tddft % target_state ), hpt , hpp , hmm , gxp (:,:, 1 )) rhs = - rhs !   2. Initialize CG for Z-vector solution write ( iw , '(/3x,25(\"-\")& &/6x,\"START Z-VECTOR LOOP\"& &/3x,25(\"-\")/)' ) call flush ( iw ) allocate ( xminv ( lexc ), & xm ( lexc ), & stat = ok , & source = 0.0_dp ) if ( ok /= 0 ) call show_message ( 'Cannot allocate memory' , with_abort ) scale_exch = 1.0_dp if ( dft ) scale_exch = infos % dft % HFscale ! The Z-vector (orbital-relaxation) equation uses the ground-state ! orbital Hessian (A+B), which is identical for TDA and full RPA - the ! Tamm-Dancoff approximation only affects the excitation vectors and the ! RHS, not the relaxation operator. Forcing tamm_dancoff here would build ! the A matrix into %amb (which compute_apbx never reads), leaving the ! operator without its two-electron part for TDA. int2_data = int2_td_data_t ( d2 = pa , & int_apb = . true ., & int_amb = . false ., & tamm_dancoff = . false ., & scale_exchange = scale_exch ) pxm ( 1 : nocc , 1 : nvir ) => xm ( 1 :) do i = 1 , nvir do j = 1 , nocc pxm ( j , i ) = mo_energy_a ( nocc + i ) - mo_energy_a ( j ) end do end do call sanitize_zvector_preconditioner ( xm , xminv , iw , ZVEC_PRECOND_FLOOR , \"RHF\" ) cgdata = tdhf_cg_data ( & infos = infos , int2_driver = int2_driver , & int2_data = int2_data , molgrid = molgrid , & wrk = wrk1 , mo = mo_a , pa = pa , xm = xm , xminv = xminv , & nbf = nbf , nocc = nocc , dft = dft & ) call pcg % init ( b = rhs , & update = compute_apbx , precond = precond , & dat = cgdata , tol = sqrt ( abs ( cnvtol ))) write ( iw , '(\" INITIAL ERROR =\",3X,1P,E10.3,1X,\"/\",1P,E10.3)' ) pcg % error ** 2 , cnvtol ! Begin CG iterations do iter = 1 , infos % control % maxit_zv if ( pcg % errcode /= PCG_OK ) exit ! Progressive screening: loosen while the residual is large, pin tight ! near convergence (pcg%error is the residual norm; cnvtol is its square). if ( zvo % prog_on ) call int2_driver % set_cutoff ( zv_prog_tau ( zvo , pcg % error ** 2 , zv_rc_tight )) call pcg % step () write ( iw , '(\" ITER#\",I2,\" ERROR =\",3X,1P,E10.3,1X,\"/\",1P,E10.3)' ) & iter , pcg % error ** 2 , cnvtol call flush ( iw ) end do select case ( pcg % errcode ) case ( PCG_CONVERGED ) write ( iw , '(/3x,24(\"-\")& &/6x,\"Z-Vector converged\"& &/3x,24(\"-\")/)' ) infos % mol_energy % Z_Vector_converged = . true . case ( PCG_BREAKDOWN ) write ( iw , '(/3x,24(\"-\")& &/6x,\"Z-Vector PCG breakdown\"& &/3x,24(\"-\")/)' ) write ( iw , '(\" PCG stopped on a non-finite or near-zero denominator; \",& &\"final residual = \",1p,e13.6)' ) pcg % error infos % mol_energy % Z_Vector_converged = . false . call flush ( iw ) deallocate ( xminv , rhs , xm ) if ( allocated ( int2_data )) then call int2_data % clean () deallocate ( int2_data ) end if call pcg % clean () call int2_driver % clean () if ( dft ) call dftclean ( infos ) call measure_time ( print_total = 1 , log_unit = iw ) close ( iw ) return case default write ( iw , '(/3x,24(\"-\")& &/6x,\"Z-Vector not converged\"& &/3x,24(\"-\")/)' ) write ( iw , '(\" PCG reached the maximum z-vector iterations; \",& &\"final residual = \",1p,e13.6)' ) pcg % error infos % mol_energy % Z_Vector_converged = . false . end select call flush ( iw ) ! Restore the tight cutoff for the relaxed-density / W back-projection. if ( zvo % prog_on ) call int2_driver % set_cutoff ( zv_rc_tight ) !   Save Z-vector and clean up memory deallocate ( xminv , rhs , xm ) call int2_data % clean () deallocate ( int2_data ) allocate ( zvec , source = pcg % x ) call pcg % clean () !   3. Now, compute relaxed energy-weighted difference density matrix W ! Convert Z-vector from MO to AO and assemble P = T+Z pa = 0 call iatogen ( zvec , pa (:,:, 1 ), nocc , nocc ) call symmetrize_matrix ( pa (:,:, 1 ), nbf ) pa (:,:, 1 ) = 0.5 * pa (:,:, 1 ) call orthogonal_transform ( 't' , nbf , mo_a , pa (:,:, 1 )) call unpack_matrix ( ta , wrk1 ) ! T pa (:,:, 1 ) = pa (:,:, 1 ) + wrk1 ! T+Z ! Store relaxed difference density matrix P to global memory call infos % dat % alloc_or_die ( OQP_td_p , ( / nbf2 , 1 / ), td_p , description = OQP_td_p_comment ) call pack_matrix ( pa (:,:, 1 ), td_p (:, 1 )) ! Compute H+[P] ppa ( 1 : nbf , 1 : nbf , 1 : 1 , 1 : 1 ) => pa int2_data = int2_rpagrd_data_t (& xpy = null (), & xmy = null (), & t = ppa , & nspin = 1 , & tamm_dancoff = tda , & scale_exchange = scale_exch ) call int2_driver % run ( int2_data , & cam = dft . and . infos % dft % cam_flag , & alpha = infos % dft % cam_alpha , & beta = infos % dft % cam_beta ,& mu = infos % dft % cam_mu ) select type ( int2_data ) type is ( int2_rpagrd_data_t ) hpt = int2_data % hpt (:,:,:, 1 , 1 ) end select call int2_data % clean () deallocate ( int2_data ) if ( dft ) then pa = pa * 2 call tddft_fxc ( basis = basis , & molGrid = molGrid , & isVecs = . true ., & wf = MO_A , & fx = hpt (:,:, 1 : 1 ), & dx = pa (:,:, 1 : 1 ), & nmtx = 1 , & !threshold=1.0d-15, & threshold = 0.0d0 , & infos = infos ) end if ! Transform H+[P], H+[X+Y], H-[X-Y] from AO to MO basis call orthogonal_transform ( 'n' , nbf , mo_a , hpt (:,:, 1 ), wrk = wrk1 ) ! P call orthogonal_transform ( 'n' , nbf , mo_a , hpp (:,:, 1 ), wrk = wrk1 ) ! X+Y call orthogonal_transform ( 'n' , nbf , mo_a , hmm (:,:, 1 ), wrk = wrk1 ) ! X-Y ! Calculate W in MO basis wmo ( 1 : nbf , 1 : nbf ) => wrk1 call compute_w_mo ( wmo , xpy (:, infos % tddft % target_state ), xmy (:, infos % tddft % target_state ), zvec , & hpt (:,:, 1 ), hpp (:,:, 1 ), hmm (:,:, 1 ), & mo_energy_a , td_energies ( infos % tddft % target_state ), nocc , gxp (:,:, 1 )) ! Transform W from MO to AO basis call orthogonal_transform ( 't' , nbf , mo_a , wmo ) ! Store W to global memory call infos % dat % alloc_or_die ( OQP_WAO , ( / nbf2 / ), wao , description = OQP_WAO_comment ) call pack_matrix ( wmo , wao ) wao = wao * 0.5_dp ! Cleanup call int2_driver % clean () if ( dft ) call dftclean ( infos ) call measure_time ( print_total = 1 , log_unit = iw ) close ( iw ) end subroutine oqp_tdhf_z_vector !############################################################################### !> @brief Compute H+[X+Y], H+[T], and H-[X-Y] subroutine compute_r_terms ( infos , basis , int2_driver , molGrid , mo_a , xpy , xmy , ta , hpp , hpt , hmm , gxp ) use mod_dft_gridint_fxc , only : tddft_fxc use mod_dft_gridint_gxc , only : tddft_gxc use tdhf_lib , only : int2_rpagrd_data_t use mathlib , only : symmetrize_matrix , orthogonal_transform use mathlib , only : unpack_matrix use tdhf_lib , only : iatogen type ( information ) :: infos type ( basis_set ) :: basis type ( dft_grid_t ) :: molGrid type ( int2_compute_t ), target :: int2_driver real ( kind = dp ), intent ( in ) :: mo_a (:,:), xpy (:), xmy (:), ta (:) real ( kind = dp ), target :: hpp (:,:,:), hpt (:,:,:), hmm (:,:,:), gxp (:,:,:) real ( kind = dp ), allocatable , target :: xpy2 (:,:,:,:), xmy2 (:,:,:,:) real ( kind = dp ), allocatable , target :: hp (:,:,:) real ( kind = dp ) :: scale_exch integer :: nocc , nvir , nbf logical :: tda , dft type ( int2_rpagrd_data_t ), target :: int2_data nbf = basis % nbf nocc = infos % mol_prop % nocc nvir = nbf - nocc tda = infos % tddft % tda dft = infos % control % hamilton == 20 allocate ( xpy2 ( nbf , nbf , 2 , 1 ), & xmy2 ( nbf , nbf , 1 , 1 ), & source = 0.0_dp ) ! Prepare unrelaxed density, X+Y, and X-Y vectors in AO basis set call iatogen ( xpy , xpy2 (:,:, 1 , 1 ), nocc , nocc ) call symmetrize_matrix ( xpy2 (:,:, 1 , 1 ), nbf ) xpy2 (:,:, 1 , 1 ) = xpy2 (:,:, 1 , 1 ) * 0.5 call orthogonal_transform ( 't' , nbf , mo_a , xpy2 (:,:, 1 , 1 )) call iatogen ( xmy , xmy2 (:,:, 1 , 1 ), nocc , nocc ) call orthogonal_transform ( 't' , nbf , mo_a , xmy2 (:,:, 1 , 1 )) call unpack_matrix ( ta , xpy2 (:,:, 2 , 1 )) ! Initialize ERI calculations scale_exch = 1.0_dp if ( dft ) scale_exch = infos % dft % HFscale if ( dft ) then call tddft_gxc ( basis = basis , & molGrid = molGrid , & isVecs = . true ., & wf = MO_A , & fx = gxp (:,:, 1 : 1 ), & dx = xpy2 (:,:, 1 : 1 , 1 ), & nmtx = 1 , & !threshold=1.0d-15, & threshold = 0.0d0 , & infos = infos ) allocate ( hp ( nbf , nbf , 2 ), source = 0.0_dp ) call tddft_fxc ( basis = basis , & molGrid = molGrid , & isVecs = . true ., & wf = MO_A , & fx = hp (:,:, 1 : 2 ), & dx = xpy2 (:,:, 1 : 2 , 1 ), & nmtx = 2 , & !threshold=1.0d-15, & threshold = 0.0d0 , & infos = infos ) hpp (:,:, 1 ) = hpp (:,:, 1 ) + hp (:,:, 1 ) hpt (:,:, 1 ) = hpt (:,:, 1 ) + hp (:,:, 2 ) deallocate ( hp ) end if ! Compute H+[X+Y], H+[T], and H-[X-Y] int2_data = int2_rpagrd_data_t (& xpy = xpy2 , & xmy = xmy2 , & t = xpy2 (:,:, 2 : 2 , 1 : 1 ), & nspin = 1 , & tamm_dancoff = tda , & scale_exchange = scale_exch ) call int2_driver % run ( int2_data , & cam = dft . and . infos % dft % cam_flag , & alpha = infos % dft % cam_alpha , & beta = infos % dft % cam_beta ,& mu = infos % dft % cam_mu ) hpp (:,:,:) = 2 * hpp (:,:,:) + int2_data % hpp (:,:,:, 1 , 1 ) ! H+[X+Y] hpt (:,:,:) = 2 * hpt (:,:,:) + int2_data % hpt (:,:,:, 1 , 1 ) ! H+[T] hmm (:,:,:) = int2_data % hmm (:,:,:, 1 , 1 ) ! H-[X-Y] call int2_data % clean () end subroutine !############################################################################### subroutine compute_w_mo ( wmo , xpy , xmy , z , hpt , hpp , hmm , e_mo , e_state , nocc , gxp ) use mathlib , only : triangular_to_full , orthogonal_transform implicit none real ( kind = dp ), intent ( in ) :: xpy ( nocc , * ), xmy ( nocc , * ), z ( nocc , * ), e_mo ( * ), hpt (:,:), hpp (:,:), hmm (:,:) real ( kind = dp ), optional , intent ( in ) :: gxp (:,:) real ( kind = dp ), intent ( in ) :: e_state real ( kind = dp ), intent ( out ) :: wmo (:,:) integer , intent ( in ) :: nocc real ( kind = dp ), allocatable , target :: wrk1 (:,:), wrk_ia (:,:) integer :: nbf , nvir , i nbf = ubound ( wmo , 1 ) nvir = nbf - nocc allocate ( wrk1 ( nbf , nbf ), & wrk_ia ( nocc , nvir ), & source = 0.0d0 ) wmo = 0 ! W_ij (occ x occ) call dsyr2k ( 'u' , 'n' , nocc , nvir , & e_state , xpy , nocc , & xmy , nocc , & 1.0d0 , wmo , nbf ) do i = 1 , nvir wrk_ia (:, i ) = xpy (:, i ) * e_mo ( nocc + i ) end do call dgemm ( 'n' , 't' , nocc , nocc , nvir , & - 1.0d0 , xpy , nocc , & wrk_ia , nocc , & 1.0d0 , wmo , nbf ) do i = 1 , nvir wrk_ia (:, i ) = xmy (:, i ) * e_mo ( nocc + i ) end do call dgemm ( 'n' , 't' , nocc , nocc , nvir , & - 1.0d0 , xmy , nocc , & wrk_ia , nocc , & 1.0d0 , wmo , nbf ) wmo (: nocc ,: nocc ) = wmo (: nocc ,: nocc ) + hpt (: nocc ,: nocc ) if ( present ( gxp )) then wmo (: nocc ,: nocc ) = wmo (: nocc ,: nocc ) + 2 * gxp (: nocc ,: nocc ) end if ! W_ab (vir x vir) call dsyr2k ( 'u' , 't' , nvir , nocc , & e_state , xpy , nocc , & xmy , nocc , & 1.0d0 , wmo ( nocc + 1 :, nocc + 1 ), nbf ) do i = 1 , nocc wrk_ia ( i ,:) = xpy ( i ,: nvir ) * e_mo ( i ) end do call dgemm ( 't' , 'n' , nvir , nvir , nocc , & 1.0d0 , xpy , nocc , & wrk_ia , nocc , & 1.0d0 , wmo ( nocc + 1 :, nocc + 1 ), nbf ) do i = 1 , nocc wrk_ia ( i ,:) = xmy ( i ,: nvir ) * e_mo ( i ) end do call dgemm ( 't' , 'n' , nvir , nvir , nocc , & 1.0d0 , xmy , nocc , & wrk_ia , nocc , & 1.0d0 , wmo ( nocc + 1 :, nocc + 1 ), nbf ) ! W_ia (occ x vir) call dgemm ( 't' , 'n' , nocc , nvir , nocc , & 1.0_dp , hpp , nbf , & xpy , nocc , & 1.0_dp , wmo (:, nocc + 1 ), nbf ) call dgemm ( 't' , 'n' , nocc , nvir , nocc , & 1.0_dp , hmm , nbf , & xmy , nocc , & 1.0_dp , wmo (:, nocc + 1 ), nbf ) do i = 1 , nocc wmo ( i , nocc + 1 :) = wmo ( i , nocc + 1 :) + z ( i ,: nvir ) * e_mo ( i ) end do call triangular_to_full ( wmo , nbf , 'u' ) end subroutine !############################################################################### subroutine compute_r_mo ( rhs , mo , xpy , xmy , hpt , hpp , hmm , gxp ) use mathlib , only : orthogonal_transform implicit none real ( kind = dp ), contiguous , target , intent ( out ) :: rhs (:,:) real ( kind = dp ), intent ( in ) :: xpy ( * ), xmy ( * ) real ( kind = dp ), contiguous , intent ( in ) :: mo (:,:) real ( kind = dp ), contiguous , intent ( inout ) :: hpt (:,:,:), hpp (:,:,:), hmm (:,:,:), gxp (:,:) real ( kind = dp ), allocatable :: wrk1 (:,:) integer :: nbf , nocc , nvir nbf = ubound ( hpt , 1 ) nocc = ubound ( rhs , 1 ) nvir = ubound ( rhs , 2 ) allocate ( wrk1 ( nbf , nbf )) rhs = 0 call orthogonal_transform ( 'n' , nbf , mo , hpp (:,:, 1 ), wrk1 ) call dgemm ( 'n' , 't' , nocc , nvir , nvir , & 1.0_dp , xpy , nocc , & wrk1 ( nocc + 1 , nocc + 1 ), nbf , & 1.0_dp , rhs , nocc ) call dgemm ( 't' , 'n' , nocc , nvir , nocc , & - 1.0_dp , wrk1 , nbf , & xpy , nocc , & 1.0_dp , rhs , nocc ) call orthogonal_transform ( 'n' , nbf , mo , hmm (:,:, 1 ), wrk1 ) call dgemm ( 'n' , 't' , nocc , nvir , nvir , & 1.0_dp , xmy , nocc , & wrk1 ( nocc + 1 , nocc + 1 ), nbf , & 1.0_dp , rhs , nocc ) call dgemm ( 't' , 'n' , nocc , nvir , nocc , & - 1.0_dp , wrk1 , nbf , & xmy , nocc , & 1.0_dp , rhs , nocc ) call orthogonal_transform ( 'n' , nbf , mo , hpt (:,:, 1 ), wrk1 ) rhs = rhs + wrk1 ( 1 : nocc , nocc + 1 :) rhs = rhs + 2 * gxp ( 1 : nocc , nocc + 1 :) end subroutine !############################################################################### subroutine compute_apbx ( y , x , dat ) use iso_c_binding , only : c_ptr , c_f_pointer use tdhf_lib , only : iatogen , mntoia use mathlib , only : symmetrize_matrix , orthogonal_transform use mod_dft_gridint_fxc , only : tddft_fxc implicit none real ( kind = dp ) :: x (:) real ( kind = dp ) :: y (:) type ( c_ptr ) :: dat type ( tdhf_cg_data ), pointer :: p real ( kind = dp ), pointer :: apb (:,:,:) call c_f_pointer ( dat , p ) associate ( wrk => p % wrk , nocc => p % nocc , nbf => p % nbf & , mo => p % mo , pa => p % pa & , int2_driver => p % int2_driver & , int2_data => p % int2_data & , infos => p % infos & , molgrid => p % molgrid & , dft => p % dft & , xm => p % xm & ) call iatogen ( x , wrk , nocc , nocc ) call symmetrize_matrix ( wrk , nbf ) call orthogonal_transform ( 't' , nbf , mo , wrk , pa (:,:, 1 )) !     (A+B)*PK call int2_driver % run ( int2_data , & cam = dft . and . infos % dft % cam_flag , & alpha = infos % dft % cam_alpha , & beta = infos % dft % cam_beta ,& mu = infos % dft % cam_mu ) select type ( int2_data ) type is ( int2_td_data_t ) apb => int2_data % apb (:,:,:, 1 ) end select apb = apb * 0.5 if ( dft ) then call tddft_fxc ( basis = infos % basis , & molGrid = molGrid , & isVecs = . true ., & wf = mo , & fx = apb (:,:, 1 : 1 ), & dx = pa (:,:, 1 : 1 ), & nmtx = 1 , & !threshold=1.0d-15, & threshold = 0.0d0 , & infos = infos ) end if call mntoia ( apb (:,:, 1 ), y , mo , mo , nocc , nocc ) y = y + xm * x end associate end subroutine !############################################################################### subroutine precond ( y , x , dat ) use iso_c_binding , only : c_ptr , c_f_pointer implicit none real ( kind = dp ) :: x (:) real ( kind = dp ) :: y (:) type ( c_ptr ) :: dat type ( tdhf_cg_data ), pointer :: p call c_f_pointer ( dat , p ) ! diagonal approximation: ! (A+B)&#94;{-1} ~ 1/(e_vir-e_occ) y = p % xminv * x end subroutine end module","tags":"","url":"sourcefile/tdhf_z_vector.f90.html"},{"title":"oqp_linalg.F90 – OpenQP Fortran API","text":"Source Code #ifndef OQP_BLAS_INT #define OQP_BLAS_INT 4 #endif module oqp_linalg #if OQP_BLAS_INT == 4 use blas_wrap , only : caxpy => oqp_caxpy_i64 use blas_wrap , only : ccopy => oqp_ccopy_i64 use blas_wrap , only : cdotc => oqp_cdotc_i64 use blas_wrap , only : cdotu => oqp_cdotu_i64 use blas_wrap , only : cgbmv => oqp_cgbmv_i64 use blas_wrap , only : cgemm => oqp_cgemm_i64 use blas_wrap , only : cgemv => oqp_cgemv_i64 use blas_wrap , only : cgerc => oqp_cgerc_i64 use blas_wrap , only : cgeru => oqp_cgeru_i64 use blas_wrap , only : chbmv => oqp_chbmv_i64 use blas_wrap , only : chemm => oqp_chemm_i64 use blas_wrap , only : chemv => oqp_chemv_i64 use blas_wrap , only : cher => oqp_cher_i64 use blas_wrap , only : cher2 => oqp_cher2_i64 use blas_wrap , only : cher2k => oqp_cher2k_i64 use blas_wrap , only : cherk => oqp_cherk_i64 use blas_wrap , only : chpmv => oqp_chpmv_i64 use blas_wrap , only : chpr => oqp_chpr_i64 use blas_wrap , only : chpr2 => oqp_chpr2_i64 use blas_wrap , only : cscal => oqp_cscal_i64 use blas_wrap , only : csrot => oqp_csrot_i64 use blas_wrap , only : csscal => oqp_csscal_i64 use blas_wrap , only : cswap => oqp_cswap_i64 use blas_wrap , only : csymm => oqp_csymm_i64 use blas_wrap , only : csyr2k => oqp_csyr2k_i64 use blas_wrap , only : csyrk => oqp_csyrk_i64 use blas_wrap , only : ctbmv => oqp_ctbmv_i64 use blas_wrap , only : ctbsv => oqp_ctbsv_i64 use blas_wrap , only : ctpmv => oqp_ctpmv_i64 use blas_wrap , only : ctpsv => oqp_ctpsv_i64 use blas_wrap , only : ctrmm => oqp_ctrmm_i64 use blas_wrap , only : ctrmv => oqp_ctrmv_i64 use blas_wrap , only : ctrsm => oqp_ctrsm_i64 use blas_wrap , only : ctrsv => oqp_ctrsv_i64 use blas_wrap , only : dasum => oqp_dasum_i64 use blas_wrap , only : daxpy => oqp_daxpy_i64 use blas_wrap , only : dcopy => oqp_dcopy_i64 use blas_wrap , only : ddot => oqp_ddot_i64 use blas_wrap , only : dgbmv => oqp_dgbmv_i64 use blas_wrap , only : dgemm => oqp_dgemm_i64 use blas_wrap , only : dgemv => oqp_dgemv_i64 use blas_wrap , only : dger => oqp_dger_i64 use blas_wrap , only : drot => oqp_drot_i64 use blas_wrap , only : drotm => oqp_drotm_i64 use blas_wrap , only : dsbmv => oqp_dsbmv_i64 use blas_wrap , only : dscal => oqp_dscal_i64 use blas_wrap , only : dsdot => oqp_dsdot_i64 use blas_wrap , only : dspmv => oqp_dspmv_i64 use blas_wrap , only : dspr => oqp_dspr_i64 use blas_wrap , only : dspr2 => oqp_dspr2_i64 use blas_wrap , only : dswap => oqp_dswap_i64 use blas_wrap , only : dsymm => oqp_dsymm_i64 use blas_wrap , only : dsymv => oqp_dsymv_i64 use blas_wrap , only : dsyr => oqp_dsyr_i64 use blas_wrap , only : dsyr2 => oqp_dsyr2_i64 use blas_wrap , only : dsyr2k => oqp_dsyr2k_i64 use blas_wrap , only : dsyrk => oqp_dsyrk_i64 use blas_wrap , only : dtbmv => oqp_dtbmv_i64 use blas_wrap , only : dtbsv => oqp_dtbsv_i64 use blas_wrap , only : dtpmv => oqp_dtpmv_i64 use blas_wrap , only : dtpsv => oqp_dtpsv_i64 use blas_wrap , only : dtrmm => oqp_dtrmm_i64 use blas_wrap , only : dtrmv => oqp_dtrmv_i64 use blas_wrap , only : dtrsm => oqp_dtrsm_i64 use blas_wrap , only : dtrsv => oqp_dtrsv_i64 use blas_wrap , only : dzasum => oqp_dzasum_i64 use blas_wrap , only : icamax => oqp_icamax_i64 use blas_wrap , only : idamax => oqp_idamax_i64 use blas_wrap , only : isamax => oqp_isamax_i64 use blas_wrap , only : izamax => oqp_izamax_i64 use blas_wrap , only : sasum => oqp_sasum_i64 use blas_wrap , only : saxpy => oqp_saxpy_i64 use blas_wrap , only : scasum => oqp_scasum_i64 use blas_wrap , only : scopy => oqp_scopy_i64 use blas_wrap , only : sdot => oqp_sdot_i64 use blas_wrap , only : sdsdot => oqp_sdsdot_i64 use blas_wrap , only : sgbmv => oqp_sgbmv_i64 use blas_wrap , only : sgemm => oqp_sgemm_i64 use blas_wrap , only : sgemv => oqp_sgemv_i64 use blas_wrap , only : sger => oqp_sger_i64 use blas_wrap , only : srot => oqp_srot_i64 use blas_wrap , only : srotm => oqp_srotm_i64 use blas_wrap , only : ssbmv => oqp_ssbmv_i64 use blas_wrap , only : sscal => oqp_sscal_i64 use blas_wrap , only : sspmv => oqp_sspmv_i64 use blas_wrap , only : sspr => oqp_sspr_i64 use blas_wrap , only : sspr2 => oqp_sspr2_i64 use blas_wrap , only : sswap => oqp_sswap_i64 use blas_wrap , only : ssymm => oqp_ssymm_i64 use blas_wrap , only : ssymv => oqp_ssymv_i64 use blas_wrap , only : ssyr => oqp_ssyr_i64 use blas_wrap , only : ssyr2 => oqp_ssyr2_i64 use blas_wrap , only : ssyr2k => oqp_ssyr2k_i64 use blas_wrap , only : ssyrk => oqp_ssyrk_i64 use blas_wrap , only : stbmv => oqp_stbmv_i64 use blas_wrap , only : stbsv => oqp_stbsv_i64 use blas_wrap , only : stpmv => oqp_stpmv_i64 use blas_wrap , only : stpsv => oqp_stpsv_i64 use blas_wrap , only : strmm => oqp_strmm_i64 use blas_wrap , only : strmv => oqp_strmv_i64 use blas_wrap , only : strsm => oqp_strsm_i64 use blas_wrap , only : strsv => oqp_strsv_i64 use blas_wrap , only : xerbla => oqp_xerbla_i64 !  use blas_wrap, only: xerbla_array => oqp_xerbla_array_i64 use blas_wrap , only : zaxpy => oqp_zaxpy_i64 use blas_wrap , only : zcopy => oqp_zcopy_i64 use blas_wrap , only : zdotc => oqp_zdotc_i64 use blas_wrap , only : zdotu => oqp_zdotu_i64 use blas_wrap , only : zdrot => oqp_zdrot_i64 use blas_wrap , only : zdscal => oqp_zdscal_i64 use blas_wrap , only : zgbmv => oqp_zgbmv_i64 use blas_wrap , only : zgemm => oqp_zgemm_i64 use blas_wrap , only : zgemv => oqp_zgemv_i64 use blas_wrap , only : zgerc => oqp_zgerc_i64 use blas_wrap , only : zgeru => oqp_zgeru_i64 use blas_wrap , only : zhbmv => oqp_zhbmv_i64 use blas_wrap , only : zhemm => oqp_zhemm_i64 use blas_wrap , only : zhemv => oqp_zhemv_i64 use blas_wrap , only : zher => oqp_zher_i64 use blas_wrap , only : zher2 => oqp_zher2_i64 use blas_wrap , only : zher2k => oqp_zher2k_i64 use blas_wrap , only : zherk => oqp_zherk_i64 use blas_wrap , only : zhpmv => oqp_zhpmv_i64 use blas_wrap , only : zhpr => oqp_zhpr_i64 use blas_wrap , only : zhpr2 => oqp_zhpr2_i64 use blas_wrap , only : zscal => oqp_zscal_i64 use blas_wrap , only : zswap => oqp_zswap_i64 use blas_wrap , only : zsymm => oqp_zsymm_i64 use blas_wrap , only : zsyr2k => oqp_zsyr2k_i64 use blas_wrap , only : zsyrk => oqp_zsyrk_i64 use blas_wrap , only : ztbmv => oqp_ztbmv_i64 use blas_wrap , only : ztbsv => oqp_ztbsv_i64 use blas_wrap , only : ztpmv => oqp_ztpmv_i64 use blas_wrap , only : ztpsv => oqp_ztpsv_i64 use blas_wrap , only : ztrmm => oqp_ztrmm_i64 use blas_wrap , only : ztrmv => oqp_ztrmv_i64 use blas_wrap , only : ztrsm => oqp_ztrsm_i64 use blas_wrap , only : ztrsv => oqp_ztrsv_i64 use blas_wrap , only : dnrm2 => oqp_dnrm2_i64 use blas_wrap , only : dznrm2 => oqp_dznrm2_i64 use blas_wrap , only : scnrm2 => oqp_scnrm2_i64 use blas_wrap , only : snrm2 => oqp_snrm2_i64 use lapack_wrap , only : dgeqrf => oqp_dgeqrf_i64 use lapack_wrap , only : dgels => oqp_dgels_i64 use lapack_wrap , only : dgesv => oqp_dgesv_i64 use lapack_wrap , only : dsysv => oqp_dsysv_i64 use lapack_wrap , only : dgglse => oqp_dgglse_i64 use lapack_wrap , only : dorgqr => oqp_dorgqr_i64 use lapack_wrap , only : dormqr => oqp_dormqr_i64 use lapack_wrap , only : dtpttr => oqp_dtpttr_i64 use lapack_wrap , only : dtrttp => oqp_dtrttp_i64 #endif implicit none public end module","tags":"","url":"sourcefile/oqp_linalg.f90.html"},{"title":"qmmm.F90 – OpenQP Fortran API","text":"Source Code module qmmm_mod use oqp_linalg use resp_mod , only : add_atom_grid implicit none character ( len =* ), parameter :: module_name = \"qmmm_mod\" private public get_mm_energy public form_esp_charges public print_mm_energy public oqp_esp_qmmm public grad_esp_qmmm public espf_op_corr public add_potqm_contributions public form_esp_charges_excited contains subroutine espf_op_corr_C ( c_handle ) bind ( C , name = \"espf_op_corr\" ) use c_interop , only : oqp_handle_t , oqp_handle_get_info use types , only : information type ( oqp_handle_t ) :: c_handle type ( information ), pointer :: inf inf => oqp_handle_get_info ( c_handle ) !    call form_esp_charges(inf) call espf_op_corr ( inf ) end subroutine espf_op_corr_C subroutine form_esp_charges_C ( c_handle ) bind ( C , name = \"form_esp_charges\" ) use c_interop , only : oqp_handle_t , oqp_handle_get_info use types , only : information type ( oqp_handle_t ) :: c_handle type ( information ), pointer :: inf inf => oqp_handle_get_info ( c_handle ) call form_esp_charges ( inf ) end subroutine form_esp_charges_C subroutine grad_esp_qmmm_C ( c_handle ) bind ( C , name = \"grad_esp_qmmm\" ) use c_interop , only : oqp_handle_t , oqp_handle_get_info use types , only : information type ( oqp_handle_t ) :: c_handle type ( information ), pointer :: inf inf => oqp_handle_get_info ( c_handle ) call grad_esp_qmmm ( inf ) end subroutine grad_esp_qmmm_C subroutine grad_esp_qmmm_excited_C ( c_handle ) bind ( C , name = \"grad_esp_qmmm_excited\" ) use c_interop , only : oqp_handle_t , oqp_handle_get_info use types , only : information type ( oqp_handle_t ) :: c_handle type ( information ), pointer :: inf inf => oqp_handle_get_info ( c_handle ) call grad_esp_qmmm_excited ( inf ) end subroutine grad_esp_qmmm_excited_C subroutine form_esp_charges_excited ( infos ) use precision , only : dp use io_constants , only : iw use basis_tools , only : basis_set use messages , only : show_message , with_abort use types , only : information use oqp_tagarray_driver use int1 , only : omp_qmmm use constants , only : tol_int use mathlib , only : traceprod_sym_packed implicit none character ( len =* ), parameter :: module_name = \"form_esp_charges_excited\" character ( len =* ), parameter :: subroutine_name = \"form_esp_charges_excited\" type ( information ), target , intent ( inout ) :: infos type ( basis_set ), pointer :: basis integer :: nat , nbf , nbf2 , ok , istate integer :: npt , nptcur , i logical :: urohf , use_relaxed real ( dp ), allocatable :: tmp (:), chg_op (:) real ( dp ), allocatable , target :: xyz (:,:), ttt (:,:) real ( dp ), pointer :: wn (:,:) real ( dp ) :: tol , chg , corr real ( dp ), contiguous , pointer :: dmat_a (:), dmat_b (:), partial_charges (:) real ( dp ), contiguous , pointer :: td_p (:,:), td_abxc (:) character ( len =* ), parameter :: tags_required ( 5 ) = ( / character ( len = 80 ) :: & OQP_DM_A , OQP_DM_B , OQP_TD_P , OQP_TD_ABXC , OQP_SM / ) character ( len =* ), parameter :: tags_qmmm ( 1 ) = ( / character ( len = 80 ) :: & OQP_partial_charges / ) open ( unit = IW , file = infos % log_filename , position = \"append\" ) basis => infos % basis basis % atoms => infos % atoms nat = ubound ( infos % atoms % zn , 1 ) nbf = basis % nbf nbf2 = nbf * ( nbf + 1 ) / 2 istate = infos % tddft % target_state urohf = infos % control % scftype == 2 . or . infos % control % scftype == 3 use_relaxed = . true . ! ESPF_ROHF=1: use the ROHF reference density for ESPF charge fitting instead ! of the S1 relaxed density.  This matches GAMESS's ESPF implementation, which ! always fits charges from the ROHF reference (not the response density).  With ! the hard-pruned GAMESS grid (ESPF_GAMESS=1), the ROHF density has smaller ! ESPF fitting residuals at the grid boundary, so the force discontinuity when ! points blink in/out is much smaller -- reproducing GAMESS-level conservation. block character ( len = 8 ) :: env_r integer :: st_r call get_environment_variable ( 'ESPF_ROHF' , env_r , status = st_r ) if ( st_r == 0 ) then if ( trim ( env_r ) == '1' . or . trim ( env_r ) == 'on' ) use_relaxed = . false . end if end block call data_has_tags ( infos % dat , tags_required , module_name , subroutine_name , WITH_ABORT ) allocate ( tmp ( nbf2 ), stat = ok ) if ( ok /= 0 ) call show_message ( 'Cannot allocate tmp' , WITH_ABORT ) tmp = 0.0_dp call tagarray_get_data ( infos % dat , OQP_DM_A , dmat_a ) tmp = dmat_a if ( urohf ) then call tagarray_get_data ( infos % dat , OQP_DM_B , dmat_b ) tmp = tmp + dmat_b end if if ( use_relaxed ) then call tagarray_get_data ( infos % dat , OQP_TD_P , td_p ) tmp = tmp + td_p (:, 1 ) + td_p (:, 2 ) write ( iw , '(4x,a,i4)' ) 'Using RELAXED excited-state density for ESPF charges, state ' , istate else write ( iw , '(4x,a,i4)' ) 'Using ROHF reference density for ESPF charges (ESPF_ROHF), state ' , istate end if npt = nat * ( 132 + 152 + 192 + 350 ) allocate ( xyz ( npt , 3 ), ttt ( nat , npt ), chg_op ( nbf2 ), stat = ok ) if ( ok /= 0 ) call show_message ( 'Cannot allocate ESPF arrays' , WITH_ABORT ) call form_espf_grid ( nat , npt , 4 , [ 1.4_dp , 1.6_dp , 1.8_dp , 2.0_dp ], & [ 132 , 152 , 192 , 350 ], [ 3 , 3 , 3 , 0 ], & infos % atoms % zn , infos % atoms % xyz , xyz , ttt , nptcur ) wn => ttt (:,: nptcur ) tol = log ( 1 0.0d0 ) * tol_int ! alloc_or_die replaces the removed reserve_data API (main's tagarray ! container refactor) and binds the pointer in one call. call infos % dat % alloc_or_die ( OQP_partial_charges , ( / nat / ), partial_charges , & description = OQP_partial_charges_comment ) partial_charges = 0.0_dp call data_has_tags ( infos % dat , tags_qmmm , module_name , subroutine_name , WITH_ABORT ) call tagarray_get_data ( infos % dat , OQP_partial_charges , partial_charges ) corr = 0.0_dp do i = 1 , nat call omp_qmmm ( basis , i , transpose ( xyz ( 1 : nptcur ,:)), wn , chg_op , nat , logtol = tol ) chg = traceprod_sym_packed ( tmp , chg_op , nbf ) partial_charges ( i ) = infos % atoms % zn ( i ) + chg corr = corr + partial_charges ( i ) end do do i = 1 , nat partial_charges ( i ) = partial_charges ( i ) + ( infos % mol_prop % charge - corr ) / nat end do call print_charges ( infos , partial_charges , iw ) deallocate ( tmp , xyz , ttt , chg_op ) end subroutine form_esp_charges_excited subroutine espf_op_corr ( infos ) !,dmat,nbf) use precision , only : dp use oqp_tagarray_driver use basis_tools , only : basis_set use messages , only : show_message , with_abort use types , only : information use strings , only : Cstring , fstring use int1 , only : omp_qmmm use constants , only : tol_int use mathlib , only : traceprod_sym_packed implicit none character ( len =* ), parameter :: subroutine_name = \"espf_op_corr\" integer :: nbf !, intent(in) :: nbf type ( information ), target , intent ( inout ) :: infos integer :: nat , nelec , nbf2 , ok type ( basis_set ), pointer :: basis real ( kind = dp ), allocatable :: chg_op (:) real ( kind = dp ), target , allocatable :: ttt (:,:), xyz (:,:) real ( kind = dp ), pointer :: coord (:,:) real ( kind = dp ), pointer :: wn (:,:) integer :: npt , nptcur integer :: i real ( kind = dp ) :: chg integer , parameter :: nlayers = 4 real ( kind = dp ), parameter :: & layers ( nlayers ) = [ 1.4 , 1.6 , 1.8 , 2.0 ] integer , parameter :: npt_layer ( nlayers ) = [ 132 , 152 , 192 , 350 ] integer , parameter :: typ_layer ( nlayers ) = [ 3 , 3 , 3 , 0 ] real ( kind = dp ), allocatable :: sum_op (:), corr (:) real ( kind = dp ) :: tol real ( kind = dp ), contiguous , pointer :: dmat_a (:), dmat_b (:) character ( len =* ), parameter :: tags_alpha ( 1 ) = & ( / character ( len = 80 ) :: OQP_DM_A / ) character ( len =* ), parameter :: tags_beta ( 1 ) = & ( / character ( len = 80 ) :: OQP_DM_B / ) !============================================================================== ! Tag Arrays for Accessing Data !============================================================================== real ( kind = dp ), contiguous , pointer :: smat (:), chg_ops_corr (:,:) character ( len =* ), parameter :: tags_general ( 1 ) = & ( / character ( len = 80 ) :: OQP_SM / ) character ( len =* ), parameter :: tags ( 1 ) = & ( / character ( len = 80 ) :: OQP_ESPF_CORR / ) !   Load basis set basis => infos % basis basis % atoms => infos % atoms nbf = basis % nbf !   Allocate memory nbf2 = nbf * ( nbf + 1 ) / 2 nat = ubound ( infos % atoms % zn , 1 ) nelec = infos % mol_prop % nelec npt = nat * sum ( npt_layer ) allocate ( xyz ( npt , 3 ), & ttt ( nat , npt ), & chg_op ( nbf2 ), & sum_op ( nbf2 ), & corr ( nbf2 ), & stat = ok ) if ( ok /= 0 ) call show_message ( 'Cannot allocate memory' , WITH_ABORT ) call data_has_tags ( infos % dat , tags_general , module_name , subroutine_name , WITH_ABORT ) call tagarray_get_data ( infos % dat , OQP_SM , smat ) call infos % dat % alloc_or_die ( OQP_ESPF_CORR , ( / nbf2 , nat / ), chg_ops_corr , description = OQP_ESPF_CORR_comment ) call data_has_tags ( infos % dat , tags , module_name , subroutine_name , WITH_ABORT ) call tagarray_get_data ( infos % dat , OQP_ESPF_CORR , chg_ops_corr ) call form_espf_grid ( nat , npt , nlayers , layers , npt_layer , typ_layer , infos % atoms % zn , infos % atoms % xyz , xyz , ttt , nptcur ) wn => ttt (:,: nptcur ) tol = log ( 1 0.0d0 ) * tol_int sum_op = 0 do i = 1 , nat chg_ops_corr (:, i ) = 0.0_dp call omp_qmmm ( & basis , & i , & transpose ( xyz ( 1 : nptcur ,:)), & wn , & chg_ops_corr (:, i ), & nat , & logtol = tol ) sum_op (:) = sum_op (:) + chg_ops_corr (:, i ) end do corr (:) = ( sum_op (:) + smat (:)) / real ( nat , dp ) do i = 1 , nat chg_ops_corr (:, i ) = chg_ops_corr (:, i ) - corr (:) end do deallocate ( xyz , ttt , chg_op , sum_op , corr ) end subroutine espf_op_corr subroutine add_potqm_contributions ( infos , dens , dh ) use precision , only : dp use basis_tools , only : basis_set use types , only : information use messages , only : show_message , with_abort use mathlib , only : traceprod_sym_packed use oqp_tagarray_driver implicit none character ( len =* ), parameter :: subroutine_name = \"add_potqm_contributions\" character ( len =* ), parameter :: module_name = \"qmmm_espf\" ! adjust if needed type ( information ), target , intent ( inout ) :: infos real ( dp ), contiguous , intent ( in ) :: dens (:) real ( dp ), contiguous , intent ( inout ) :: dh (:) type ( basis_set ), pointer :: basis integer :: nbf , nbf2 , nat , i , ok real ( dp ), contiguous , pointer :: smat (:), potqm (:,:), chg_ops_corr (:,:) real ( dp ), allocatable :: q (:) real ( dp ), allocatable :: v (:) !    real(dp), allocatable :: dh(:) character ( len =* ), parameter :: tags ( 3 ) = & ( / character ( len = 80 ) :: OQP_SM , OQP_ESPF_CORR , OQP_POTQM / ) if (. not . infos % control % qmmm_flag ) return basis => infos % basis basis % atoms => infos % atoms nbf = basis % nbf nbf2 = nbf * ( nbf + 1 ) / 2 nat = ubound ( infos % atoms % zn , 1 ) call data_has_tags ( infos % dat , tags , module_name , subroutine_name , WITH_ABORT ) call tagarray_get_data ( infos % dat , OQP_SM , smat ) call tagarray_get_data ( infos % dat , OQP_ESPF_CORR , chg_ops_corr ) call tagarray_get_data ( infos % dat , OQP_POTQM , potqm ) allocate ( q ( nat ), v ( nat ), stat = ok ) if ( ok /= 0 ) call show_message ( \"Cannot allocate memory in add_potqm_contributions\" , WITH_ABORT ) q (:) = 0.0_dp do i = 1 , nat q ( i ) = traceprod_sym_packed ( dens , chg_ops_corr (:, i ), nbf ) end do v = matmul ( potqm , q ) dh (:) = 0.0_dp do i = 1 , nat dh (:) = dh (:) - v ( i ) * chg_ops_corr (:, i ) end do deallocate ( q , v ) end subroutine add_potqm_contributions !> @brief Compute the MM and atomic QM/MM contributions to energy ! !> @detail Classical contributions to energy and the QM atomic charge times MM potential ! !> @author   Miquel Huix-Rotllant ! !     REVISION HISTORY: !> @date _Oct, 2024_ Initial release subroutine get_mm_energy ( infos , emm ) use precision , only : dp use oqp_tagarray_driver use types , only : information use messages , only : WITH_ABORT implicit none character ( len =* ), parameter :: subroutine_name = \"get_mm_energy\" real ( kind = dp ), intent ( inout ) :: emm real ( kind = dp ), contiguous , pointer :: mm_potential (:), mm_energy (:) character ( len =* ), parameter :: tags_qmmm ( 2 ) = ( / character ( len = 80 ) :: & OQP_mm_potential , OQP_mm_energy / ) type ( information ), target , intent ( inout ) :: infos emm = 0.0d0 if (. not . infos % control % qmmm_flag ) return call data_has_tags ( infos % dat , tags_qmmm , module_name , subroutine_name , WITH_ABORT ) call tagarray_get_data ( infos % dat , OQP_mm_energy , mm_energy ) call tagarray_get_data ( infos % dat , OQP_mm_potential , mm_potential ) emm = sum ( mm_energy ) + dot_product ( mm_potential , infos % atoms % zn ) return end subroutine get_mm_energy !-------------------------------------------------------------------------------- !> @brief Print MM energy decomposition in file ! !> @detail Classical contributions to energy and the QM atomic charge times MM potential ! !> @author   Miquel Huix-Rotllant ! !     REVISION HISTORY: !> @date _Oct, 2024_ Initial release subroutine print_mm_energy ( infos ) use precision , only : dp use oqp_tagarray_driver use types , only : information use messages , only : WITH_ABORT use io_constants , only : iw implicit none character ( len =* ), parameter :: subroutine_name = \"get_mm_energy\" real ( kind = dp ), contiguous , pointer :: mm_potential (:), mm_energy (:), partial_charges (:) character ( len =* ), parameter :: tags_qmmm ( 3 ) = ( / character ( len = 80 ) :: & OQP_mm_potential , OQP_mm_energy , OQP_partial_charges / ) type ( information ), target , intent ( inout ) :: infos if (. not . infos % control % qmmm_flag ) return call data_has_tags ( infos % dat , tags_qmmm , module_name , subroutine_name , WITH_ABORT ) call tagarray_get_data ( infos % dat , OQP_mm_energy , mm_energy ) call tagarray_get_data ( infos % dat , OQP_mm_potential , mm_potential ) call tagarray_get_data ( infos % dat , OQP_partial_charges , partial_charges ) write ( iw , * ) ! QM/MM interaction energy write ( iw , \"(' QM/MM: Electrostatic energy      = ',F20.10)\" )& dot_product ( partial_charges , mm_potential ) ! Classical forcefields if ( abs ( mm_energy ( 1 )). gt . 1.0d-10 )& write ( iw , \"(' MM: Bonded energy                = ',F20.10)\" ) mm_energy ( 1 ) if ( abs ( mm_energy ( 2 )). gt . 1.0d-10 )& write ( iw , \"(' MM: Angle bending energy         = ',F20.10)\" ) mm_energy ( 2 ) if ( abs ( mm_energy ( 3 )). gt . 1.0d-10 )& write ( iw , \"(' MM: Periodic Torsion energy      = ',F20.10)\" ) mm_energy ( 3 ) if ( abs ( mm_energy ( 4 )). gt . 1.0d-10 )& write ( iw , \"(' MM: RBTorsion energy             = ',F20.10)\" ) mm_energy ( 4 ) if ( abs ( mm_energy ( 5 )). gt . 1.0d-10 )& write ( iw , \"(' MM: Nonbonded energy             = ',F20.10)\" ) mm_energy ( 5 ) ! Custom Classical forcefields if ( abs ( mm_energy ( 6 )). gt . 1.0d-10 )& write ( iw , \"(' MM: CustomBonded energy          = ',F20.10)\" ) mm_energy ( 6 ) if ( abs ( mm_energy ( 7 )). gt . 1.0d-10 )& write ( iw , \"(' MM: CustomAngle energy           = ',F20.10)\" ) mm_energy ( 7 ) if ( abs ( mm_energy ( 8 )). gt . 1.0d-10 )& write ( iw , \"(' MM: CustomTorsion energy         = ',F20.10)\" ) mm_energy ( 8 ) if ( abs ( mm_energy ( 9 )). gt . 1.0d-10 )& write ( iw , \"(' MM: CustomNonbonded energy       = ',F20.10)\" ) mm_energy ( 9 ) if ( abs ( mm_energy ( 10 )). gt . 1.0d-10 )& write ( iw , \"(' MM: CustomExternal energy        = ',F20.10)\" ) mm_energy ( 10 ) ! Implicit solvation if ( abs ( mm_energy ( 11 )). gt . 1.0d-10 )& write ( iw , \"(' MM: GBSAOBC energy               = ',F20.10)\" ) mm_energy ( 11 ) if ( abs ( mm_energy ( 12 )). gt . 1.0d-10 )& write ( iw , \"(' MM: CustomGB energy              = ',F20.10)\" ) mm_energy ( 12 ) ! Amoeba forcefields if ( abs ( mm_energy ( 13 )). gt . 1.0d-10 )& write ( iw , \"(' MM: AmoebaMultipole energy       = ',F20.10)\" ) mm_energy ( 13 ) if ( abs ( mm_energy ( 14 )). gt . 1.0d-10 )& write ( iw , \"(' MM: AmoebaVdw energy             = ',F20.10)\" ) mm_energy ( 14 ) if ( abs ( mm_energy ( 15 )). gt . 1.0d-10 )& write ( iw , \"(' MM: AmoebaBond energy            = ',F20.10)\" ) mm_energy ( 15 ) if ( abs ( mm_energy ( 16 )). gt . 1.0d-10 )& write ( iw , \"(' MM: AmoebaAngle energy           = ',F20.10)\" ) mm_energy ( 16 ) if ( abs ( mm_energy ( 17 )). gt . 1.0d-10 )& write ( iw , \"(' MM: AmoebaTorsion energy         = ',F20.10)\" ) mm_energy ( 17 ) if ( abs ( mm_energy ( 18 )). gt . 1.0d-10 )& write ( iw , \"(' MM: AmoebaOutOfPlaneBend energy  = ',F20.10)\" ) mm_energy ( 18 ) if ( abs ( mm_energy ( 19 )). gt . 1.0d-10 )& write ( iw , \"(' MM: AmoebaPiTorsion energy       = ',F20.10)\" ) mm_energy ( 19 ) if ( abs ( mm_energy ( 20 )). gt . 1.0d-10 )& write ( iw , \"(' MM: AmoebaStretchBend energy     = ',F20.10)\" ) mm_energy ( 20 ) if ( abs ( mm_energy ( 21 )). gt . 1.0d-10 )& write ( iw , \"(' MM: AmoebaUreyBradley energy     = ',F20.10)\" ) mm_energy ( 21 ) if ( abs ( mm_energy ( 22 )). gt . 1.0d-10 )& write ( iw , \"(' MM: AmoebaVdw14 energy           = ',F20.10)\" ) mm_energy ( 22 ) ! Extras if ( abs ( mm_energy ( 23 )). gt . 1.0d-10 )& write ( iw , \"(' MM: CMMotion energy              = ',F20.10)\" ) mm_energy ( 23 ) if ( abs ( mm_energy ( 24 )). gt . 1.0d-10 )& write ( iw , \"(' MM: CustomCompoundBond energy    = ',F20.10)\" ) mm_energy ( 24 ) if ( abs ( mm_energy ( 25 )). gt . 1.0d-10 )& write ( iw , \"(' MM: MonteCarloBarostad           = ',F20.10)\" ) mm_energy ( 25 ) write ( iw , * ) call print_charges ( infos , partial_charges , iw ) return end subroutine print_mm_energy !-------------------------------------------------------------------------------- !> @brief Compute the MM and atomic QM/MM contributions to energy ! !> @detail Classical contributions to energy and the QM atomic charge times MM potential ! !> @author   Miquel Huix-Rotllant ! !     REVISION HISTORY: !> @date _Oct, 2024_ Initial release subroutine form_esp_charges ( infos ) !,dmat,nbf) use precision , only : dp use oqp_tagarray_driver use basis_tools , only : basis_set use messages , only : show_message , with_abort use types , only : information use strings , only : Cstring , fstring use int1 , only : omp_qmmm use constants , only : tol_int use mathlib , only : traceprod_sym_packed implicit none character ( len =* ), parameter :: subroutine_name = \"form_esp_charges\" integer :: nbf !, intent(in) :: nbf real ( kind = dp ), allocatable :: dmat (:) !(nbf*nbf)!, intent(in) :: dmat(nbf*nbf) type ( information ), target , intent ( inout ) :: infos real ( kind = dp ), contiguous , pointer :: partial_charges (:) character ( len =* ), parameter :: tags_qmmm ( 1 ) = ( / character ( len = 80 ) :: & OQP_partial_charges / ) integer :: nat , nelec , nbf2 , ok type ( basis_set ), pointer :: basis real ( kind = dp ), allocatable :: chg_op (:) real ( kind = dp ), target , allocatable :: ttt (:,:), xyz (:,:) real ( kind = dp ), pointer :: coord (:,:) real ( kind = dp ), pointer :: wn (:,:) integer :: npt , nptcur integer :: i real ( kind = dp ) :: chg , corr integer , parameter :: nlayers = 4 real ( kind = dp ), parameter :: & layers ( nlayers ) = [ 1.4 , 1.6 , 1.8 , 2.0 ] integer , parameter :: npt_layer ( nlayers ) = [ 132 , 152 , 192 , 350 ] integer , parameter :: typ_layer ( nlayers ) = [ 3 , 3 , 3 , 0 ] real ( kind = dp ) :: tol real ( kind = dp ), contiguous , pointer :: dmat_a (:), dmat_b (:) character ( len =* ), parameter :: tags_alpha ( 1 ) = & ( / character ( len = 80 ) :: OQP_DM_A / ) character ( len =* ), parameter :: tags_beta ( 1 ) = & ( / character ( len = 80 ) :: OQP_DM_B / ) !   Load basis set basis => infos % basis basis % atoms => infos % atoms nbf = basis % nbf !   Allocate memory nbf2 = nbf * ( nbf + 1 ) / 2 nat = ubound ( infos % atoms % zn , 1 ) nelec = infos % mol_prop % nelec npt = nat * sum ( npt_layer ) call data_has_tags ( infos % dat , tags_alpha , module_name , subroutine_name , WITH_ABORT ) call tagarray_get_data ( infos % dat , OQP_DM_A , dmat_a ) ! Get beta-spin tag arrays if needed if ( infos % control % scftype > 1 ) then call data_has_tags ( infos % dat , tags_beta , module_name , subroutine_name , WITH_ABORT ) call tagarray_get_data ( infos % dat , OQP_DM_B , dmat_b ) end if allocate ( xyz ( npt , 3 ), & ttt ( nat , npt ), & chg_op ( nbf2 ), & dmat ( nbf2 ), & stat = ok ) if ( ok /= 0 ) call show_message ( 'Cannot allocate memory' , WITH_ABORT ) dmat = dmat_a if ( infos % control % scftype > 1 ) then dmat = dmat + dmat_b end if call form_espf_grid ( nat , npt , nlayers , layers , npt_layer , typ_layer , infos % atoms % zn , infos % atoms % xyz , xyz , ttt , nptcur ) ! Compute integrals and form partial charges wn => ttt (:,: nptcur ) tol = log ( 1 0.0d0 ) * tol_int call infos % dat % alloc_or_die ( OQP_partial_charges , ( / infos % mol_prop % natom / ), partial_charges , description = OQP_partial_charges_comment ) call data_has_tags ( infos % dat , tags_qmmm , module_name , subroutine_name , WITH_ABORT ) call tagarray_get_data ( infos % dat , OQP_partial_charges , partial_charges ) ! Form partial charges and compute the correction for total charge corr = 0.0_dp !nelec/nat do i = 1 , nat call omp_qmmm ( basis , i , transpose ( xyz ( 1 : nptcur ,:)), wn , chg_op , nat , logtol = tol ) chg = traceprod_sym_packed ( dmat , chg_op , nbf ) partial_charges ( i ) = infos % atoms % zn ( i ) + chg corr = corr + partial_charges ( i ) end do ! Correct for the total charge do i = 1 , nat partial_charges ( i ) = partial_charges ( i ) + ( infos % mol_prop % charge - corr ) / nat end do deallocate ( xyz , ttt , chg_op , dmat ) end subroutine form_esp_charges !-------------------------------------------------------------------------------- !> @brief Compute the QM/MM one-electron hamiltonian using ESPF method !> @param[in]      infos        OQP handle !> @param[in,out]  hqmmm        QM/MM one-electron hamiltonian !> @param[in]      mm_potential classical MM potential on QM centers !> @param[in]      smat         overlap matrix !> @param[in]      logtol       tolerance threshold for integrals ! !> @detail This subroutine computes the one-electron hamiltonian for introducing the QM/MM interaction !>         in the core hamiltonian using the electrostatic potential fitted (ESPF) method. ! !> @author   Miquel Huix-Rotllant ! !     REVISION HISTORY: !> @date _Jul, 2024_ Initial release subroutine oqp_esp_qmmm ( infos , Hqmmm , mm_potential , smat , logtol ) use precision , only : dp use basis_tools , only : basis_set use messages , only : show_message , with_abort use types , only : information use strings , only : Cstring , fstring use int1 , only : omp_qmmm use lebedev , only : lebedev_get_grid use elements , only : ELEMENTS_VDW_RADII implicit none character ( len =* ), parameter :: subroutine_name = \"oqp_esp_qmmm\" type ( information ), target , intent ( inout ) :: infos real ( kind = dp ), contiguous , intent ( inout ) :: Hqmmm (:) real ( kind = dp ), contiguous , intent ( in ) :: smat (:), mm_potential (:) real ( kind = dp ), intent ( in ) :: logtol integer :: nbf , nbf2 , ok type ( basis_set ), pointer :: basis real ( kind = dp ), allocatable :: wt (:), chg_op (:) real ( kind = dp ), allocatable :: xyz (:,:) real ( kind = dp ), target , allocatable :: ttt (:,:) real ( kind = dp ), pointer :: coord (:,:) real ( kind = dp ), pointer :: wn (:,:) integer :: nat , npt , nptcur integer :: i real ( kind = dp ) :: mm_pot_av integer , parameter :: nlayers = 4 real ( kind = dp ), parameter :: & layers ( nlayers ) = [ 1.4 , 1.6 , 1.8 , 2.0 ] integer , parameter :: npt_layer ( nlayers ) = [ 132 , 152 , 192 , 350 ] integer , parameter :: typ_layer ( nlayers ) = [ 3 , 3 , 3 , 0 ] logical :: restr !   Load basis set basis => infos % basis basis % atoms => infos % atoms !   Allocate memory nbf = basis % nbf nbf2 = nbf * ( nbf + 1 ) / 2 nat = ubound ( infos % atoms % zn , 1 ) npt = nat * sum ( npt_layer ) allocate ( xyz ( npt , 3 ), & wt ( npt ), & ttt ( nat , npt ), & chg_op ( nbf2 ), & stat = ok ) if ( ok /= 0 ) call show_message ( 'Cannot allocate memory' , WITH_ABORT ) ! Compute the numerical Lebedev grid (xyz) and integral weights (TTT) call form_espf_grid ( nat , npt , nlayers , layers , npt_layer , typ_layer , infos % atoms % zn , infos % atoms % xyz , xyz , ttt , nptcur ) ! Compute integrals and form QM/MM hamiltonian wn => ttt (:,: nptcur ) mm_pot_av = sum ( mm_potential ) / nat hqmmm = - smat * mm_pot_av do i = 1 , nat call omp_qmmm ( basis , i , transpose ( xyz ( 1 : nptcur ,:)), wn , chg_op , nat , logtol ) hqmmm = hqmmm + ( mm_potential ( i ) - mm_pot_av ) * chg_op end do end subroutine oqp_esp_qmmm !-------------------------------------------------------------------------------- !> @brief Compute the gradient contributions from the QM/MM interaction energy using ESPF method !> @param[in]      infos        OQP handle !> @param[in]      dens         density matrix !> @param[in,out]  grad         energy gradient !> @param[in]      logtol       tolerance threshold for integrals ! !> @detail This subroutine computes the analytic derivatives of the QM/MM interaction energy !>         from the electrostatic potential fitted (ESPF) method. Here the polarizable term !>         (Q&#94;x*mm_potential) and the classical term (Q*mm_potential&#94;x) computed by OpenMM !>         are added to the QM gradient. The MM atoms gradient is added in the python layer. ! !> @author   Miquel Huix-Rotllant ! !     REVISION HISTORY: !> @date _Jul, 2024_ Initial release subroutine grad_esp_qmmm ( infos ) !, dens, grad, logtol) use oqp_tagarray_driver use precision , only : dp use basis_tools , only : basis_set use messages , only : show_message , with_abort use types , only : information use strings , only : Cstring , fstring use grd1 , only : grad_elpot , grad_ee_overlap use lebedev , only : lebedev_get_grid use elements , only : ELEMENTS_VDW_RADII use constants , only : tol_int implicit none character ( len =* ), parameter :: subroutine_name = \"grad_esp_qmmm\" type ( information ), target , intent ( inout ) :: infos !    real(kind=dp), intent(inout) :: grad(:,:) !    real(kind=dp), intent(inout) :: dens(:) real ( kind = dp ) :: logtol integer :: nbf , nbf2 , ok type ( basis_set ), pointer :: basis real ( kind = dp ), allocatable :: wt (:), dens (:) real ( kind = dp ), allocatable :: xyz (:,:) real ( kind = dp ), target , allocatable :: ttt (:,:) integer :: nat , npt , nptcur integer :: i , j , k integer , parameter :: nlayers = 4 real ( kind = dp ), parameter :: & layers ( nlayers ) = [ 1.4 , 1.6 , 1.8 , 2.0 ] integer , parameter :: npt_layer ( nlayers ) = [ 132 , 152 , 192 , 350 ] integer , parameter :: typ_layer ( nlayers ) = [ 3 , 3 , 3 , 0 ] !tagarray real ( kind = dp ), contiguous , pointer :: partial_charges (:), mm_potential (:),& espf_grad_ta (:,:), & dmat_a (:), dmat_b (:) character ( len =* ), parameter :: tags_qmmm ( 4 ) = ( / character ( len = 80 ) :: & OQP_partial_charges , OQP_POTMM , OQP_ESPF_GRAD , OQP_DM_A / ) character ( len =* ), parameter :: tags_beta ( 1 ) = ( / character ( len = 80 ) :: & OQP_DM_B / ) real ( kind = dp ) :: mm_pot_av logical :: skip_legacy character ( len = 8 ) :: env_l integer :: st_l !   Load basis set basis => infos % basis basis % atoms => infos % atoms !   Replace legacy espf_grad weight term with the complete pseudoinverse !   derivative (espf_grad_weight); ESPF_LEGACY=1 restores the old term. skip_legacy = . true . call get_environment_variable ( 'ESPF_LEGACY' , env_l , status = st_l ) if ( st_l == 0 ) then if ( trim ( env_l ) == '1' . or . trim ( env_l ) == 'on' ) skip_legacy = . false . end if !   Allocate memory nbf = basis % nbf nbf2 = nbf * ( nbf + 1 ) / 2 nat = ubound ( infos % atoms % zn , 1 ) npt = nat * sum ( npt_layer ) logtol = log ( 1 0.0d0 ) * tol_int allocate ( xyz ( npt , 3 ), & wt ( npt ), & ttt ( nat , npt ), & dens ( nbf2 ), & stat = ok ) if ( ok /= 0 ) call show_message ( 'Cannot allocate memory' , WITH_ABORT ) call form_espf_grid ( nat , npt , nlayers , layers , npt_layer , typ_layer , infos % atoms % zn , infos % atoms % xyz , xyz , ttt , nptcur ) ! ESP gradient contribution !   Tagarray call infos % dat % alloc_or_die ( OQP_ESPF_GRAD , ( / 3 , nat / ), espf_grad_ta , description = OQP_ESPF_GRAD_comment ) call data_has_tags ( infos % dat , tags_qmmm , module_name , subroutine_name , WITH_ABORT ) call tagarray_get_data ( infos % dat , OQP_POTMM , mm_potential ) call tagarray_get_data ( infos % dat , OQP_partial_charges , partial_charges ) call tagarray_get_data ( infos % dat , OQP_DM_A , dmat_a ) call tagarray_get_data ( infos % dat , OQP_ESPF_GRAD , espf_grad_ta ) ! Get beta-spin tag arrays if needed if ( infos % control % scftype > 1 ) then call data_has_tags ( infos % dat , tags_beta , module_name , subroutine_name , WITH_ABORT ) call tagarray_get_data ( infos % dat , OQP_DM_B , dmat_b ) end if espf_grad_ta = 0.0_dp dens = dmat_a if ( infos % control % scftype >= 2 ) dens = dens + dmat_b ! Compute integrals and form ESP operators !   Compute the corrected mm potential mm_pot_av = sum ( mm_potential ) / nat do i = 1 , nat mm_potential ( i ) = mm_pot_av - mm_potential ( i ) end do !   Add integral gradient term, mm_potential*[(T&#94;+T)&#94;-1*T&#94;+]*V&#94;x do i = 1 , nptcur wt ( i ) =- dot_product ( ttt (:, i ), mm_potential ) call grad_elpot ( basis , xyz ( i ,:), wt ( i ), dens , espf_grad_ta ) end do !   Add overlap derivative correction for the total charge conservation if ( abs ( mm_pot_av ). gt . 1.0e-6 ) then dens =- mm_pot_av * dens call grad_ee_overlap ( basis , dens , espf_grad_ta , logtol ) dens =- dens / mm_pot_av end if !   Add weights gradient term, -mm_potential*[(T&#94;+T)&#94;-1*T&#94;+]*T&#94;xQ + q*mm_potential&#94;x if (. not . skip_legacy ) then call espf_grad (& x = xyz (: nptcur , 1 ),& y = xyz (: nptcur , 2 ),& z = xyz (: nptcur , 3 ),& at = infos % atoms % xyz ,& wt = wt ,& zn = infos % atoms % zn ,& pchg = partial_charges ,& grad = espf_grad_ta ) end if !    espf_grad = grad !   Complete pseudoinverse-weight derivative dZ/dR (a_i = phi_i-<phi> = -mm_potential) call espf_grad_weight ( basis , nat , nptcur , infos % atoms % xyz , xyz , & ttt , - mm_potential ( 1 : nat ), dens , espf_grad_ta , logtol , & ELEMENTS_VDW_RADII ( int ( infos % atoms % zn ))) !   Restablish mm potential to the original one do i = 1 , nat ! it seems not to be:  mm_potential(i)= - mm_pot_av-mm_potential(i) mm_potential ( i ) = mm_pot_av - mm_potential ( i ) end do end subroutine grad_esp_qmmm subroutine grad_esp_qmmm_excited ( infos ) !, dens, grad, logtol) use oqp_tagarray_driver use precision , only : dp use basis_tools , only : basis_set use messages , only : show_message , with_abort use types , only : information use strings , only : Cstring , fstring use grd1 , only : grad_elpot , grad_ee_overlap use lebedev , only : lebedev_get_grid use elements , only : ELEMENTS_VDW_RADII use constants , only : tol_int implicit none character ( len =* ), parameter :: subroutine_name = \"grad_esp_qmmm_excited\" type ( information ), target , intent ( inout ) :: infos !    real(kind=dp), intent(inout) :: grad(:,:) !    real(kind=dp), intent(inout) :: dens(:) real ( kind = dp ) :: logtol integer :: nbf , nbf2 , ok type ( basis_set ), pointer :: basis real ( kind = dp ), allocatable :: wt (:), dens (:) real ( kind = dp ), allocatable :: xyz (:,:) real ( kind = dp ), target , allocatable :: ttt (:,:) integer :: nat , npt , nptcur integer :: i , j , k integer , parameter :: nlayers = 4 real ( kind = dp ), parameter :: & layers ( nlayers ) = [ 1.4 , 1.6 , 1.8 , 2.0 ] integer , parameter :: npt_layer ( nlayers ) = [ 132 , 152 , 192 , 350 ] integer , parameter :: typ_layer ( nlayers ) = [ 3 , 3 , 3 , 0 ] !tagarray real ( kind = dp ), contiguous , pointer :: partial_charges (:), mm_potential (:),& espf_grad_ta (:,:), & dmat_a (:), dmat_b (:) real ( dp ), contiguous , pointer :: td_p (:,:), td_abxc (:) character ( len =* ), parameter :: tags_qmmm ( 6 ) = ( / character ( len = 80 ) :: & OQP_partial_charges , OQP_POTMM , OQP_ESPF_GRAD , OQP_DM_A , & OQP_TD_P , OQP_TD_ABXC / ) character ( len =* ), parameter :: tags_beta ( 1 ) = ( / character ( len = 80 ) :: & OQP_DM_B / ) real ( kind = dp ) :: mm_pot_av logical :: use_relaxed logical :: skip_legacy character ( len = 8 ) :: env_l integer :: st_l !   Load basis set basis => infos % basis basis % atoms => infos % atoms use_relaxed = . true . ! ESPF_ROHF=1: use ROHF reference density in the ESPF gradient.  The ROHF ! density has smaller ESP fitting residuals at grid-boundary points; when the ! GAMESS hard-pruned grid (ESPF_GAMESS=1) removes those points the force ! discontinuity is therefore much smaller, reproducing GAMESS energy conservation. block character ( len = 8 ) :: env_r2 integer :: st_r2 call get_environment_variable ( 'ESPF_ROHF' , env_r2 , status = st_r2 ) if ( st_r2 == 0 ) then if ( trim ( env_r2 ) == '1' . or . trim ( env_r2 ) == 'on' ) use_relaxed = . false . end if end block ! The legacy espf_grad weight term is replaced by the complete pseudoinverse ! derivative (espf_grad_weight, ported from GAMESS DVESPF/INIDZ): FD-verified ! to cut the QM-atom force-energy inconsistency from RMS 1.6e-3 to 5.2e-4 ! Ha/bohr at large displacement.  Set ESPF_LEGACY=1 to restore the old term. skip_legacy = . true . call get_environment_variable ( 'ESPF_LEGACY' , env_l , status = st_l ) if ( st_l == 0 ) then if ( trim ( env_l ) == '1' . or . trim ( env_l ) == 'on' ) skip_legacy = . false . end if !   Allocate memory nbf = basis % nbf nbf2 = nbf * ( nbf + 1 ) / 2 nat = ubound ( infos % atoms % zn , 1 ) npt = nat * sum ( npt_layer ) logtol = log ( 1 0.0d0 ) * tol_int allocate ( xyz ( npt , 3 ), & wt ( npt ), & ttt ( nat , npt ), & dens ( nbf2 ), & stat = ok ) if ( ok /= 0 ) call show_message ( 'Cannot allocate memory' , WITH_ABORT ) call form_espf_grid ( nat , npt , nlayers , layers , npt_layer , typ_layer , infos % atoms % zn , infos % atoms % xyz , xyz , ttt , nptcur ) ! ESP gradient contribution !   Tagarray call infos % dat % alloc_or_die ( OQP_ESPF_GRAD , ( / 3 , nat / ), espf_grad_ta , description = OQP_ESPF_GRAD_comment ) call data_has_tags ( infos % dat , tags_qmmm , module_name , subroutine_name , WITH_ABORT ) call tagarray_get_data ( infos % dat , OQP_POTMM , mm_potential ) call tagarray_get_data ( infos % dat , OQP_partial_charges , partial_charges ) call tagarray_get_data ( infos % dat , OQP_DM_A , dmat_a ) call tagarray_get_data ( infos % dat , OQP_ESPF_GRAD , espf_grad_ta ) ! Get beta-spin tag arrays if needed if ( infos % control % scftype > 1 ) then call data_has_tags ( infos % dat , tags_beta , module_name , subroutine_name , WITH_ABORT ) call tagarray_get_data ( infos % dat , OQP_DM_B , dmat_b ) end if espf_grad_ta = 0.0_dp dens = dmat_a if ( infos % control % scftype >= 2 ) dens = dens + dmat_b if ( use_relaxed ) then ! Default: S1 relaxed density = ROHF + td_p (orbital-relaxation correction) call tagarray_get_data ( infos % dat , OQP_TD_P , td_p ) dens = dens + td_p (:, 1 ) + td_p (:, 2 ) else ! ESPF_ROHF=1: stop at the ROHF reference density -- do NOT add td_abxc. ! This mirrors GAMESS, which always uses the ROHF density for ESPF fitting ! (not the response/relaxed density). continue end if ! Compute integrals and form ESP operators !   Compute the corrected mm potential mm_pot_av = sum ( mm_potential ) / nat do i = 1 , nat mm_potential ( i ) = mm_pot_av - mm_potential ( i ) end do !   Add integral gradient term, mm_potential*[(T&#94;+T)&#94;-1*T&#94;+]*V&#94;x do i = 1 , nptcur wt ( i ) =- dot_product ( ttt (:, i ), mm_potential ) call grad_elpot ( basis , xyz ( i ,:), wt ( i ), dens , espf_grad_ta ) end do !   Add overlap derivative correction for the total charge conservation if ( abs ( mm_pot_av ). gt . 1.0e-6 ) then dens =- mm_pot_av * dens call grad_ee_overlap ( basis , dens , espf_grad_ta , logtol ) dens =- dens / mm_pot_av end if !   Add weights gradient term, -mm_potential*[(T&#94;+T)&#94;-1*T&#94;+]*T&#94;xQ + q*mm_potential&#94;x if (. not . skip_legacy ) then call espf_grad (& x = xyz (: nptcur , 1 ),& y = xyz (: nptcur , 2 ),& z = xyz (: nptcur , 3 ),& at = infos % atoms % xyz ,& wt = wt ,& zn = infos % atoms % zn ,& pchg = partial_charges ,& grad = espf_grad_ta ) end if !    espf_grad = grad !   Add the ESPF weight-matrix (pseudoinverse) derivative term dZ/dR.  Here !   mm_potential currently holds (<phi> - phi_i), so the mean-removed potential !   a_i = phi_i - <phi> = -mm_potential. call espf_grad_weight ( basis , nat , nptcur , infos % atoms % xyz , xyz , & ttt , - mm_potential ( 1 : nat ), dens , espf_grad_ta , logtol , & ELEMENTS_VDW_RADII ( int ( infos % atoms % zn ))) !   Restablish mm potential to the original one do i = 1 , nat ! it seems not to be:  mm_potential(i)= - mm_pot_av-mm_potential(i) mm_potential ( i ) = mm_pot_av - mm_potential ( i ) end do end subroutine grad_esp_qmmm_excited !-------------------------------------------------------------------------------- !> @brief Add to the gradient the integral weight derivatives and classical MM contributions !> @param[in]      infos        OQP handle !> @param[in]      dens         density matrix !> @param[in,out]  grad         energy gradient !> @param[in]      logtol       tolerance threshold for integrals ! !> @detail This subroutine computes the analytic derivatives of the QM/MM interaction energy !>         corresponding to the integral weight derivatives and the classical MM contributions ! !> @author   Miquel Huix-Rotllant ! !     REVISION HISTORY: !> @date _Jul, 2024_ Initial release subroutine espf_grad ( x , y , z , at , wt , zn , pchg , grad ) use precision , only : dp implicit none real ( kind = dp ), intent ( in ) :: x (:), y (:), z (:), at (:,:), zn (:) real ( kind = dp ), intent ( inout ) :: grad (:,:) real ( kind = dp ), contiguous , intent ( in ) :: pchg (:) real ( kind = dp ), intent ( inout ) :: wt (:) !    real(kind=dp), target, allocatable :: gradient_mm(:,:) integer :: i , j , nat , npts , dim1 , dim2 nat = ubound ( at , 2 ) npts = ubound ( x , 1 ) ! Compute the matrix of the inverse distances do i = 1 , nat do j = 1 , npts grad ( 1 , i ) = grad ( 1 , i ) & + wt ( j ) * ( pchg ( i ) - zn ( i )) * ( at ( 1 , i ) - x ( j )) / norm2 ( at (:, i ) - [ x ( j ), y ( j ), z ( j )]) ** 3 grad ( 2 , i ) = grad ( 2 , i ) & + wt ( j ) * ( pchg ( i ) - zn ( i )) * ( at ( 2 , i ) - y ( j )) / norm2 ( at (:, i ) - [ x ( j ), y ( j ), z ( j )]) ** 3 grad ( 3 , i ) = grad ( 3 , i ) & + wt ( j ) * ( pchg ( i ) - zn ( i )) * ( at ( 3 , i ) - z ( j )) / norm2 ( at (:, i ) - [ x ( j ), y ( j ), z ( j )]) ** 3 end do end do end subroutine espf_grad !-------------------------------------------------------------------------------- !> @brief ESPF weight-matrix (pseudoinverse) derivative contribution to the !>        QM-atom gradient of the QM/MM electrostatic coupling energy. !> !> @detail The ESPF charges are q = Z u (electronic part), Z = (T&#94;T T)&#94;-1 T&#94;T, !>         T_{i,k} = 1/|R_i - g_k| (atom i, grid point k), u_k = Tr(P V_k&#94;AO) the !>         electronic ESP at grid point k.  The coupling energy contains !>         E = sum_i a_i sum_k Z_{i,k} u_k  with a_i = phi_i - <phi> (mean-removed !>         MM potential).  grad_elpot already differentiates u_k at fixed Z; this !>         routine adds the term from dZ/dR (the GAMESS DVESPF/INIDZ \"DTZ.V\" !>         contribution), with the atom-centred grid treated as fixed (matching !>         GAMESS).  Closed form (M = T&#94;T T, Minv = Z Z&#94;T): !>           b = Minv a,  g = Z u,  G = T&#94;T g,  B = T&#94;T b !>           dE/dR_{J,c} = sum_k dT(J,k,c) [ b_J (u_k - G_k) - g_J B_k ] !>           dT(J,k,c) = (g_k - R_J)_c / |g_k - R_J|&#94;3 !> !> @author  ported/derived from GAMESS espf.src (INIDZ/DVESPF), 2026-06 !> !> @detail  Smooth-switching mode (ESPF_SMOOTH=1): the grid carries smooth !>          weights s_k (espf_smooth_s) and Z = M&#94;-1 T diag(s), M = T diag(s) T&#94;T. !>          E = a&#94;T M&#94;-1 T diag(s) u, so dE/dR has, besides the dT term (now with !>          an s_k factor), an extra weight-derivative term: !>            dE/dR += sum_k ds_k/dR * B_k (u_k - G_k), !>          with ds_k/dR_{J} = [prod_{b/=J} S_b] S'_J (1/delta) (R_J-g_k)/|g_k-R_J|. subroutine espf_grad_weight ( basis , nat , nptcur , at , gxyz , zmat , amm , dens , grad , logtol , rvdw ) use precision , only : dp use basis_tools , only : basis_set use int1 , only : electrostatic_potential_unweighted use messages , only : show_message , with_abort implicit none type ( basis_set ), intent ( inout ) :: basis integer , intent ( in ) :: nat , nptcur real ( kind = dp ), intent ( in ) :: at (:,:) ! (3,nat) atom coords real ( kind = dp ), intent ( in ) :: gxyz (:,:) ! (npt,3) grid coords real ( kind = dp ), intent ( in ) :: zmat (:,:) ! (nat,npt) Z (weighted) real ( kind = dp ), intent ( in ) :: amm (:) ! (nat) mean-removed MM potential a_i real ( kind = dp ), intent ( inout ) :: dens (:) ! packed density for ESP real ( kind = dp ), intent ( inout ) :: grad (:,:) ! (3,nat) accumulated dE/dR real ( kind = dp ), intent ( in ) :: logtol real ( kind = dp ), intent ( in ) :: rvdw (:) ! (nat) base VDW radii real ( kind = dp ), allocatable :: gx (:), gy (:), gz (:), u (:) real ( kind = dp ), allocatable :: tmat (:,:), minv (:,:), bvec (:), gvec (:), & gbig (:), bbig (:), sk (:) integer , allocatable :: ipiv (:) real ( kind = dp ) :: dx , dy , dz , r2 , r3 , scal , fac , sw_delta , sw_scale , d , xx , & sp , sig , pe , coef , wk integer :: i , k , j , info character ( len = 32 ) :: envv integer :: status logical :: smooth ! runtime toggle / scale (default ON, scale 1.0); allows FD calibration ! without rebuilds:  ESPF_WDERIV=0 disables, ESPF_WSCALE=<f> rescales. call get_environment_variable ( 'ESPF_WDERIV' , envv , status = status ) if ( status == 0 ) then if ( trim ( envv ) == '0' . or . trim ( envv ) == 'off' ) return end if scal = 1.0_dp call get_environment_variable ( 'ESPF_WSCALE' , envv , status = status ) if ( status == 0 ) then if ( len_trim ( envv ) > 0 ) read ( envv , * ) scal end if smooth = . true . call get_environment_variable ( 'ESPF_SMOOTH' , envv , status = status ) if ( status == 0 ) then if ( trim ( envv ) == '0' . or . trim ( envv ) == 'off' ) smooth = . false . end if sw_delta = 0.7_dp call get_environment_variable ( 'ESPF_SWDELTA' , envv , status = status ) if ( status == 0 ) then if ( len_trim ( envv ) > 0 ) read ( envv , * ) sw_delta end if sw_scale = 1.8_dp call get_environment_variable ( 'ESPF_SWSCALE' , envv , status = status ) if ( status == 0 ) then if ( len_trim ( envv ) > 0 ) read ( envv , * ) sw_scale end if allocate ( gx ( nptcur ), gy ( nptcur ), gz ( nptcur ), u ( nptcur )) gx = gxyz ( 1 : nptcur , 1 ); gy = gxyz ( 1 : nptcur , 2 ); gz = gxyz ( 1 : nptcur , 3 ) ! u_k = Tr(P V_k&#94;AO): electronic ESP at the grid points (same kernel/sign as ! the omp_qmmm operator used to build the charges). call electrostatic_potential_unweighted ( basis , gx , gy , gz , dens , u , logtol ) ! T_{i,k} = 1/|R_i - g_k| allocate ( tmat ( nat , nptcur ), sk ( nptcur )) do k = 1 , nptcur do i = 1 , nat dx = at ( 1 , i ) - gx ( k ); dy = at ( 2 , i ) - gy ( k ); dz = at ( 3 , i ) - gz ( k ) tmat ( i , k ) = 1.0_dp / sqrt ( dx * dx + dy * dy + dz * dz ) end do end do if ( smooth ) then call espf_smooth_s ( gxyz (: nptcur ,:), nptcur , at , nat , sw_scale * rvdw , sw_delta , sk ) else sk = 1.0_dp end if allocate ( minv ( nat , nat ), bvec ( nat ), gvec ( nat ), gbig ( nptcur ), bbig ( nptcur )) ! b = M&#94;-1 a ;  g = Z u if ( smooth ) then ! M = T diag(s) T&#94;T ; solve M b = a do j = 1 , nat do i = 1 , nat minv ( i , j ) = sum ( sk ( 1 : nptcur ) * tmat ( i , 1 : nptcur ) * tmat ( j , 1 : nptcur )) end do end do bvec = amm allocate ( ipiv ( nat )) call dgesv ( nat , 1 , minv , nat , ipiv , bvec , nat , info ) if ( info /= 0 ) call show_message ( 'espf_grad_weight: dgesv failed' , WITH_ABORT ) deallocate ( ipiv ) else minv = matmul ( zmat ( 1 : nat , 1 : nptcur ), transpose ( zmat ( 1 : nat , 1 : nptcur ))) ! ZZ&#94;T=M&#94;-1 bvec = matmul ( minv , amm ) end if gvec = matmul ( zmat ( 1 : nat , 1 : nptcur ), u ) ! G_k = (T&#94;T g)_k ,  B_k = (T&#94;T b)_k gbig = matmul ( transpose ( tmat ), gvec ) bbig = matmul ( transpose ( tmat ), bvec ) ! dT term: dE/dR_{i,c} += scal * sum_k s_k dT(i,k,c) [ b_i(u_k-G_k) - g_i B_k ] do i = 1 , nat do k = 1 , nptcur dx = gx ( k ) - at ( 1 , i ); dy = gy ( k ) - at ( 2 , i ); dz = gz ( k ) - at ( 3 , i ) r2 = dx * dx + dy * dy + dz * dz r3 = r2 * sqrt ( r2 ) fac = scal * sk ( k ) * ( bvec ( i ) * ( u ( k ) - gbig ( k )) - gvec ( i ) * bbig ( k ) ) / r3 grad ( 1 , i ) = grad ( 1 , i ) + fac * dx grad ( 2 , i ) = grad ( 2 , i ) + fac * dy grad ( 3 , i ) = grad ( 3 , i ) + fac * dz end do end do ! ds term (smooth only): dE/dR_{J,c} += scal * sum_k ds_k/dR_{J,c} B_k(u_k-G_k) if ( smooth ) then do k = 1 , nptcur wk = bbig ( k ) * ( u ( k ) - gbig ( k )) ! B_k (u_k - G_k) if ( wk == 0.0_dp ) cycle do j = 1 , nat dx = gx ( k ) - at ( 1 , j ); dy = gy ( k ) - at ( 2 , j ); dz = gz ( k ) - at ( 3 , j ) d = sqrt ( dx * dx + dy * dy + dz * dz ) xx = ( d - sw_scale * rvdw ( j )) / sw_delta sp = espf_dsstep ( xx ) if ( sp == 0.0_dp ) cycle sig = espf_sstep ( xx ) ! in (0,1) where sp/=0 pe = sk ( k ) / sig ! prod_{b/=j} S_b ! ds_k/dR_{J,c} = pe * sp/delta * (R_J - g_k)_c/d  = pe*sp/delta*(-dx)/d coef = scal * wk * pe * sp / ( sw_delta * d ) grad ( 1 , j ) = grad ( 1 , j ) - coef * dx grad ( 2 , j ) = grad ( 2 , j ) - coef * dy grad ( 3 , j ) = grad ( 3 , j ) - coef * dz end do end do end if deallocate ( gx , gy , gz , u , tmat , sk , minv , bvec , gvec , gbig , bbig ) end subroutine espf_grad_weight !-------------------------------------------------------------------------------- !> @brief C1 smoothstep S(x): 0 for x<=0, 1 for x>=1, x&#94;2(3-2x) in between. elemental function espf_sstep ( x ) result ( s ) use precision , only : dp real ( kind = dp ), intent ( in ) :: x real ( kind = dp ) :: s if ( x <= 0.0_dp ) then s = 0.0_dp else if ( x >= 1.0_dp ) then s = 1.0_dp else s = x * x * ( 3.0_dp - 2.0_dp * x ) end if end function espf_sstep !> @brief S'(x) for the C1 smoothstep. elemental function espf_dsstep ( x ) result ( d ) use precision , only : dp real ( kind = dp ), intent ( in ) :: x real ( kind = dp ) :: d if ( x <= 0.0_dp . or . x >= 1.0_dp ) then d = 0.0_dp else d = 6.0_dp * x * ( 1.0_dp - x ) end if end function espf_dsstep !> @brief Smooth per-point grid weights s_k = prod_b S((|g_k-R_b|-Rvdw_b)/delta). !>        Zero inside any atom's VDW sphere, 1 outside, smooth in the shell of !>        width delta.  Makes the ESPF grid contribution a smooth function of !>        nuclear geometry (replaces the hard VDW pruning in add_atom_grid). subroutine espf_smooth_s ( xyz , np , at , nat , rvdw , delta , s ) use precision , only : dp real ( kind = dp ), intent ( in ) :: xyz (:,:) ! (npt,3) integer , intent ( in ) :: np , nat real ( kind = dp ), intent ( in ) :: at (:,:) ! (3,nat) real ( kind = dp ), intent ( in ) :: rvdw (:) ! (nat) real ( kind = dp ), intent ( in ) :: delta real ( kind = dp ), intent ( out ) :: s (:) ! (np) integer :: k , b real ( kind = dp ) :: d do k = 1 , np s ( k ) = 1.0_dp do b = 1 , nat d = norm2 ( xyz ( k ,:) - at (:, b )) s ( k ) = s ( k ) * espf_sstep (( d - rvdw ( b )) / delta ) if ( s ( k ) == 0.0_dp ) exit end do end do end subroutine espf_smooth_s !> @brief Weighted ESPF pseudoinverse Z = M&#94;-1 T diag(s), M = T diag(s) T&#94;T, !>        T_{i,k}=1/|R_i-g_k|.  Reduces to the unweighted fit when s=1. subroutine espf_weights_w ( x , y , z , ttt , at , s ) use precision , only : dp use messages , only : show_message , with_abort implicit none real ( kind = dp ), intent ( in ) :: x (:), y (:), z (:), at (:,:), s (:) real ( kind = dp ), intent ( inout ) :: ttt (:,:) ! (nat, npts) <- Z on output integer :: i , j , k , nat , npts , info real ( kind = dp ), allocatable :: tmat (:,:), mmat (:,:) integer , allocatable :: ipiv (:) nat = ubound ( at , 2 ) npts = ubound ( x , 1 ) allocate ( tmat ( nat , npts ), mmat ( nat , nat ), ipiv ( nat )) do k = 1 , npts do i = 1 , nat tmat ( i , k ) = 1.0_dp / norm2 ( at (:, i ) - [ x ( k ), y ( k ), z ( k )]) end do end do ! M = T diag(s) T&#94;T do j = 1 , nat do i = 1 , nat mmat ( i , j ) = sum ( s ( 1 : npts ) * tmat ( i , 1 : npts ) * tmat ( j , 1 : npts )) end do end do ! RHS = T diag(s) ; solve M Z = RHS  -> Z = M&#94;-1 T diag(s) do k = 1 , npts ttt ( 1 : nat , k ) = tmat ( 1 : nat , k ) * s ( k ) end do call dgesv ( nat , npts , mmat , nat , ipiv , ttt , size ( ttt , 1 ), info ) if ( info /= 0 ) call show_message ( 'espf_weights_w: dgesv failed' , WITH_ABORT ) deallocate ( tmat , mmat , ipiv ) end subroutine espf_weights_w !-------------------------------------------------------------------------------- !> @brief Computes the integral weights for computing the ESPF integrals !> @param[in]      x,y,z        Grid Cartesian coordinates !> @param[in,out]  ttt          Integral weights !> @param[in]      at           Atom Cartesian coordinates ! !> @detail Form the electrostatic kernel T(nat,npts) and forms the pseudoinverse !>         (T&#94;+T)&#94;-1*T&#94;+ (in which + = dagger) ! !> @author   Miquel Huix-Rotllant ! !     REVISION HISTORY: !> @date _Jul, 2024_ Initial release subroutine espf_weights ( x , y , z , ttt , at ) use io_constants , only : iw use precision , only : dp implicit none real ( kind = dp ), intent ( in ) :: x (:), y (:), z (:), at (:,:) real ( kind = dp ), intent ( inout ) :: ttt (:,:) integer :: i , j , nat , npts , lwork , info real ( kind = dp ), allocatable :: b (:,:), r (:,:) real ( kind = dp ), allocatable :: work (:) real ( kind = dp ) :: workk ( 1 ) nat = ubound ( at , 2 ) npts = ubound ( x , 1 ) allocate ( b ( npts , npts ), r ( nat , npts )) ! Compute the matrix of the inverse distances b = 0.0d0 do j = 1 , npts b ( j , j ) = 1.0d0 do i = 1 , nat r ( i , j ) = 1 / norm2 ( at (:, i ) - [ x ( j ), y ( j ), z ( j )]) end do end do ! Workspace query for optimal lwork size lwork = - 1 call dgels ( 'T' , nat , npts , npts , r , nat , b , npts , workk , lwork , info ) lwork = int ( workk ( 1 )) allocate ( work ( lwork )) ! Solve the least-squares problem T * X ≈ B call dgels ( 'T' , nat , npts , npts , r , nat , b , npts , work , lwork , info ) ttt (: nat ,: npts ) = b (: nat ,: npts ) end subroutine espf_weights !-------------------------------------------------------------------------------- !> @brief Adds atomic-centered spherical grid to form the molecular grid for ESP calculations !> @param[in]      nat          Number of QM centers !> @param[in]      npt          Maximum number of gridpoints !> @param[in]      nlayers      Number of layers for the grid !> @param[in]      layers       Radius for the different layers !> @param[in]      npt_layer    Number of points per layer !> @param[in]      typ_layer !> @param[in]      zn           atomic charges !> @param[in]      atoms_xyz    atomic coordinates !> @param[in,out]  xyz          grid coordinates !> @param[in,out]  ttt          grid weights !> @param[in,out]  nptcur       final number of grid points ! !> @detail Form the numerical grid for ESPF computations and construct the integral weights !>         This routine is adapted from oqp/modules/resp.F90 ! !> @author   Miquel Huix-Rotllant ! !     REVISION HISTORY: !> @date _Oct, 2024_ Initial release subroutine form_espf_grid ( nat , npt , nlayers , layers , npt_layer , typ_layer , zn , atoms_xyz , xyz , ttt , nptcur ) use precision , only : dp use lebedev , only : lebedev_get_grid use elements , only : ELEMENTS_VDW_RADII use physical_constants , only : ANGSTROM_TO_BOHR use messages , only : show_message , with_abort implicit none integer , intent ( in ) :: nat , npt , nlayers real ( kind = dp ), intent ( in ) :: zn ( nat ), atoms_xyz ( 3 , nat ), layers ( nlayers ) integer , intent ( in ) :: npt_layer ( nlayers ), typ_layer ( nlayers ) real ( kind = dp ), intent ( inout ) :: xyz ( npt , 3 ), ttt ( nat , npt ) integer , intent ( inout ) :: nptcur real ( kind = dp ), allocatable :: leb (:,:), lebw (:) real ( kind = dp ), allocatable :: vdwrad (:), excl_vdw (:), wt (:) integer , allocatable :: neigh (:) integer :: nadd , nleb , ok integer :: i , j , k , layer , iz logical :: keepall , smooth , gamess_mode character ( len = 16 ) :: env_k integer :: st_k real ( kind = dp ) :: sw_delta , sw_scale , rmax_i , vdwenv_i , prec1_bohr real ( kind = dp ), allocatable :: gamess_vdw (:) !> GAMESS ESPF VDW radii (Å, from LEBGRD in espf.src, Emsley 1991 + Bondi 1964). !> Zero entries fall back to OpenQP's ELEMENTS_VDW_RADII at runtime. real ( kind = dp ), parameter :: gamess_rvdw_ang ( 104 ) = [ & 1.20_dp , 1.22_dp , & ! H, He 0.00_dp , 0.00_dp , & ! Li, Be 2.08_dp , 1.85_dp , 1.54_dp , 1.50_dp , 1.35_dp , 1.60_dp , & ! B-Ne 2.31_dp , 0.00_dp , 2.05_dp , 2.00_dp , 1.90_dp , 1.85_dp , & ! Na-S 1.81_dp , 1.91_dp , & ! Cl, Ar 2.31_dp , & ! K 0.00_dp , 0.00_dp , 0.00_dp , 0.00_dp , 0.00_dp , 0.00_dp , 0.00_dp , & ! Ca-Fe 0.00_dp , 0.00_dp , 0.00_dp , 0.00_dp , 0.00_dp , 0.00_dp , & ! Co-Ge 2.00_dp , 2.00_dp , 1.95_dp , 1.98_dp , & ! As, Se, Br, Kr 2.44_dp , & ! Rb 0.00_dp , 0.00_dp , 0.00_dp , 0.00_dp , 0.00_dp , 0.00_dp , 0.00_dp , & ! Sr-Ru 0.00_dp , 0.00_dp , 0.00_dp , 0.00_dp , 0.00_dp , 0.00_dp , & ! Rh-Sn 2.20_dp , 2.20_dp , 2.15_dp , 0.00_dp , & ! Sb, Te, I, Xe 2.62_dp , & ! Cs 0.00_dp , 0.00_dp , 0.00_dp , 0.00_dp , 0.00_dp , 0.00_dp , 0.00_dp , & ! Ba-Nd 0.00_dp , 0.00_dp , 0.00_dp , 0.00_dp , 0.00_dp , 0.00_dp , 0.00_dp , & ! Pm-Yb 0.00_dp , 0.00_dp , 0.00_dp , 0.00_dp , 0.00_dp , 0.00_dp , 0.00_dp , & ! Lu-Re 0.00_dp , 0.00_dp , 0.00_dp , 0.00_dp , 0.00_dp , 0.00_dp , 0.00_dp , & ! Os-Pb 2.40_dp , 0.00_dp , 0.00_dp , 0.00_dp , & ! Bi, Po, At, Rn 0.00_dp , 0.00_dp , 0.00_dp , 0.00_dp , 0.00_dp , 0.00_dp , 0.00_dp , & ! Fr-Am 0.00_dp , 0.00_dp , 0.00_dp , 0.00_dp , 0.00_dp , 0.00_dp , 0.00_dp , & ! Cm-Rf 0.00_dp , 0.00_dp , 0.00_dp & ! Db, Sg, Bh (pad to 104) ] ! npt may be larger than npt_layer total when GAMESS mode adds 146/shell; ! use max(npt, nat*nlayers*146) in the caller, or just pad npt there. allocate ( leb ( max ( maxval ( npt_layer ), 146 ), 3 ), & lebw ( max ( maxval ( npt_layer ), 146 )), & vdwrad ( nat ), & excl_vdw ( nat ), & gamess_vdw ( nat ), & neigh ( nat ), & wt ( npt ), & stat = ok ) if ( ok /= 0 ) call show_message ( 'Cannot allocate memory' , WITH_ABORT ) !   Set up the grid nptcur = 0 ! Current number of point in a grid !   ESPF_KEEPALL=1 keeps every Lebedev point (fixed grid membership) instead of !   removing points that fall inside neighbour VDW spheres.  The hard removal is !   a step function of geometry: as atoms move, points blink in/out, making the !   ESPF energy non-smooth and leaking energy in dynamics.  Keeping all points !   makes the atom-centred grid translate smoothly with the nuclei. keepall = . false . call get_environment_variable ( 'ESPF_KEEPALL' , env_k , status = st_k ) if ( st_k == 0 ) then if ( trim ( env_k ) == '1' . or . trim ( env_k ) == 'on' ) keepall = . true . end if ! Smooth-switching weighted ESPF grid (DEFAULT): keep all points + smooth ! weights for energy-conserving dynamics.  ESPF_SMOOTH=0 restores the hard ! VDW-pruned grid (matches the original/GAMESS grid). smooth = . true . call get_environment_variable ( 'ESPF_SMOOTH' , env_k , status = st_k ) if ( st_k == 0 ) then if ( trim ( env_k ) == '0' . or . trim ( env_k ) == 'off' ) smooth = . false . end if sw_delta = 0.7_dp call get_environment_variable ( 'ESPF_SWDELTA' , env_k , status = st_k ) if ( st_k == 0 ) then if ( len_trim ( env_k ) > 0 ) read ( env_k , * ) sw_delta end if sw_scale = 1.8_dp call get_environment_variable ( 'ESPF_SWSCALE' , env_k , status = st_k ) if ( st_k == 0 ) then if ( len_trim ( env_k ) > 0 ) read ( env_k , * ) sw_scale end if if ( smooth ) keepall = . true . !   GAMESS-identical mode: ESPF_GAMESS=1 reproduces GAMESS LEBGRD exactly !   (RVDW table from Emsley 1991/Bondi 1964, NANG=146 Lebedev per shell, !    linear shell placement RINC=IS*(4r-r-0.1)/NRAD, fixed r+0.1 Å exclusion). gamess_mode = . false . call get_environment_variable ( 'ESPF_GAMESS' , env_k , status = st_k ) if ( st_k == 0 ) then if ( trim ( env_k ) == '1' . or . trim ( env_k ) == 'on' ) gamess_mode = . true . end if prec1_bohr = 0.1_dp * ANGSTROM_TO_BOHR ! GAMESS PREC1 = 0.1 Å ! Build GAMESS VDW radius array in bohr; fall back to OpenQP for unknown elements do i = 1 , nat iz = int ( zn ( i )) if ( iz >= 1 . and . iz <= size ( gamess_rvdw_ang ) . and . gamess_rvdw_ang ( iz ) > 0.0_dp ) then gamess_vdw ( i ) = gamess_rvdw_ang ( iz ) * ANGSTROM_TO_BOHR else gamess_vdw ( i ) = ELEMENTS_VDW_RADII ( iz ) end if end do ! GAMESS mode forces hard pruning (no smooth, no keepall) if ( gamess_mode ) then smooth = . false . keepall = . false . end if !   Fixed exclusion radii: scaled by the MINIMUM layer factor (layers(1) = 1.4) !   so the exclusion sphere is independent of the current layer being built. ! !   Why not base VDW (layer 1.0)? !     Too permissive: OpenQP shells sit at 1.4–2.0 × r_vdw, so base-VDW !     exclusion admits ~1400 extra near-atom intermediate-zone points that !     make the T matrix ill-conditioned and energy noisier. ! !   Why not layer-scaled exclusion (original)? !     The outer shells (1.8–2.0×) then sit right at their own exclusion !     boundary.  A C–H stretch of 0.1 Å flips the outer-shell point toward H !     from \"kept\" to \"excluded\" (margin ≈ 0.10 Å), creating discrete grid !     membership changes → non-smooth energy surface → drift. ! !   Why min-layer (1.4 × r_vdw)? !     • Same inner-shell points are excluded as before (inner shell exclusion !       is identical to the original 1.4-layer-scaled rule). !     • Outer shells (1.8–2.0×) now have a margin of ~0.5–0.8 Å before any !       point flips out; normal MD vibrational amplitudes (< 0.3 Å) are safe. !     • Intermediate-zone points (1.4–2.0 × r_vdw from neighbours) are admitted !       on outer shells but at physically reasonable positions (not near singularity). !   This is the correct fixed-scale complement to OpenQP's 1.4–2.0 shell scheme. if ( gamess_mode ) then excl_vdw = gamess_vdw + prec1_bohr ! GAMESS: r_vdw + 0.1 Å (fixed, Emsley radii) else excl_vdw = ELEMENTS_VDW_RADII ( int ( zn )) * layers ( 1 ) ! = 1.4 × r_vdw (innermost layer) end if !   Loop over layers and add spherical grid points on each atom to the molecular grid do layer = 1 , nlayers !     Get the atomic radii on which to place new grid layer if ( gamess_mode ) then ! GAMESS shell radius: IS*(RMAX-VDWEnv)/NRAD where RMAX=4*r_vdw, VDWEnv=r_vdw+0.1 Å ! => layer*(nlayers*gamess_vdw - gamess_vdw - prec1)/nlayers do i = 1 , nat vdwrad ( i ) = real ( layer , dp ) * ( real ( nlayers , dp ) * gamess_vdw ( i ) - gamess_vdw ( i ) - prec1_bohr ) & / real ( nlayers , dp ) end do else vdwrad = ELEMENTS_VDW_RADII ( int ( zn )) * layers ( layer ) end if !     Get grid if ( gamess_mode ) then nleb = 146 leb = 0 ; lebw = 0 call lebedev_get_grid ( nleb , leb , lebw , 0 ) ! type 0 = standard Lebedev, NANG=146 else nleb = npt_layer ( layer ) leb = 0 lebw = 0 call lebedev_get_grid ( nleb , leb , lebw , typ_layer ( layer )) end if !     Add new grid layer for each atom, remove inner points do i = 1 , nat ! GAMESS: atom IA is included in its own exclusion loop, so IS=1 shell ! (radius < r_vdw+0.1) is always fully self-excluded.  add_atom_grid skips ! self (cur_atom), so mimic GAMESS by skipping this layer when the shell ! radius is within the atom's own exclusion sphere. if ( gamess_mode . and . vdwrad ( i ) <= excl_vdw ( i )) then nadd = 0 nptcur = nptcur + nadd cycle end if if ( keepall ) then do j = 1 , nleb xyz ( nptcur + j , 1 ) = atoms_xyz ( 1 , i ) + vdwrad ( i ) * leb ( j , 1 ) xyz ( nptcur + j , 2 ) = atoms_xyz ( 2 , i ) + vdwrad ( i ) * leb ( j , 2 ) xyz ( nptcur + j , 3 ) = atoms_xyz ( 3 , i ) + vdwrad ( i ) * leb ( j , 3 ) wt ( nptcur + j ) = lebw ( j ) end do nadd = nleb else call add_atom_grid ( & x = xyz ( nptcur + 1 :, 1 ), & y = xyz ( nptcur + 1 :, 2 ), & z = xyz ( nptcur + 1 :, 3 ), & wts = wt ( nptcur + 1 :), & nadd = nadd , & atpts = leb (: nleb ,:), & atwts = lebw (: nleb ), & atoms_xyz = atoms_xyz , & atoms_rad = vdwrad , & cur_atom = i , & neighbours = neigh , & excl_rad = excl_vdw ) end if nptcur = nptcur + nadd end do end do !   Compute the weights if ( smooth ) then block real ( kind = dp ) :: rvdw ( nat ), s ( nptcur ) integer :: kk , nkeep ! Core radius = sw_scale*Rvdw: larger scale zeroes (and drops) more inner ! points, keeping the grid ~ as sparse as the hard prune for efficiency. rvdw = sw_scale * ELEMENTS_VDW_RADII ( int ( zn )) call espf_smooth_s ( xyz (: nptcur ,:), nptcur , atoms_xyz , nat , rvdw , sw_delta , s ) ! Compact out points with s_k == 0 (deep inside a neighbour VDW core): ! they contribute exactly 0 to both energy and gradient (S=0 and S'=0), ! so dropping them is discontinuity-free and recovers the keep-all cost. nkeep = 0 do kk = 1 , nptcur if ( s ( kk ) > 0.0_dp ) then nkeep = nkeep + 1 xyz ( nkeep ,:) = xyz ( kk ,:) s ( nkeep ) = s ( kk ) end if end do nptcur = nkeep call espf_weights_w ( xyz (: nptcur , 1 ), xyz (: nptcur , 2 ), xyz (: nptcur , 3 ), ttt , atoms_xyz , s (: nptcur )) end block else call espf_weights ( & x = xyz (: nptcur , 1 ), & y = xyz (: nptcur , 2 ), & z = xyz (: nptcur , 3 ), & ttt = ttt , & at = atoms_xyz ) end if ! one-shot grid-size report (ESPF_NPRINT=1) if ( st_k >= 0 ) then call get_environment_variable ( 'ESPF_NPRINT' , env_k , status = st_k ) if ( st_k == 0 . and . trim ( env_k ) == '1' ) then block integer :: ud open ( newunit = ud , file = '/tmp/espf_npts.txt' , position = 'append' , action = 'write' ) if ( gamess_mode ) then write ( ud , '(a,i7)' ) 'GAMESS nptcur=' , nptcur else if ( smooth ) then write ( ud , '(a,i7,a,f5.2,a,f5.2)' ) 'smooth nptcur=' , nptcur , & '  scale=' , sw_scale , '  delta=' , sw_delta else write ( ud , '(a,i7)' ) 'pruned nptcur=' , nptcur end if close ( ud ) end block end if end if end subroutine form_espf_grid !-------------------------------------------------------------------------------- !> @brief Print partial ESPF charges !> !> @param[in]      infos        OQP handle !> @param[in]      chg          atomic partial charges ! !> @author   Miquel Huix-Rotllant ! !> @detail This is a modified copy of print_charges of oqp/modules/resp.F90 ! !     REVISION HISTORY: !> @date _Oct, 2024_ Initial release subroutine print_charges ( infos , partial_charges , iw ) use precision , only : dp use oqp_tagarray_driver use elements , only : ELEMENTS_SHORT_NAME use types , only : information use messages , only : show_message , with_abort implicit none type ( information ), intent ( in ) :: infos real ( kind = dp ), intent ( in ), contiguous :: partial_charges (:) integer , intent ( in ) :: iw integer :: i , elem , nat nat = ubound ( infos % atoms % zn , 1 ) write ( iw , '(2/)' ) write ( iw , '(4x,a)' ) '==============================' write ( iw , '(4x,a)' ) 'ESPF QM/MM charges calculation' write ( iw , '(4x,a)' ) '==============================' write ( iw , '(/,30(\"&#94;\"))' ) write ( iw , '(/a8,a8,a14)' ) '#' , 'Name' , 'Charge' write ( iw , '(30(\"-\"))' ) do i = 1 , nat elem = nint ( infos % atoms % zn ( i )) write ( iw , '(i8,a8,f14.6)' ) i , ELEMENTS_SHORT_NAME ( elem ), partial_charges ( i ) end do write ( iw , '(30(\"=\"))' ) end subroutine print_charges end module qmmm_mod","tags":"","url":"sourcefile/qmmm.f90.html"},{"title":"bragg_slater.F90 – OpenQP Fortran API","text":"Source Code !> @brief Bragg-Slater radii for determining the relative size of the !>        polyhedra in the polyatomic integration scheme module bragg_slater_radii use precision , only : dp private public BRSL_NUM_ELEMENTS public BRSL_TYPE_GAMESS public BRSL_TYPE_GILL public BRSL_TYPE_TA public BRSL_TYPE_BECKE public set_bragg_slater integer , parameter :: BRSL_NUM_ELEMENTS = 137 integer , parameter :: BRSL_TYPE_GAMESS = 0 integer , parameter :: BRSL_TYPE_GILL = 1 integer , parameter :: BRSL_TYPE_TA = 2 integer , parameter :: BRSL_TYPE_BECKE = 3 ! J.C.Slater, Quantum Theory of Molecules and Solids, Volume 2, Chapter 3 ! Except that hydrogen is changed from 0.25 -> bohr radius, ! and missing values such as inert gasses are filled in with ! reasonable looking data (source unknown). Slater's table ! stops at the element americium, the extension is probably ! reasonable for actinides but not all the way to z=137! real ( kind = dp ), parameter :: brsl_values_gamess ( BRSL_NUM_ELEMENTS ) = [& 0.52917D+00 , 0.31D+00 , 1.45D+00 , 1.05D+00 , 0.85D+00 , & 0.70D+00 , 0.65D+00 , 0.60D+00 , 0.50D+00 , 0.38D+00 , 1.80D+00 , & 1.50D+00 , 1.25D+00 , 1.10D+00 , 1.00D+00 , 1.00D+00 , 1.00D+00 , & 0.71D+00 , 2.20D+00 , 1.80D+00 , 1.60D+00 , 1.40D+00 , 1.35D+00 , & 1.40D+00 , 1.40D+00 , 1.40D+00 , 1.35D+00 , 1.35D+00 , 1.35D+00 , & 1.35D+00 , 1.30D+00 , 1.25D+00 , 1.15D+00 , 1.15D+00 , 1.15D+00 , & 0.88D+00 , 2.35D+00 , 2.00D+00 , 1.80D+00 , 1.55D+00 , 1.45D+00 , & 1.45D+00 , 1.35D+00 , 1.30D+00 , 1.35D+00 , 1.40D+00 , 1.60D+00 , & 1.55D+00 , 1.55D+00 , 1.45D+00 , 1.45D+00 , 1.40D+00 , 1.40D+00 , & 1.08D+00 , 2.60D+00 , 2.15D+00 , 1.95D+00 , 1.85D+00 , 1.85D+00 , & 1.85D+00 , 1.85D+00 , 1.85D+00 , 1.85D+00 , 1.80D+00 , 1.75D+00 , & 1.75D+00 , 1.75D+00 , 1.75D+00 , 1.75D+00 , 1.75D+00 , 1.75D+00 , & 1.55D+00 , 1.45D+00 , 1.35D+00 , 1.35D+00 , 1.30D+00 , 1.35D+00 , & 1.35D+00 , 1.35D+00 , 1.50D+00 , 1.90D+00 , 1.80D+00 , 1.60D+00 , & 1.90D+00 , 1.27D+00 , 1.20D+00 , 2.60D+00 , 2.15D+00 , 1.95D+00 , & 1.80D+00 , 1.75D+00 , 1.75D+00 , 1.75D+00 , 1.75D+00 , 1.75d0 , & 1.75d0 , 1.75d0 , 1.75d0 , 1.75d0 , 1.75d0 , 1.75d0 , 1.75d0 , 1.75d0 , & 1.75d0 , 1.75d0 , 1.75d0 , 1.75d0 , 1.75d0 , 1.75d0 , 1.75d0 , 1.75d0 , & 1.75d0 , 1.75d0 , 1.75d0 , 1.75d0 , 1.75d0 , 1.75d0 , 1.75d0 , 1.75d0 , & 1.75d0 , 1.75d0 , 1.75d0 , 1.75d0 , 1.75d0 , 1.75d0 , 1.75d0 , 1.75d0 , & 1.75d0 , 1.75d0 , 1.75d0 , 1.75d0 , 1.75d0 , 1.75d0 , 1.75d0 , 1.75d0 , & 1.75d0 , 1.75d0 ] ! Gill et al., CPL,209, 506 (1993). real ( kind = dp ), parameter :: brsl_values_gill ( BRSL_NUM_ELEMENTS ) = [ & 0.52918D+00 , 0.31126D+00 , 1.62822D+00 , 1.08550D+00 , & 0.81414D+00 , 0.65131D+00 , 0.54272D+00 , 0.46520D+00 , & 0.40704D+00 , 0.36185D+00 , 2.16481D+00 , 1.67109D+00 , & 1.36073D+00 , 1.14763D+00 , 0.99221D+00 , 0.87388D+00 , & 0.78075D+00 , 0.70555D+00 , 2.20D+00 , 1.80D+00 , & 1.60D+00 , 1.40D+00 , 1.35D+00 , 1.40D+00 , 1.40D+00 , & 1.40D+00 , 1.35D+00 , 1.35D+00 , 1.35D+00 , 1.35D+00 , & 1.30D+00 , 1.25D+00 , 1.15D+00 , 1.15D+00 , 1.15D+00 , & 0.88D+00 , 2.35D+00 , 2.00D+00 , 1.80D+00 , 1.55D+00 , & 1.45D+00 , 1.45D+00 , 1.35D+00 , 1.30D+00 , 1.35D+00 , & 1.40D+00 , 1.60D+00 , 1.55D+00 , 1.55D+00 , 1.45D+00 , & 1.45D+00 , 1.40D+00 , 1.40D+00 , 1.08D+00 , 2.60D+00 , & 2.15D+00 , 1.95D+00 , 1.85D+00 , 1.85D+00 , 1.85D+00 , & 1.85D+00 , 1.85D+00 , 1.85D+00 , 1.80D+00 , 1.75D+00 , & 1.75D+00 , 1.75D+00 , 1.75D+00 , 1.75D+00 , 1.75D+00 , & 1.75D+00 , 1.55D+00 , 1.45D+00 , 1.35D+00 , 1.35D+00 , & 1.30D+00 , 1.35D+00 , 1.35D+00 , 1.35D+00 , 1.50D+00 , & 1.90D+00 , 1.80D+00 , 1.60D+00 , 1.90D+00 , 1.27D+00 , & 1.20D+00 , 2.60D+00 , 2.15D+00 , 1.95D+00 , 1.80D+00 , & 1.75D+00 , 1.75D+00 , 1.75D+00 , 1.75D+00 , 1.75D+00 , & 1.75D+00 , 1.75D+00 , 1.75D+00 , 1.75D+00 , 1.75D+00 , & 1.75D+00 , 1.75D+00 , 1.75D+00 , 1.75D+00 , 1.75D+00 , & 1.75D+00 , 1.75D+00 , 1.75D+00 , 1.75D+00 , 1.75D+00 , & 1.75D+00 , 1.75D+00 , 1.75D+00 , 1.75D+00 , 1.75D+00 , & 1.75D+00 , 1.75D+00 , 1.75D+00 , 1.75D+00 , 1.75D+00 , & 1.75D+00 , 1.75D+00 , 1.75D+00 , 1.75D+00 , 1.75D+00 , & 1.75D+00 , 1.75D+00 , 1.75D+00 , 1.75D+00 , 1.75D+00 , & 1.75D+00 , 1.75D+00 , 1.75D+00 , 1.75D+00 , 1.75D+00 , & 1.75D+00 , 1.75D+00 ] ! O.Treutler, R.Ahlrichs, JCP,102(1), 346 (1995). real ( kind = dp ), parameter :: brsl_values_treutler ( BRSL_NUM_ELEMENTS ) = [& 0.8D+00 , 0.9D+00 , & 1.8D+00 , 1.4D+00 , 1.3D+00 , 1.1D+00 , & 0.9D+00 , 0.9D+00 , 0.9D+00 , 0.9D+00 , & 1.4D+00 , 1.3D+00 , 1.3D+00 , 1.2D+00 , & 1.1D+00 , 1.0D+00 , 1.0D+00 , 1.0D+00 , & 1.5D+00 , 1.4D+00 , & 1.3D+00 , 1.2D+00 , 1.2D+00 , 1.2D+00 , 1.2D+00 , & 1.2D+00 , 1.2D+00 , 1.1D+00 , 1.1D+00 , 1.1D+00 , & 1.1D+00 , 1.0D+00 , 0.9D+00 , 0.9D+00 , 0.9D+00 , & 0.9D+00 , & 1.0D+00 , 1.0D+00 , 1.0D+00 , 1.0D+00 , 1.0D+00 , & 1.0D+00 , 1.0D+00 , 1.0D+00 , 1.0D+00 , 1.0D+00 , & 1.0D+00 , 1.0D+00 , 1.0D+00 , 1.0D+00 , 1.0D+00 , & 1.0D+00 , 1.0D+00 , 1.0D+00 , 1.0D+00 , 1.0D+00 , & 1.0D+00 , 1.0D+00 , 1.0D+00 , 1.0D+00 , 1.0D+00 , & 1.0D+00 , 1.0D+00 , 1.0D+00 , 1.0D+00 , 1.0D+00 , & 1.0D+00 , 1.0D+00 , 1.0D+00 , 1.0D+00 , 1.0D+00 , & 1.0D+00 , 1.0D+00 , 1.0D+00 , 1.0D+00 , 1.0D+00 , & 1.0D+00 , 1.0D+00 , 1.0D+00 , 1.0D+00 , 1.0D+00 , & 1.0D+00 , 1.0D+00 , 1.0D+00 , 1.0D+00 , 1.0D+00 , & 1.0D+00 , 1.0D+00 , 1.0D+00 , 1.0D+00 , 1.0D+00 , & 1.0D+00 , 1.0D+00 , 1.0D+00 , 1.0D+00 , 1.0D+00 , & 1.0D+00 , 1.0D+00 , 1.0D+00 , 1.0D+00 , 1.0D+00 , & 1.0D+00 , 1.0D+00 , 1.0D+00 , 1.0D+00 , 1.0D+00 , & 1.0D+00 , 1.0D+00 , 1.0D+00 , 1.0D+00 , 1.0D+00 , & 1.0D+00 , 1.0D+00 , 1.0D+00 , 1.0D+00 , 1.0D+00 , & 1.0D+00 , 1.0D+00 , 1.0D+00 , 1.0D+00 , 1.0D+00 , & 1.0D+00 , 1.0D+00 , 1.0D+00 , 1.0D+00 , 1.0D+00 , & 1.0D+00 , 1.0D+00 , 1.0D+00 , 1.0D+00 , 1.0D+00 , & 1.0D+00 , 1.0D+00 , 1.0D+00 , 1.0D+00 , 1.0D+00 , & 1.0D+00 ] ! J.C.Slater, JCP 41, 3199 (1964), with Becke's hydrogen value of 0.35 A ! (A.D.Becke, JCP 88, 2547 (1988)) and noble gases / super-heavy elements ! filled with the same conventional values used by the Becke-partition ! reference implementations (e.g. the libdft table behind PySCF's ! dft.radi.BRAGG_RADII).  This is the radii table that defines the ! Becke--Treutler \"atomic size adjustment\" of the reference ddCOSMO/ddPCM ! density-partition (solvent_pcm), NOT a radial-grid scaling table. real ( kind = dp ), parameter :: brsl_values_becke ( BRSL_NUM_ELEMENTS ) = [& 0.35D+00 , 1.40D+00 , 1.45D+00 , 1.05D+00 , 0.85D+00 , & 0.70D+00 , 0.65D+00 , 0.60D+00 , 0.50D+00 , 1.50D+00 , & 1.80D+00 , 1.50D+00 , 1.25D+00 , 1.10D+00 , 1.00D+00 , & 1.00D+00 , 1.00D+00 , 1.80D+00 , 2.20D+00 , 1.80D+00 , & 1.60D+00 , 1.40D+00 , 1.35D+00 , 1.40D+00 , 1.40D+00 , & 1.40D+00 , 1.35D+00 , 1.35D+00 , 1.35D+00 , 1.35D+00 , & 1.30D+00 , 1.25D+00 , 1.15D+00 , 1.15D+00 , 1.15D+00 , & 1.90D+00 , 2.35D+00 , 2.00D+00 , 1.80D+00 , 1.55D+00 , & 1.45D+00 , 1.45D+00 , 1.35D+00 , 1.30D+00 , 1.35D+00 , & 1.40D+00 , 1.60D+00 , 1.55D+00 , 1.55D+00 , 1.45D+00 , & 1.45D+00 , 1.40D+00 , 1.40D+00 , 2.10D+00 , 2.60D+00 , & 2.15D+00 , 1.95D+00 , 1.85D+00 , 1.85D+00 , 1.85D+00 , & 1.85D+00 , 1.85D+00 , 1.85D+00 , 1.80D+00 , 1.75D+00 , & 1.75D+00 , 1.75D+00 , 1.75D+00 , 1.75D+00 , 1.75D+00 , & 1.75D+00 , 1.55D+00 , 1.45D+00 , 1.35D+00 , 1.35D+00 , & 1.30D+00 , 1.35D+00 , 1.35D+00 , 1.35D+00 , 1.50D+00 , & 1.90D+00 , 1.80D+00 , 1.60D+00 , 1.90D+00 , 1.45D+00 , & 2.10D+00 , 1.80D+00 , 2.15D+00 , 1.95D+00 , 1.80D+00 , & 1.80D+00 , 1.75D+00 , 1.75D+00 , 1.75D+00 , 1.75D+00 , & 1.75D+00 , 1.75D+00 , 1.75D+00 , 1.75D+00 , 1.75D+00 , & 1.75D+00 , 1.75D+00 , 1.75D+00 , 1.75D+00 , 1.75D+00 , & 1.75D+00 , 1.75D+00 , 1.75D+00 , 1.75D+00 , 1.75D+00 , & 1.75D+00 , 1.75D+00 , 1.75D+00 , 1.75D+00 , 1.75D+00 , & 1.75D+00 , 1.75D+00 , 1.75D+00 , 1.75D+00 , 1.75D+00 , & 1.75D+00 , 1.75D+00 , 1.75D+00 , 1.75D+00 , 1.75D+00 , & 1.75D+00 , 1.75D+00 , 1.75D+00 , 1.75D+00 , 1.75D+00 , & 1.75D+00 , 1.75D+00 , 1.75D+00 , 1.75D+00 , 1.75D+00 , & 1.75D+00 , 1.75D+00 ] contains subroutine set_bragg_slater ( array , bstype ) real ( kind = dp ), intent ( out ) :: array (:) integer , intent ( in ) :: bstype select case ( bstype ) case ( BRSL_TYPE_GAMESS ) array = brsl_values_gamess case ( BRSL_TYPE_TA ) array = brsl_values_treutler case ( BRSL_TYPE_GILL ) array = brsl_values_gill case ( BRSL_TYPE_BECKE ) array = brsl_values_becke case default array = brsl_values_gill end select end subroutine end module","tags":"","url":"sourcefile/bragg_slater.f90.html"},{"title":"guess_json.F90 – OpenQP Fortran API","text":"Source Code !> @file guess_json_mod.f90 !> @brief Module to process stored SCF guess data in JSON format. !> !> This module provides routines to load the JSON formatted SCF guess, !> retrieve basis set and molecular orbital data, compute the initial !> density matrix for RHF or ROHF/UHF calculations, and broadcast the !> computed data in a parallel environment. module guess_json_mod implicit none character ( len =* ), parameter :: module_name = \"guess_json_mod\" contains !> @brief C binding for the guess_json routine. subroutine guess_json_C ( c_handle ) bind ( C , name = \"guess_json\" ) use c_interop , only : oqp_handle_t , oqp_handle_get_info use types , only : information type ( oqp_handle_t ) :: c_handle type ( information ), pointer :: inf inf => oqp_handle_get_info ( c_handle ) call guess_json ( inf ) end subroutine guess_json_C !> @brief Process SCF guess JSON data. !> !> This subroutine loads JSON data provided by Python via the tagarray interface. !> !> @param[in,out] infos Information object containing the basis set, atomic data, !>                        control parameters, and JSON tag arrays required for processing. subroutine guess_json ( infos ) use precision , only : dp use types , only : information use io_constants , only : IW use oqp_tagarray_driver use basis_tools , only : basis_set use guess , only : get_ab_initio_density use util , only : measure_time use messages , only : show_message , WITH_ABORT use printing , only : print_module_info use oqp_tagarray_driver use parallel , only : par_env_t implicit none character ( len =* ), parameter :: subroutine_name = \"guess_json\" type ( information ), target , intent ( inout ) :: infos integer :: i , nbf , nbf2 type ( basis_set ), pointer :: basis character ( len = :), allocatable :: basis_file logical :: err integer , parameter :: root = 0 type ( par_env_t ) :: pe ! tagarray real ( kind = dp ), contiguous , pointer :: & Smat (:), & dmat_a (:), mo_a (:,:), mo_energy_a (:), & dmat_b (:), mo_b (:,:), mo_energy_b (:) character ( len =* ), parameter :: tags_alpha ( 3 ) = ( / character ( len = 80 ) :: & OQP_DM_A , OQP_E_MO_A , OQP_VEC_MO_A / ) character ( len =* ), parameter :: tags_beta ( 3 ) = ( / character ( len = 80 ) :: & OQP_DM_B , OQP_E_MO_B , OQP_VEC_MO_B / ) character ( len =* ), parameter :: tags_general ( 1 ) = ( / character ( len = 80 ) :: & OQP_SM / ) ! Files open ! 1. XYZ: Read : Geometric data, ATOMS ! 3. LOG: Read Write: Main output file ! open ( unit = IW , file = infos % log_filename , position = \"append\" ) call print_module_info ( \"Loading JSON\" , \"Using stored SCF guess\" ) ! load basis set basis => infos % basis call pe % init ( infos % mpiinfo % comm , infos % mpiinfo % usempi ) basis % atoms => infos % atoms !  Allocate H, S ,T and D matrices nbf = basis % nbf nbf2 = nbf * ( nbf + 1 ) / 2 ! load general data call data_has_tags ( infos % dat , tags_general , module_name , subroutine_name , WITH_ABORT ) call tagarray_get_data ( infos % dat , OQP_SM , smat ) ! load alpha data call data_has_tags ( infos % dat , tags_alpha , module_name , subroutine_name , WITH_ABORT ) call tagarray_get_data ( infos % dat , OQP_DM_A , dmat_a ) call tagarray_get_data ( infos % dat , OQP_E_MO_A , mo_energy_a ) call tagarray_get_data ( infos % dat , OQP_VEC_MO_A , mo_a ) ! Load beta orbitals from the JSON guess. For ROHF/UHF (scftype >= 2) these ! are the supplied beta guess read by get_ab_initio_density below, so they ! must be retrieved, NOT reallocated (alloc_or_die would discard the guess). call data_has_tags ( infos % dat , tags_beta , module_name , subroutine_name , WITH_ABORT ) call tagarray_get_data ( infos % dat , OQP_DM_B , dmat_b ) call tagarray_get_data ( infos % dat , OQP_E_MO_B , mo_energy_b ) call tagarray_get_data ( infos % dat , OQP_VEC_MO_B , mo_b ) !  For ROHF/UHF if ( INFOS % control % scftype == 1 ) MO_B = MO_A ! Calculate Density Matrix if ( pe % rank == root ) then ! RHF if ( infos % control % scftype == 1 ) then call get_ab_initio_density ( Dmat_A , MO_A , infos = infos , basis = basis ) ! ROHF/UHF else call get_ab_initio_density ( Dmat_A , MO_A , Dmat_B , MO_B , infos , basis ) endif endif ! Broadcast MO and density matrices to all processes call pe % bcast ( MO_A , nbf * nbf ) if ( infos % control % scftype >= 2 ) then call pe % bcast ( MO_B , nbf * nbf ) endif ! Broadcast the density matrices to all processes if ( infos % control % scftype == 1 ) then call pe % bcast ( Dmat_A , nbf2 ) else call pe % bcast ( Dmat_A , nbf2 ) call pe % bcast ( Dmat_B , nbf2 ) endif call pe % barrier () write ( iw , '(/x,a,/)' ) '...... End of initial orbital guess ......' call measure_time ( print_total = 1 , log_unit = iw ) close ( iw ) end subroutine guess_json end module guess_json_mod","tags":"","url":"sourcefile/guess_json.f90.html"},{"title":"boys_lut.F90 – OpenQP Fortran API","text":"Source Code module boys_lut implicit none private integer , public , parameter :: ntx = 4 integer , public , parameter :: npf = 450 integer , public , parameter :: ngrd = 7 integer , public , parameter :: npx = 1000 integer , public , parameter :: mxqt = 16 integer , public , parameter :: ntx_al = 7 integer , public , parameter :: igrid ( 0 : 16 ) = [ & 0 , 1 , 2 , 3 , 4 , 5 , 5 , 5 , 5 , 6 , 6 , 6 , 6 , 7 , 7 , 7 , 7 ] integer , public , parameter :: irgrd ( 0 : 16 ) = [ & 0 , 1 , 2 , 3 , 4 , 8 , 8 , 8 , 8 , 12 , 12 , 12 , 12 , 16 , 16 , 16 , 16 ] real ( kind = 8 ), public , parameter :: fgrid ( 0 : ntx_al , 0 : npf , 0 : ngrd ) = reshape ([ & 0.1000000000000002D+01 , - 0.1944677204778938D-01 , 0.3403592489727661D-03 , & - 0.4727937670648743D-05 , 0.5363325491161102D-07 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.9999999996527571D+00 , & - 0.1944677004989777D-01 , 0.3403547806735521D-03 , - 0.4722981323166795D-05 , & 0.5113531272702215D-07 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.9999999860712950D+00 , - 0.1944673597639924D-01 , & 0.3403221068494966D-03 , - 0.4708752315218815D-05 , 0.4875754652287080D-07 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.9999998937930883D+00 , - 0.1944659164209455D-01 , 0.3402367859399692D-03 , & - 0.4686152979313101D-05 , 0.4649403900398180D-07 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.9999995636396291D+00 , & - 0.1944621861832296D-01 , 0.3400780863619526D-03 , - 0.4656018786134421D-05 , & 0.4433916935215916D-07 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.9999987123339004D+00 , - 0.1944546701468398D-01 , & 0.3398286154981241D-03 , - 0.4619122817398130D-05 , 0.4228759816883974D-07 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.9999969115536510D+00 , - 0.1944416313835158D-01 , 0.3394739798891309D-03 , & - 0.4576179954551890D-05 , 0.4033425319082611D-07 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.9999935749227216D+00 , & - 0.1944211614546375D-01 , 0.3390024742433137D-03 , - 0.4527850800838404D-05 , & 0.3847431573905210D-07 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.9999879516237495D+00 , - 0.1943912378879129D-01 , & 0.3384047970491306D-03 , - 0.4474745353173870D-05 , 0.3670320786242433D-07 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.9999791254779147D+00 , - 0.1943497735646099D-01 , 0.3376737907356166D-03 , & - 0.4417426439301450D-05 , 0.3501658014076362D-07 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.9999660184827301D+00 , & - 0.1942946588786292D-01 , 0.3368042044752042D-03 , - 0.4356412934742869D-05 , & 0.3341030011274566D-07 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.9999473979288140D+00 , - 0.1942237974494847D-01 , & 0.3357924778618716D-03 , - 0.4292182773191178D-05 , 0.3188044129651878D-07 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.9999218863325967D+00 , - 0.1941351360986777D-01 , 0.3346365438265601D-03 , & - 0.4225175763160092D-05 , 0.3042327277236056D-07 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.9998879735253112D+00 , & - 0.1940266897325069D-01 , 0.3333356492717871D-03 , - 0.4155796222927262D-05 , & 0.2903524929833186D-07 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.9998440303306402D+00 , - 0.1938965617135469D-01 , & 0.3318901920189594D-03 , - 0.4084415445077229D-05 , 0.2771300193139766D-07 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.9997883233451363D+00 , - 0.1937429602474198D-01 , 0.3303015727656529D-03 , & - 0.4011374001262219D-05 , 0.2645332912791963D-07 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.9997190304079954D+00 , & - 0.1935642112606568D-01 , 0.3285720608465874D-03 , - 0.3936983897152270D-05 , & 0.2525318829878136D-07 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.9996342564108887D+00 , - 0.1933587681990074D-01 , & 0.3267046726816851D-03 , - 0.3861530586938511D-05 , 0.2410968779569468D-07 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.9995320491551501D+00 , - 0.1931252191331723D-01 , 0.3247030618779327D-03 , & - 0.3785274856182071D-05 , 0.2302007930645549D-07 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.9994104150134649D+00 , & - 0.1928622915202556D-01 , 0.3225714200291889D-03 , - 0.3708454581264120D-05 , & 0.2198175063807233D-07 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.9992673341969633D+00 , - 0.1925688549339756D-01 , & 0.3203143873300004D-03 , - 0.3631286373187787D-05 , 0.2099221886778681D-07 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.9991007754669577D+00 , - 0.1922439220445497D-01 , 0.3179369721862906D-03 , & - 0.3553967113008360D-05 , 0.2004912384304238D-07 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.9989087101639971D+00 , & - 0.1918866480999251D-01 , 0.3154444790678112D-03 , - 0.3476675385722240D-05 , & 0.1915022201244167D-07 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.9986891254560050D+00 , - 0.1914963291334204D-01 , & 0.3128424439048281D-03 , - 0.3399572819026240D-05 , 0.1829338057066486D-07 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.9984400367324392D+00 , - 0.1910723990986669D-01 , 0.3101365763849579D-03 , & - 0.3322805332964963D-05 , 0.1747657190120479D-07 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.9981594990931386D+00 , & - 0.1906144261107771D-01 , 0.3073327085556652D-03 , - 0.3246504306114089D-05 , & 0.1669786830161196D-07 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.9978456178991164D+00 , - 0.1901221079527456D-01 , & 0.3044367491839333D-03 , - 0.3170787663599639D-05 , 0.1595543697673586D-07 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.9974965583684394D+00 , - 0.1895952669880262D-01 , 0.3014546433672911D-03 , & - 0.3095760891926709D-05 , 0.1524753528620155D-07 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.9971105542137483D+00 , & - 0.1890338446038784D-01 , 0.2983923369299439D-03 , - 0.3021517985284169D-05 , & 0.1457250623307268D-07 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.9966859153292502D+00 , - 0.1884378952952836D-01 , & 0.2952557451744257D-03 , - 0.2948142327703547D-05 , 0.1392877418132845D-07 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.9962210345443646D+00 , - 0.1878075804858658D-01 , 0.2920507255931806D-03 , & - 0.2875707515179372D-05 , 0.1331484079042179D-07 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.9957143934688942D+00 , & - 0.1871431621701939D-01 , 0.2887830541759645D-03 , - 0.2804278121603826D-05 , & 0.1272928115579348D-07 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.9951645674608040D+00 , - 0.1864449964509732D-01 , & 0.2854584049781245D-03 , - 0.2733910412129507D-05 , 0.1217074014479201D-07 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.9945702297525958D+00 , - 0.1857135270348505D-01 , 0.2820823326418100D-03 , & - 0.2664653007349614D-05 , 0.1163792891799455D-07 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.9939301547760740D+00 , & - 0.1849492787417709D-01 , 0.2786602575871677D-03 , - 0.2596547501473966D-05 , & 0.1112962162644126D-07 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.9932432207281043D+00 , - 0.1841528510749356D-01 , & 0.2751974536136955D-03 , - 0.2529629037481261D-05 , 0.1064465227578523D-07 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.9925084114219259D+00 , - 0.1833249118913465D-01 , 0.2716990376733245D-03 , & - 0.2463926842041980D-05 , 0.1018191174882492D-07 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.9917248174698379D+00 , & - 0.1824661912066134D-01 , 0.2681699615965772D-03 , - 0.2399464722831718D-05 , & 0.9740344978326347D-08 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.9908916368436587D+00 , - 0.1815774751620597D-01 , & 0.2646150055714381D-03 , - 0.2336261530690715D-05 , 0.9318948262459719D-08 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.9900081748594800D+00 , - 0.1806596001771547D-01 , 0.2610387731914635D-03 , & - 0.2274331588931423D-05 , 0.8916766715570861D-08 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.9890738436328269D+00 , & - 0.1797134473058424D-01 , 0.2574456879052667D-03 , - 0.2213685091951364D-05 , & 0.8532891847383198D-08 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.9880881610496302D+00 , - 0.1787399368113957D-01 , & 0.2538399907139203D-03 , - 0.2154328475172823D-05 , 0.8166459264081547D-08 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.9870507492973390D+00 , - 0.1777400229709398D-01 , 0.2502257389761151D-03 , & - 0.2096264758203582D-05 , 0.7816646485066291D-08 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.9859613329992050D+00 , & - 0.1767146891177249D-01 , 0.2466068061931845D-03 , - 0.2039493862993250D-05 , & 0.7482670869486196D-08 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.9848197369932644D+00 , - 0.1756649429265379D-01 , & 0.2429868826574078D-03 , - 0.1984012908647568D-05 , 0.7163787646961240D-08 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.9836258837958636D+00 , - 0.1745918119452959D-01 , 0.2393694768574389D-03 , & - 0.1929816484457730D-05 , 0.6859288047194246D-08 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.9823797907877978D+00 , & - 0.1734963393738222D-01 , 0.2357579175443032D-03 , - 0.1876896902602882D-05 , & 0.6568497523442586D-08 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.9810815671592429D+00 , - 0.1723795800890402D-01 , & 0.2321553563702518D-03 , - 0.1825244431891265D-05 , 0.6290774065079557D-08 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.9797314106477399D+00 , - 0.1712425969143048D-01 , 0.2285647710208972D-03 , & - 0.1774847513818375D-05 , 0.6025506594720097D-08 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.9783296041015124D+00 , & - 0.1700864571292954D-01 , 0.2249889687685383D-03 , - 0.1725692962138918D-05 , & 0.5772113445617653D-08 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.9768765118984188D+00 , - 0.1689122292158014D-01 , & 0.2214305903814637D-03 , - 0.1677766147072696D-05 , 0.5530040915259449D-08 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.9753725762488773D+00 , - 0.1677209798338129D-01 , 0.2178921143303369D-03 , & - 0.1631051165192740D-05 , 0.5298761891296091D-08 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.9738183134091374D+00 , & - 0.1665137710215781D-01 , 0.2143758612385761D-03 , - 0.1585530995976596D-05 , & 0.5077774546139653D-08 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.9722143098293601D+00 , - 0.1652916576126631D-01 , & 0.2108839985289514D-03 , - 0.1541187645938434D-05 , 0.4866601096752055D-08 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.9705612182591024D+00 , - 0.1640556848625748D-01 , 0.2074185452235179D-03 , & - 0.1498002281200447D-05 , 0.4664786626323795D-08 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.9688597538309758D+00 , & - 0.1628068862771175D-01 , 0.2039813768584568D-03 , - 0.1455955349306338D-05 , & 0.4471897964711879D-08 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.9671106901414926D+00 , - 0.1615462816343812D-01 , & 0.2005742304794997D-03 , - 0.1415026691027642D-05 , 0.4287522624666026D-08 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.9653148553464348D+00 , - 0.1602748751920665D-01 , 0.1971987096873482D-03 , & - 0.1375195642864746D-05 , 0.4111267791024150D-08 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.9634731282864434D+00 , & - 0.1589936540717307D-01 , 0.1938562897059222D-03 , - 0.1336441130898660D-05 , & 0.3942759360202110D-08 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.9615864346569969D+00 , - 0.1577035868114957D-01 , & 0.1905483224493923D-03 , - 0.1298741756606706D-05 , 0.3781641027439479D-08 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.9596557432354670D+00 , - 0.1564056220787580D-01 , 0.1872760415667986D-03 , & - 0.1262075875215003D-05 , 0.3627573419392540D-08 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.9576820621765482D+00 , & - 0.1551006875345060D-01 , 0.1840405674456532D-03 , - 0.1226421667122971D-05 , & 0.3480233269788722D-08 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.9556664353860485D+00 , - 0.1537896888409418D-01 , & 0.1808429121582861D-03 , - 0.1191757202899725D-05 , 0.3339312635973248D-08 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.9536099389817778D+00 , - 0.1524735088042487D-01 , 0.1776839843368350D-03 , & - 0.1158060502319143D-05 , 0.3204518154289304D-08 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.9515136778491130D+00 , & - 0.1511530066445054D-01 , 0.1745645939647366D-03 , - 0.1125309587869388D-05 , & 0.3075570332337980D-08 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.9493787822977381D+00 , - 0.1498290173849457D-01 , & 0.1714854570743336D-03 , - 0.1093482533143616D-05 , 0.2952202876263670D-08 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.9472064048250187D+00 , - 0.1485023513529732D-01 , 0.1684472003418196D-03 , & - 0.1062557506491427D-05 , 0.2834162051305045D-08 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.9449977169905580D+00 , & - 0.1471737937855727D-01 , 0.1654503655721814D-03 , - 0.1032512810285108D-05 , & 0.2721206073941164D-08 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.9427539064055761D+00 , - 0.1458441045320037D-01 , & 0.1624954140681072D-03 , - 0.1003326916130938D-05 , 0.2613104534047270D-08 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.9404761738399605D+00 , - 0.1445140178469153D-01 , 0.1595827308780018D-03 , & - 0.9749784963334251D-06 , 0.2509637845555362D-08 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.9381657304490917D+00 , & - 0.1431842422672858D-01 , 0.1567126289193029D-03 , - 0.9474464518995232D-06 , & 0.2410596724191022D-08 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.9358237951218568D+00 , - 0.1418554605668551D-01 , & 0.1538853529742428D-03 , - 0.9207099373502759D-06 , 0.2315781690930528D-08 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.9334515919506424D+00 , - 0.1405283297819898D-01 , 0.1511010835560419D-03 , & - 0.8947483825890619D-06 , 0.2225002599891049D-08 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.9310503478235267D+00 , & - 0.1392034813031899D-01 , 0.1483599406442777D-03 , - 0.8695415120584873D-06 , & 0.2138078189431960D-08 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.9286212901383762D+00 , - 0.1378815210267188D-01 , & 0.1456619872888435D-03 , - 0.8450693614019661D-06 , 0.2054835655307256D-08 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.9261656446380863D+00 , - 0.1365630295611035D-01 , 0.1430072330825063D-03 , & - 0.8213122918310468D-06 , 0.1975110244767769D-08 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.9236846333657805D+00 , & - 0.1352485624835188D-01 , 0.1403956375025966D-03 , - 0.7982510023855365D-06 , & 0.1898744870567642D-08 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.9211794727384145D+00 , - 0.1339386506413291D-01 , & 0.1378271131228292D-03 , - 0.7758665402603991D-06 , 0.1825589743882390D-08 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.9186513717368949D+00 , - 0.1326338004943158D-01 , 0.1353015286966516D-03 , & - 0.7541403093611310D-06 , 0.1755502025196062D-08 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.9161015302105294D+00 , & - 0.1313344944933683D-01 , 0.1328187121138736D-03 , - 0.7330540772379173D-06 , & 0.1688345492262629D-08 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.9135311372933683D+00 , - 0.1300411914916585D-01 , & 0.1303784532326310D-03 , - 0.7125899805381476D-06 , 0.1623990224291917D-08 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.9109413699297774D+00 , - 0.1287543271845557D-01 , 0.1279805065889993D-03 , & - 0.6927305291069140D-06 , 0.1562312301553279D-08 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.9083333915063845D+00 , & - 0.1274743145747633D-01 , 0.1256245939867921D-03 , - 0.6734586088557627D-06 , & 0.1503193519630858D-08 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.9057083505873877D+00 , - 0.1262015444593824D-01 , & 0.1233104069702640D-03 , - 0.6547574835112774D-06 , 0.1446521117602966D-08 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.9030673797500761D+00 , - 0.1249363859358179D-01 , 0.1210376091825929D-03 , & - 0.6366107953469309D-06 , 0.1392187519454671D-08 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.9004115945173037D+00 , & - 0.1236791869236470D-01 , 0.1188058386131384D-03 , - 0.6190025649940595D-06 , & 0.1340090088067545D-08 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.8977420923835762D+00 , - 0.1224302746997648D-01 , & 0.1166147097365716D-03 , - 0.6019171904207178D-06 , 0.1290130891163437D-08 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.8950599519313385D+00 , - 0.1211899564443110D-01 , 0.1144638155470472D-03 , & - 0.5853394451605798D-06 , 0.1242216478610557D-08 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.8923662320340151D+00 , & - 0.1199585197950599D-01 , 0.1123527294906422D-03 , - 0.5692544758678764D-06 , & 0.1196257670529809D-08 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.8896619711423203D+00 , - 0.1187362334081259D-01 , & 0.1102810072993184D-03 , - 0.5536477992686147D-06 , 0.1152169355667576D-08 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.8869481866503494D+00 , - 0.1175233475230033D-01 , 0.1082481887296883D-03 , & - 0.5385052985729689D-06 , 0.1109870299527928D-08 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.8842258743379632D+00 , & - 0.1163200945301087D-01 , 0.1062537992098635D-03 , - 0.5238132194087371D-06 , & 0.1069282961782655D-08 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.8814960078859957D+00 , - 0.1151266895391476D-01 , & 0.1042973513976568D-03 , - 0.5095581653311053D-06 , 0.1030333322501656D-08 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.8787595384608444D+00 , - 0.1139433309467617D-01 , 0.1023783466533885D-03 , & - 0.4957270929596295D-06 , 0.9929507167691219D-09 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.8760173943650386D+00 , & - 0.1127702010020473D-01 , 0.1004962764305163D-03 , - 0.4823073067893084D-06 , & 0.9570676772727134D-09 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.8732704807504343D+00 , - 0.1116074663686625D-01 , & 0.9865062358726609D-04 , - 0.4692864537188718D-06 , 0.9226197844735592D-09 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.8705196793907378D+00 , - 0.1104552786823527D-01 , 0.9684086362239503D-04 , & - 0.4566525173359017D-06 , 0.8895455239845084D-09 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.8677658485101256D+00 , & - 0.1093137751028433D-01 , 0.9506646583816447D-04 , - 0.4443938119951714D-06 , & 0.8577861508026856D-09 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.8650098226647943D+00 , - 0.1081830788591453D-01 , & 0.9332689443353832D-04 , - 0.4324989767235511D-06 , 0.8272855600600535D-09 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.8622524126743607D+00 , - 0.1070632997874233D-01 , 0.9162160953055962D-04 , & - 0.4209569689820296D-06 , 0.7979901639724585D-09 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.8594944056000978D+00 , & - 0.1059545348606645D-01 , 0.8995006813678818D-04 , - 0.4097570583127849D-06 , & 0.7698487746835640D-09 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.8567365647670886D+00 , - 0.1048568687094764D-01 , & 0.8831172504661170D-04 , - 0.3988888198968268D-06 , 0.7428124927152055D-09 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.8539796298274621D+00 , - 0.1037703741334181D-01 , 0.8670603368416672D-04 , & - 0.3883421280454687D-06 , 0.7168346007500342D-09 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.8512243168619634D+00 , & - 0.1026951126023496D-01 , 0.8513244689053065D-04 , - 0.3781071496468146D-06 , & 0.6918704624859737D-09 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.8484713185172054D+00 , - 0.1016311347473513D-01 , & 0.8359041765776763D-04 , - 0.3681743375865053D-06 , 0.6678774263149447D-09 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.8457213041760433D+00 , - 0.1005784808408317D-01 , 0.8207939981233208D-04 , & - 0.3585344241601771D-06 , 0.6448147335906154D-09 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.8429749201585982D+00 , & - 0.9953718126550376D-02 , 0.8059884865025398D-04 , - 0.3491784144934229D-06 , & 0.6226434312615917D-09 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.8402327899515637D+00 , - 0.9850725697196477D-02 , & 0.7914822152645126D-04 , - 0.3400975799835129D-06 , 0.6013262886575761D-09 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.8374955144635144D+00 , - 0.9748871992466860D-02 , 0.7772697840043312D-04 , & - 0.3312834517757073D-06 , 0.5808277182265251D-09 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.8347636723040300D+00 , & - 0.9648157353612673D-02 , 0.7633458234058101D-04 , - 0.3227278142856759D-06 , & 0.5611137000308514D-09 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.8320378200845442D+00 , - 0.9548581308921842D-02 , & 0.7497049998911282D-04 , - 0.3144226987783255D-06 , 0.5421517098202031D-09 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.8293184927389251D+00 , - 0.9450142614753363D-02 , 0.7363420198976109D-04 , & - 0.3063603770122207D-06 , 0.5239106505073903D-09 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.8266062038618714D+00 , & - 0.9352839295370664D-02 , 0.7232516338011614D-04 , - 0.2985333549577350D-06 , & 0.5063607868825725D-09 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.8239014460633117D+00 , - 0.9256668681573609D-02 , & 0.7104286395051142D-04 , - 0.2909343665961269D-06 , 0.4894736834089784D-09 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.8212046913370774D+00 , - 0.9161627448131610D-02 , 0.6978678857125417D-04 , & - 0.2835563678058498D-06 , 0.4732221449511517D-09 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.8185163914422074D+00 , & - 0.9067711650023335D-02 , 0.6855642748993120D-04 , - 0.2763925303416013D-06 , & 0.4575801602940647D-09 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.8158369782953203D+00 , - 0.8974916757491021D-02 , & 0.6735127660044789D-04 , - 0.2694362359108631D-06 , 0.4425228483184053D-09 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.8131668643725884D+00 , - 0.8883237689919780D-02 , 0.6617083768539143D-04 , & - 0.2626810703520142D-06 , 0.4280264067039897D-09 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.8105064431199093D+00 , & - 0.8792668848554418D-02 , 0.6501461863323886D-04 , - 0.2561208179174616D-06 , & 0.4140680630395304D-09 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.8078560893699649D+00 , - 0.8703204148068149D-02 , & 0.6388213363186680D-04 , - 0.2497494556646629D-06 , 0.4006260282229825D-09 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.8052161597649180D+00 , - 0.8614837046999262D-02 , 0.6277290333975363D-04 , & - 0.2435611479573893D-06 , 0.3876794520423645D-09 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.8025869931835902D+00 , & - 0.8527560577073476D-02 , 0.6168645503620611D-04 , - 0.2375502410791013D-06 , & 0.3752083808323656D-09 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.7999689111720156D+00 , - 0.8441367371430716D-02 , & 0.6062232275187741D-04 , - 0.2317112579598595D-06 , 0.3631937171071563D-09 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.7973622183763424D+00 , - 0.8356249691776556D-02 , 0.5958004738078972D-04 , & - 0.2260388930178089D-06 , 0.3516171810747218D-09 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.7947672029771254D+00 , & - 0.8272199454479334D-02 , 0.5855917677501536D-04 , - 0.2205280071158990D-06 , & 0.3404612739426481D-09 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.7921841371241085D+00 , - 0.8189208255634878D-02 , & 0.5755926582311661D-04 , - 0.2151736226341800D-06 , 0.3297092429297057D-09 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.7896132773706594D+00 , - 0.8107267395121655D-02 , 0.5657987651339262D-04 , & - 0.2099709186577157D-06 , 0.3193450479017568D-09 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.7870548651070775D+00 , & - 0.8026367899669366D-02 , 0.5562057798292836D-04 , - 0.2049152262798764D-06 , & 0.3093533295544734D-09 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.7845091269920572D+00 , - 0.7946500544965054D-02 , & 0.5468094655339572D-04 , - 0.2000020240205464D-06 , 0.2997193790691591D-09 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.7819762753816359D+00 , - 0.7867655876820680D-02 , 0.5376056575450559D-04 , & - 0.1952269333585471D-06 , 0.2904291091715317D-09 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.7794565087550087D+00 , & - 0.7789824231426719D-02 , 0.5285902633596741D-04 , - 0.1905857143773908D-06 , & 0.2814690265267500D-09 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.7769500121366469D+00 , - 0.7712995754716323D-02 , & 0.5197592626876685D-04 , - 0.1860742615232961D-06 , 0.2728262054072054D-09 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.7744569575142018D+00 , - 0.7637160420865027D-02 , 0.5111087073653329D-04 , & - 0.1816885994742573D-06 , 0.2644882625726983D-09 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.7719775042517091D+00 , & - 0.7562308049950523D-02 , 0.5026347211772476D-04 , - 0.1774248791187962D-06 , & 0.2564433333055185D-09 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.7695117994976737D+00 , - 0.7488428324797536D-02 , & 0.4943334995932309D-04 , - 0.1732793736429303D-06 , 0.2486800485457694D-09 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.7670599785876372D+00 , - 0.7415510807032386D-02 , 0.4862013094269281D-04 , & - 0.1692484747237658D-06 , 0.2411875130749006D-09 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.7646221654408750D+00 , & - 0.7343544952371875D-02 , 0.4782344884222357D-04 , - 0.1653286888280456D-06 , & 0.2339552846979458D-09 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.7621984729509049D+00 , - 0.7272520125170718D-02 , & 0.4704294447733948D-04 , - 0.1615166336138875D-06 , 0.2269733543773389D-09 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.7597890033695281D+00 , - 0.7202425612251903D-02 , 0.4627826565843021D-04 , & - 0.1578090344338997D-06 , 0.2202321272734824D-09 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.7573938486841529D+00 , & - 0.7133250636043597D-02 , 0.4552906712722411D-04 , - 0.1542027209377858D-06 , & 0.2137224046493815D-09 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.7550130909881775D+00 , - 0.7064984367046280D-02 , & 0.4479501049209606D-04 , - 0.1506946237725160D-06 , 0.2074353665987290D-09 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.7526468028442463D+00 , - 0.6997615935653294D-02 , 0.4407576415877417D-04 , & - 0.1472817713780988D-06 , 0.2013625555587791D-09 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.7502950476402134D+00 , & - 0.6931134443347465D-02 , 0.4337100325688132D-04 , - 0.1439612868769548D-06 , & 0.1954958605712004D-09 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.7479578799376851D+00 , - 0.6865528973296573D-02 , & 0.4268040956272529D-04 , - 0.1407303850548856D-06 , 0.1898275022558907D-09 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.7456353458130132D+00 , - 0.6800788600369215D-02 , 0.4200367141872124D-04 , & - 0.1375863694315929D-06 , 0.1843500184643829D-09 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.7433274831906629D+00 , & - 0.6736902400593002D-02 , 0.4134048364981240D-04 , - 0.1345266294187155D-06 , & 0.1790562505811041D-09 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.7410343221688767D+00 , - 0.6673859460075909D-02 , & 0.4069054747722914D-04 , - 0.1315486375633347D-06 , 0.1739393304422518D-09 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.7387558853375956D+00 , - 0.6611648883411682D-02 , 0.4005357042990773D-04 , & - 0.1286499468749100D-06 , 0.1689926678435111D-09 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.7364921880885874D+00 , & - 0.6550259801589093D-02 , 0.3942926625386694D-04 , - 0.1258281882335984D-06 , & 0.1642099386091943D-09 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.7342432389177910D+00 , - 0.6489681379425075D-02 , & 0.3881735481982588D-04 , - 0.1230810678779416D-06 , 0.1595850731967205D-09 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.7320090397198605D+00 , - 0.6429902822540631D-02 , 0.3821756202932434D-04 , & - 0.1204063649699006D-06 , 0.1551122458115744D-09 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.7297895860749349D+00 , & - 0.6370913383898308D-02 , 0.3762961971959200D-04 , - 0.1178019292352447D-06 , & 0.1507858640090796D-09 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.7275848675276594D+00 , - 0.6312702369919355D-02 , & 0.3705326556739559D-04 , - 0.1152656786773217D-06 , 0.1466005587604490D-09 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.7253948678585005D+00 , - 0.6255259146198140D-02 , 0.3648824299207734D-04 , & - 0.1127955973622496D-06 , 0.1425511749616372D-09 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.7232195653474158D+00 , & - 0.6198573142831216D-02 , 0.3593430105798593D-04 , - 0.1103897332736163D-06 , & 0.1386327623645627D-09 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.7210589330299302D+00 , - 0.6142633859377334D-02 , & 0.3539119437648194D-04 , - 0.1080461962347722D-06 , 0.1348405669112042D-09 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.7189129389457056D+00 , - 0.6087430869464842D-02 , 0.3485868300769278D-04 , & - 0.1057631558968555D-06 , 0.1311700224520312D-09 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.7167815463796769D+00 , & - 0.6032953825061891D-02 , 0.3433653236217467D-04 , - 0.1035388397907053D-06 , & 0.1276167428310877D-09 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.7146647140958577D+00 , - 0.5979192460424870D-02 , & 0.3382451310263157D-04 , - 0.1013715314408590D-06 , 0.1241765143208971D-09 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.7125623965638924D+00 , - 0.5926136595739311D-02 , 0.3332240104582456D-04 , & - 0.9925956853984872D-07 , 0.1208452883911325D-09 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.7104745441784862D+00 , & - 0.5873776140467944D-02 , 0.3282997706480147D-04 , - 0.9720134118106816D-07 , & 0.1176191747957831D-09 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.7084011034718025D+00 , - 0.5822101096419196D-02 , & 0.3234702699156021D-04 , - 0.9519529014849411D-07 , 0.1144944349642404D-09 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.7063420173189513D+00 , - 0.5771101560549628D-02 , 0.3187334152025391D-04 , & - 0.9323990526159441D-07 , 0.1114674756824290D-09 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.7042972251366897D+00 , & - 0.5720767727512979D-02 , 0.3140871611103569D-04 , - 0.9133372377378726D-07 , & 0.1085348430507577D-09 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.7022666630754506D+00 , - 0.5671089891968062D-02 , & 0.3095295089463151D-04 , - 0.8947532882284716D-07 , 0.1056932167062776D-09 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.7002502642048426D+00 , - 0.5622058450657730D-02 , 0.3050585057772578D-04 , & - 0.8766334793170560D-07 , 0.1029394042970514D-09 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.6982479586927319D+00 , & - 0.5573663904269929D-02 , 0.3006722434923066D-04 , - 0.8589645155810512D-07 , & 0.1002703361972637D-09 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.6962596739780513D+00 , - 0.5525896859092168D-02 , & 0.2963688578750887D-04 , - 0.8417335169162641D-07 , 0.9768306045217063D-10 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.6942853349374678D+00 , - 0.5478748028469892D-02 , 0.2921465276860987D-04 , & - 0.8249280049662939D-07 , 0.9517473794248170D-10 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.6923248640460486D+00 , & - 0.5432208234079149D-02 , 0.2880034737557568D-04 , - 0.8085358899969518D-07 , & 0.9274263775825931D-10 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.6903781815320488D+00 , - 0.5386268407022976D-02 , & 0.2839379580886240D-04 , - 0.7925454582017677D-07 , 0.9038413277287010D-10 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.6884452055259797D+00 , - 0.5340919588761438D-02 , 0.2799482829792485D-04 , & - 0.7769453594252436D-07 , 0.8809669540798818D-10 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.6865258522040796D+00 , & - 0.5296152931884023D-02 , 0.2760327901400022D-04 , - 0.7617245952906562D-07 , & 0.8587789358104438D-10 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.6846200359263350D+00 , - 0.5251959700733225D-02 , & 0.2721898598412585D-04 , - 0.7468725077196736D-07 , 0.8372538682692919D-10 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.6827276693691869D+00 , - 0.5208331271887681D-02 , 0.2684179100642044D-04 , & - 0.7323787678313810D-07 , 0.8163692258613521D-10 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.6808486636530563D+00 , & - 0.5165259134512672D-02 , 0.2647153956665281D-04 , - 0.7182333652085809D-07 , & 0.7961033265187874D-10 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.6789829284648440D+00 , - 0.5122734890586081D-02 , & 0.2610808075612294D-04 , - 0.7044265975197470D-07 , 0.7764352976910801D-10 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.6771303721755174D+00 , - 0.5080750255006635D-02 , 0.2575126719086914D-04 , & - 0.6909490604850725D-07 , 0.7573450437859936D-10 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.6752909019529387D+00 , & - 0.5039297055591808D-02 , 0.2540095493221846D-04 , - 0.6777916381756260D-07 , & 0.7388132149968788D-10 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.6734644238700584D+00 , - 0.4998367232971989D-02 , & 0.2505700340869103D-04 , - 0.6649454936348043D-07 , 0.7208211774545915D-10 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.6716508430086191D+00 , - 0.4957952840387499D-02 , 0.2471927533926769D-04 , & - 0.6524020598116682D-07 , 0.7033509846452315D-10 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.6698500635584830D+00 , & - 0.4918046043394237D-02 , 0.2438763665802419D-04 , - 0.6401530307959134D-07 , & 0.6863853500374420D-10 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.6680619889127315D+00 , - 0.4878639119484328D-02 , & 0.2406195644013888D-04 , - 0.6281903533447512D-07 , 0.6699076208658755D-10 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.6662865217586572D+00 , - 0.4839724457627027D-02 , 0.2374210682927224D-04 , & - 0.6165062186920536D-07 , 0.6539017530196077D-10 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.6645235641647721D+00 , & - 0.4801294557735379D-02 , 0.2342796296631831D-04 , - 0.6050930546305232D-07 , & 0.6383522869867809D-10 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.6627730176639622D+00 , - 0.4763342030063747D-02 , & 0.2311940291952495D-04 , - 0.5939435178579058D-07 , 0.6232443248089538D-10 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.6610347833329003D+00 , - 0.4725859594540896D-02 , 0.2281630761597654D-04 , & - 0.5830504865784787D-07 , 0.6085635080006882D-10 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.6593087618678600D+00 , & - 0.4688840080043744D-02 , 0.2251856077443633D-04 , - 0.5724070533514863D-07 , & 0.5942959963921419D-10 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.6575948536570159D+00 , - 0.4652276423615593D-02 , & 0.2222604883953563D-04 , - 0.5620065181781854D-07 , 0.5804284478540307D-10 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.6558929588493740D+00 , - 0.4616161669633488D-02 , 0.2193866091730383D-04 , & - 0.5518423818196779D-07 , 0.5669479988664857D-10 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.6542029774204303D+00 , & - 0.4580488968928551D-02 , 0.2165628871202716D-04 , - 0.5419083393378048D-07 , & 0.5538422458948973D-10 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.6525248092346698D+00 , - 0.4545251577863047D-02 , & 0.2137882646442419D-04 , - 0.5321982738516550D-07 , 0.5410992275375588D-10 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.6508583541050303D+00 , - 0.4510442857368114D-02 , 0.2110617089112717D-04 , & - 0.5227062505025468D-07 , 0.5287074074115917D-10 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.6492035118493996D+00 , & - 0.4476056271944904D-02 , 0.2083822112545060D-04 , - 0.5134265106203574D-07 , & 0.5166556577449103D-10 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.6475601823442967D+00 , - 0.4442085388633252D-02 , & 0.2057487865943821D-04 , - 0.5043534660846313D-07 , 0.5049332436438181D-10 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.6459282655758025D+00 , - 0.4408523875950349D-02 , 0.2031604728716866D-04 , & - 0.4954816938737986D-07 , 0.4935298080068417D-10 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.6443076616878572D+00 , & - 0.4375365502802631D-02 , 0.2006163304930567D-04 , - 0.4868059307962356D-07 , & 0.4824353570569428D-10 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.6426982710280027D+00 , - 0.4342604137373405D-02 , & 0.1981154417887391D-04 , - 0.4783210683969907D-07 , 0.4716402464653760D-10 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.6410999941906947D+00 , - 0.4310233745989350D-02 , 0.1956569104824713D-04 , & - 0.4700221480343664D-07 , 0.4611351680418509D-10 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.6395127320582402D+00 , & - 0.4278248391967734D-02 , 0.1932398611732604D-04 , - 0.4619043561204849D-07 , & 0.4509111369664992D-10 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.6379363858394693D+00 , - 0.4246642234447153D-02 , & 0.1908634388289097D-04 , - 0.4539630195203962D-07 , 0.4409594795405249D-10 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.6363708571062270D+00 , - 0.4215409527203849D-02 , 0.1885268082910983D-04 , & - 0.4461936011043346D-07 , 0.4312718214332900D-10 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.6348160478277592D+00 , & - 0.4184544617455666D-02 , 0.1862291537918199D-04 , - 0.4385916954479327D-07 , & 0.4218400764046172D-10 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.6332718604030959D+00 , - 0.4154041944655908D-02 , & 0.1839696784810139D-04 , - 0.4311530246754416D-07 , 0.4126564354821063D-10 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.6317381976914687D+00 , - 0.4123896039278300D-02 , 0.1817476039651489D-04 , & - 0.4238734344409765D-07 , 0.4037133565739461D-10 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.6302149630408937D+00 , & - 0.4094101521595641D-02 , 0.1795621698566219D-04 , - 0.4167488900432747D-07 , & 0.3950035544989085D-10 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.6287020603149515D+00 , - 0.4064653100453186D-02 , & 0.1774126333337396D-04 , - 0.4097754726693178D-07 , 0.3865199914157011D-10 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.6271993939178585D+00 , - 0.4035545572038570D-02 , 0.1752982687110999D-04 , & - 0.4029493757624868D-07 , 0.3782558676348275D-10 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.6257068688178937D+00 , & - 0.4006773818649695D-02 , 0.1732183670201812D-04 , - 0.3962669015110269D-07 , & 0.3702046127968029D-10 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.6242243905692362D+00 , - 0.3978332807461675D-02 , & 0.1711722355999208D-04 , - 0.3897244574526690D-07 , 0.3623598774012142D-10 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.6227518653323182D+00 , - 0.3950217589294848D-02 , 0.1691591976971398D-04 , & - 0.3833185531916120D-07 , 0.3547155246720246D-10 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.6212891998927057D+00 , & - 0.3922423297384084D-02 , 0.1671785920765540D-04 , - 0.3770457972238555D-07 , & 0.3472656227448015D-10 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.6198363016786049D+00 , - 0.3894945146151208D-02 , & 0.1652297726402239D-04 , - 0.3709028938673352D-07 , 0.3400044371625217D-10 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.6183930787770383D+00 , - 0.3867778429981253D-02 , 0.1633121080562301D-04 , & - 0.3648866402932354D-07 , 0.3329264236669863D-10 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.6169594399487666D+00 , & - 0.3840918522003859D-02 , 0.1614249813964046D-04 , - 0.3589939236551008D-07 , & 0.3260262212735724D-10 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.6155352946419715D+00 , - 0.3814360872880005D-02 , & 0.1595677897828834D-04 , - 0.3532217183122943D-07 , 0.3192986456173870D-10 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.6141205530048051D+00 , - 0.3788101009595833D-02 , 0.1577399440433491D-04 , & - 0.3475670831447535D-07 , 0.3127386825597124D-10 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.6127151258968198D+00 , & - 0.3762134534263649D-02 , 0.1559408683747365D-04 , - 0.3420271589558256D-07 , & 0.3063414820438253D-10 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.6113189248993462D+00 , - 0.3736457122931133D-02 , & 0.1541700000152328D-04 , - 0.3365991659602336D-07 , 0.3001023521899138D-10 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.6099318623248646D+00 , - 0.3711064524399372D-02 , 0.1524267889243906D-04 , & - 0.3312804013542784D-07 , 0.2940167536192193D-10 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.6085538512253996D+00 , & - 0.3685952559050054D-02 , 0.1507106974711544D-04 , - 0.3260682369654293D-07 , & 0.2880802939978939D-10 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.6071848054000293D+00 , - 0.3661117117683126D-02 , & 0.1490212001296711D-04 , - 0.3209601169787398D-07 , 0.2822887227916801D-10 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.6058246394014923D+00 , - 0.3636554160364461D-02 , 0.1473577831826470D-04 , & - 0.3159535557373076D-07 , 0.2766379262225752D-10 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.6044732685419784D+00 , & - 0.3612259715284708D-02 , 0.1457199444321234D-04 , - 0.3110461356143888D-07 , & 0.2711239224193413D-10 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.6031306088981249D+00 , - 0.3588229877629460D-02 , & 0.1441071929174846D-04 , - 0.3062355049546880D-07 , 0.2657428567538838D-10 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.6017965773152575D+00 , - 0.3564460808461152D-02 , 0.1425190486405271D-04 , & - 0.3015193760824735D-07 , 0.2604909973559177D-10 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.6004710914109361D+00 , & - 0.3540948733613364D-02 , 0.1409550422974516D-04 , - 0.2968955233743179D-07 , & 0.2553647307987314D-10 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.5991540695777856D+00 , - 0.3517689942596976D-02 , & 0.1394147150175572D-04 , - 0.2923617813941221D-07 , 0.2503605579489424D-10 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.5978454309857164D+00 , - 0.3494680787519580D-02 , 0.1378976181085512D-04 , & - 0.2879160430885054D-07 , 0.2454750899738003D-10 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.5965450955835189D+00 , & - 0.3471917682017603D-02 , 0.1364033128082670D-04 , - 0.2835562580403833D-07 , & 0.2407050444995242D-10 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.5952529840998813D+00 , - 0.3449397100201626D-02 , & 0.1349313700426540D-04 , - 0.2792804307788177D-07 , 0.2360472419146368D-10 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.5939690180438638D+00 , - 0.3427115575615178D-02 , 0.1334813701898934D-04 , & - 0.2750866191432409D-07 , 0.2314986018124628D-10 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.5926931197048331D+00 , & - 0.3405069700206663D-02 , 0.1320529028504622D-04 , - 0.2709729327001490D-07 , & 0.2270561395671298D-10 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.5914252121519460D+00 , - 0.3383256123315660D-02 , & 0.1306455666230647D-04 , - 0.2669375312106600D-07 , 0.2227169630378919D-10 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.5901652192331330D+00 , - 0.3361671550672334D-02 , 0.1292589688862091D-04 , & - 0.2629786231470117D-07 , 0.2184782693964318D-10 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.5889130655736605D+00 , & - 0.3340312743411037D-02 , 0.1278927255853465D-04 , - 0.2590944642565018D-07 , & 0.2143373420723862D-10 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.5876686765742786D+00 , - 0.3319176517097784D-02 , & 0.1265464610254138D-04 , - 0.2552833561712167D-07 , 0.2102915478123335D-10 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.5864319784089753D+00 , - 0.3298259740771637D-02 , 0.1252198076686448D-04 , & - 0.2515436450620046D-07 , 0.2063383338477309D-10 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.5852028980223895D+00 , & - 0.3277559336000514D-02 , 0.1239124059375477D-04 , - 0.2478737203352847D-07 , & 0.2024752251675618D-10 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.5839813631268330D+00 , - 0.3257072275950281D-02 , & 0.1226239040228513D-04 , - 0.2442720133710741D-07 , 0.1986998218913746D-10 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.5827673021990364D+00 , - 0.3236795584468594D-02 , 0.1213539576963824D-04 , & - 0.2407369963010790D-07 , 0.1950097967389796D-10 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.5815606444765691D+00 , & - 0.3216726335182440D-02 , 0.1201022301286878D-04 , - 0.2372671808253481D-07 , & 0.1914028925928402D-10 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.5803613199539877D+00 , - 0.3196861650609802D-02 , & 0.1188683917113102D-04 , - 0.2338611170662692D-07 , 0.1878769201495897D-10 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.5791692593786939D+00 , - 0.3177198701284915D-02 , 0.1176521198835710D-04 , & - 0.2305173924585911D-07 , 0.1844297556571154D-10 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.5779843942465920D+00 , & - 0.3157734704898112D-02 , 0.1164530989638045D-04 , - 0.2272346306744170D-07 , & 0.1810593387340072D-10 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.5768066567974718D+00 , - 0.3138466925448841D-02 , & 0.1152710199848556D-04 , - 0.2240114905818152D-07 , 0.1777636702679803D-10 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.5756359800102001D+00 , - 0.3119392672412770D-02 , 0.1141055805337862D-04 , & - 0.2208466652360635D-07 , 0.1745408103903295D-10 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.5744722975977077D+00 , & - 0.3100509299922478D-02 , 0.1129564845956611D-04 , - 0.2177388809023915D-07 , & 0.1713888765234153D-10 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.5733155440017864D+00 , - 0.3081814205961660D-02 , & 0.1118234424013081D-04 , - 0.2146868961091702D-07 , 0.1683060414983529D-10 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.5721656543877449D+00 , - 0.3063304831573186D-02 , 0.1107061702789772D-04 , & - 0.2116895007306088D-07 , 0.1652905317402559D-10 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.5710225646388553D+00 , & - 0.3044978660079798D-02 , 0.1096043905097336D-04 , - 0.2087455150978205D-07 , & 0.1623406255182815D-10 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.5698862113507049D+00 , - 0.3026833216318735D-02 , & 0.1085178311865704D-04 , - 0.2058537891375220D-07 , 0.1594546512581787D-10 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.5687565318253918D+00 , - 0.3008866065889169D-02 , 0.1074462260770866D-04 , & - 0.2030132015373116D-07 , 0.1566309859148069D-10 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.5676334640656067D+00 , & - 0.2991074814412694D-02 , 0.1063893144896588D-04 , - 0.2002226589367014D-07 , & 0.1538680534023824D-10 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.5665169467686101D+00 , - 0.2973457106806764D-02 , & 0.1053468411430202D-04 , - 0.1974810951430636D-07 , 0.1511643230802552D-10 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.5654069193200809D+00 , - 0.2956010626570416D-02 , 0.1043185560391263D-04 , & - 0.1947874703715966D-07 , 0.1485183082920350D-10 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.5643033217879334D+00 , & - 0.2938733095083415D-02 , 0.1033042143392936D-04 , - 0.1921407705086955D-07 , & 0.1459285649562002D-10 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.5632060949160007D+00 , - 0.2921622270917022D-02 , & 0.1023035762434363D-04 , - 0.1895400063977424D-07 , 0.1433936902060386D-10 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.5621151801176733D+00 , - 0.2904675949157440D-02 , 0.1013164068723841D-04 , & - 0.1869842131467380D-07 , 0.1409123210771998D-10 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.5610305194694705D+00 , & - 0.2887891960741306D-02 , 0.1003424761531757D-04 , - 0.1844724494570016D-07 , & 0.1384831332410105D-10 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.5599520557045513D+00 , - 0.2871268171803056D-02 , & 0.9938155870724987D-05 , - 0.1820037969722486D-07 , 0.1361048397818285D-10 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.5588797322062129D+00 , - 0.2854802483034596D-02 , 0.9843343374148868D-05 , & - 0.1795773596474589D-07 , 0.1337761900168543D-10 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.5578134930012862D+00 , & - 0.2838492829055703D-02 , 0.9749788494196304D-05 , - 0.1771922631367090D-07 , & 0.1314959683566455D-10 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.5567532827535596D+00 , - 0.2822337177796798D-02 , & 0.9657470037040615D-05 , - 0.1748476541995863D-07 , 0.1292629932050263D-10 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.5556990467571492D+00 , - 0.2806333529892634D-02 , 0.9566367236327417D-05 , & - 0.1725427001254150D-07 , 0.1270761158967757D-10 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.5546507309298551D+00 , & - 0.2790479918087228D-02 , 0.9476459743335265D-05 , - 0.1702765881747834D-07 , & 0.1249342196717481D-10 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.5536082818065109D+00 , - 0.2774774406649922D-02 , & 0.9387727617384357D-05 , - 0.1680485250378161D-07 , 0.1228362186840821D-10 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.5525716465322895D+00 , - 0.2759215090801723D-02 , 0.9300151316483346D-05 , & - 0.1658577363085711D-07 , 0.1207810570451280D-10 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.5515407728560766D+00 , & - 0.2743800096153364D-02 , 0.9213711688216251D-05 , - 0.1637034659752362D-07 , & 0.1187677078990241D-10 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.5505156091237782D+00 , - 0.2728527578152878D-02 , & 0.9128389960852602D-05 , - 0.1615849759253715D-07 , 0.1167951725295033D-10 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.5494961042716673D+00 , - 0.2713395721543987D-02 , 0.9044167734682564D-05 , & - 0.1595015454658906D-07 , 0.1148624794969417D-10 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.5484822078197362D+00 , & - 0.2698402739834584D-02 , 0.8961026973568195D-05 , - 0.1574524708572440D-07 , & 0.1129686838044832D-10 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.5474738698650534D+00 , - 0.2683546874775091D-02 , & 0.8878949996704917D-05 , - 0.1554370648613427D-07 , 0.1111128660921763D-10 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.5464710410751853D+00 , - 0.2668826395847271D-02 , 0.8797919470591524D-05 , & - 0.1534546563028752D-07 , 0.1092941318581792D-10 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.5454736726815543D+00 , & - 0.2654239599761582D-02 , 0.8717918401194180D-05 , - 0.1515045896433812D-07 , & 0.1075116107058727D-10 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.5444817164729063D+00 , - 0.2639784809965145D-02 , & 0.8638930126310819D-05 , - 0.1495862245679420D-07 , 0.1057644556161690D-10 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.5434951247887647D+00 , - 0.2625460376158547D-02 , 0.8560938308122387D-05 , & - 0.1476989355838985D-07 , 0.1040518422439465D-10 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.5425138505129280D+00 , & - 0.2611264673821944D-02 , 0.8483926925929204D-05 , - 0.1458421116312873D-07 , & 0.1023729682378013D-10 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.5415378470670100D+00 , - 0.2597196103750353D-02 , & 0.8407880269067832D-05 , - 0.1440151557046321D-07 , 0.1007270525822848D-10 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.5405670684039693D+00 , - 0.2583253091597155D-02 , 0.8332782929999560D-05 , & - 0.1422174844856381D-07 , 0.9911333496174235D-11 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.5396014690017717D+00 , & - 0.2569434087427583D-02 , 0.8258619797575698D-05 , - 0.1404485279866658D-07 , & 0.9753107514516559D-11 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.5386410038570053D+00 , - 0.2555737565279598D-02 , & 0.8185376050462776D-05 , - 0.1387077292043686D-07 , 0.9597955239107704D-11 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.5376856284785836D+00 , - 0.2542162022733737D-02 , 0.8113037150732240D-05 , & - 0.1369945437833743D-07 , 0.9445806487190126D-11 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.5367352988814844D+00 , & - 0.2528705980491119D-02 , 0.8041588837606915D-05 , - 0.1353084396896202D-07 , & 0.9296592911706832D-11 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.5357899715805269D+00 , - 0.2515367981959439D-02 , & 0.7971017121359993D-05 , - 0.1336488968930363D-07 , 0.9150247947418342D-11 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.5348496035842499D+00 , - 0.2502146592847608D-02 , 0.7901308277366772D-05 , & - 0.1320154070593812D-07 , 0.9006706758770498D-11 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.5339141523887415D+00 , & - 0.2489040400766885D-02 , 0.7832448840294969D-05 , - 0.1304074732507182D-07 , & 0.8865906189432719D-11 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.5329835759716151D+00 , - 0.2476048014840971D-02 , & 0.7764425598442963D-05 , - 0.1288246096345543D-07 , 0.8727784713472009D-11 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.5320578327859953D+00 , - 0.2463168065323007D-02 , 0.7697225588212787D-05 , & - 0.1272663412011648D-07 , 0.8592282388088388D-11 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.5311368817545666D+00 , & - 0.2450399203220118D-02 , 0.7630836088717984D-05 , - 0.1257322034889329D-07 , & 0.8459340807863814D-11 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.5302206822636797D+00 , - 0.2437740099925235D-02 , & 0.7565244616522557D-05 , - 0.1242217423174555D-07 , 0.8328903060472275D-11 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.5293091941574851D+00 , - 0.2425189446855582D-02 , 0.7500438920504468D-05 , & - 0.1227345135280936D-07 , 0.8200913683792290D-11 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.5284023777321958D+00 , & - 0.2412745955099191D-02 , 0.7436406976848939D-05 , - 0.1212700827319488D-07 , & 0.8075318624392495D-11 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.5275001937303305D+00 , - 0.2400408355067167D-02 , & 0.7373136984156668D-05 , - 0.1198280250647634D-07 , 0.7952065197318413D-11 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.5266026033350557D+00 , - 0.2388175396153230D-02 , 0.7310617358672553D-05 , & - 0.1184079249487344D-07 , 0.7831102047153229D-11 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.5257095681645672D+00 , & - 0.2376045846399580D-02 , 0.7248836729627715D-05 , - 0.1170093758609369D-07 , & 0.7712379110300840D-11 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.5248210502665835D+00 , - 0.2364018492169883D-02 , & 0.7187783934696291D-05 , - 0.1156319801082510D-07 , 0.7595847578456986D-11 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.5239370121128005D+00 , - 0.2352092137827348D-02 , 0.7127448015554917D-05 , & - 0.1142753486084012D-07 , 0.7481459863212422D-11 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.5230574165935008D+00 , & - 0.2340265605420191D-02 , 0.7067818213553806D-05 , - 0.1129391006771691D-07 , & 0.7369169561769131D-11 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.5221822270121780D+00 , - 0.2328537734372626D-02 , & 0.7008883965488232D-05 , - 0.1116228638214160D-07 , 0.7258931423717766D-11 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.5213114070802305D+00 , - 0.2316907381181930D-02 , 0.6950634899471008D-05 , & - 0.1103262735378097D-07 , 0.7150701318845717D-11 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.5204449209117299D+00 , & - 0.2305373419121519D-02 , 0.6893060830903596D-05 , - 0.1090489731170854D-07 , & 0.7044436205941273D-11 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.5195827330181901D+00 , - 0.2293934737949034D-02 , & 0.6836151758539189D-05 , - 0.1077906134535927D-07 , 0.6940094102553710D-11 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.5187248083035090D+00 , - 0.2282590243621404D-02 , 0.6779897860645061D-05 , & - 0.1065508528601691D-07 , 0.6837634055692856D-11 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.5178711120588656D+00 , & - 0.2271338858014147D-02 , 0.6724289491249426D-05 , - 0.1053293568879279D-07 , & 0.6737016113416704D-11 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.5170216099577293D+00 , - 0.2260179518646668D-02 , & 0.6669317176479346D-05 , - 0.1041257981509948D-07 , 0.6638201297291658D-11 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.5161762680509185D+00 , - 0.2249111178412746D-02 , 0.6614971610984037D-05 , & - 0.1029398561559771D-07 , 0.6541151575690861D-11 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.5153350527617087D+00 , & - 0.2238132805316040D-02 , 0.6561243654441179D-05 , - 0.1017712171360221D-07 , & 0.6445829837902413D-11 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.5144979308810619D+00 , - 0.2227243382211450D-02 , & 0.6508124328148332D-05 , - 0.1006195738894132D-07 , 0.6352199869027325D-11 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.5136648695627981D+00 , - 0.2216441906550005D-02 , 0.6455604811687191D-05 , & - 0.9948462562236528D-08 , 0.6260226325625149D-11 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.5128358363189407D+00 , & - 0.2205727390130021D-02 , 0.6403676439671705D-05 , - 0.9836607779615795D-08 , & 0.6169874712102896D-11 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.5120107990150663D+00 , - 0.2195098858852375D-02 , & 0.6352330698568670D-05 , - 0.9726364197829040D-08 , 0.6081111357808241D-11 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.5111897258657248D+00 , - 0.2184555352480606D-02 , 0.6301559223592495D-05 , & - 0.9617703569761233D-08 , 0.5993903394809483D-11 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.5103725854299327D+00 , & - 0.2174095924405771D-02 , 0.6251353795672512D-05 , - 0.9510598230331882D-08 , & 0.5908218736340089D-11 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.5095593466066577D+00 , - 0.2163719641414992D-02 , & 0.6201706338486487D-05 , - 0.9405021082760713D-08 , 0.5824026055879336D-11 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.5087499786304900D+00 , - 0.2153425583465967D-02 , 0.6152608915569303D-05 , & - 0.9300945585210190D-08 , 0.5741294766864518D-11 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.5079444510672479D+00 , & - 0.2143212843464314D-02 , 0.6104053727481399D-05 , - 0.9198345737766744D-08 , & 0.5659995002993642D-11 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.5071427338097017D+00 , - 0.2133080527045865D-02 , & 0.6056033109045151D-05 , - 0.9097196069770464D-08 , 0.5580097599114252D-11 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.5063447970733406D+00 , - 0.2123027752362973D-02 , 0.6008539526643784D-05 , & - 0.8997471627475660D-08 , 0.5501574072673825D-11 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.5055506113921822D+00 , & - 0.2113053649874691D-02 , 0.5961565575580986D-05 , - 0.8899147962032307D-08 , & 0.5424396605713302D-11 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.5047601476147113D+00 , - 0.2103157362141806D-02 , & 0.5915103977504416D-05 , - 0.8802201117788444D-08 , 0.5348538027393242D-11 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.5039733768997349D+00 , - 0.2093338043624130D-02 , 0.5869147577880357D-05 , & - 0.8706607620882289D-08 , 0.5273971797019146D-11 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.5031902707124234D+00 , & - 0.2083594860483176D-02 , 0.5823689343532406D-05 , - 0.8612344468143771D-08 , & 0.5200671987570851D-11 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.5024108008203449D+00 , - 0.2073926990387827D-02 , & 0.5778722360232424D-05 , - 0.8519389116276560D-08 , 0.5128613269704969D-11 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.5016349392895650D+00 , - 0.2064333622323826D-02 , 0.5734239830346398D-05 , & - 0.8427719471320339D-08 , 0.5057770896221112D-11 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.5008626584808160D+00 , & - 0.2054813956407048D-02 , 0.5690235070533996D-05 , - 0.8337313878385724D-08 , & 0.4988120686977459D-11 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.5000939310456398D+00 , - 0.2045367203699365D-02 , & 0.5646701509495687D-05 , - 0.8248151111644685D-08 , 0.4919639014234592D-11 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.4993287299227344D+00 , - 0.2035992586029727D-02 , 0.5603632685777821D-05 , & - 0.8160210364591795D-08 , 0.4852302788430547D-11 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.4985670283342086D+00 , & - 0.2026689335816937D-02 , 0.5561022245619456D-05 , - 0.8073471240539909D-08 , & 0.4786089444352570D-11 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.4978087997819551D+00 , - 0.2017456695896544D-02 , & 0.5518863940850517D-05 , - 0.7987913743364331D-08 , 0.4720976927708186D-11 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.4970540180440627D+00 , - 0.2008293919350821D-02 , 0.5477151626835961D-05 , & - 0.7903518268480570D-08 , 0.4656943682077340D-11 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.4963026571712592D+00 , & - 0.1999200269341715D-02 , 0.5435879260464573D-05 , - 0.7820265594048737D-08 , & 0.4593968636233416D-11 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.4955546914834894D+00 , - 0.1990175018947892D-02 , & 0.5395040898186379D-05 , - 0.7738136872407897D-08 , 0.4532031191828639D-11 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.4948100955663801D+00 , - 0.1981217451002958D-02 , 0.5354630694085363D-05 , & - 0.7657113621710899D-08 , 0.4471111211415954D-11 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.4940688442679084D+00 , & - 0.1972326857938464D-02 , 0.5314642898002106D-05 , - 0.7577177717783583D-08 , & 0.4411189006818143D-11 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.4933309126950412D+00 , - 0.1963502541628965D-02 , & 0.5275071853693972D-05 , - 0.7498311386180906D-08 , 0.4352245327818248D-11 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.4925962762104392D+00 , - 0.1954743813240126D-02 , 0.5235911997036251D-05 , & - 0.7420497194442763D-08 , 0.4294261351167281D-11 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.4918649104288927D+00 , & - 0.1946049993075906D-02 , 0.5197157854245904D-05 , - 0.7343718044509626D-08 , & 0.4237218669873989D-11 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.4911367912153775D+00 , - 0.1937420410447245D-02 , & 0.5158804040227370D-05 , - 0.7267957165491911D-08 , 0.4181099282915493D-11 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.4904118946799898D+00 , - 0.1928854403505713D-02 , 0.5120845256787130D-05 , & - 0.7193198106286998D-08 , 0.4125885584986912D-11 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.4896901971761097D+00 , & - 0.1920351319117760D-02 , 0.5083276291054436D-05 , - 0.7119424728710648D-08 , & 0.4071560356781351D-11 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.4889716752970089D+00 , - 0.1911910512722470D-02 , & 0.5046092013852267D-05 , - 0.7046621200631352D-08 , 0.4018106755414405D-11 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.4882563058728221D+00 , - 0.1903531348195684D-02 , 0.5009287378120198D-05 , & - 0.6974771989306660D-08 , 0.3965508305136819D-11 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.4875440659675426D+00 , & - 0.1895213197716381D-02 , 0.4972857417370233D-05 , - 0.6903861854881033D-08 , & 0.3913748888300683D-11 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.4868349328761581D+00 , - 0.1886955441636590D-02 , & 0.4936797244180256D-05 , - 0.6833875844050907D-08 , 0.3862812736578538D-11 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.4861288841216397D+00 , - 0.1878757468351604D-02 , 0.4901102048711171D-05 , & - 0.6764799283868414D-08 , 0.3812684422411095D-11 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.4854258974521523D+00 , & - 0.1870618674174518D-02 , 0.4865767097263802D-05 , - 0.6696617775710663D-08 , & 0.3763348850698007D-11 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.4847259508382197D+00 , - 0.1862538463212106D-02 , & 0.4830787730862652D-05 , - 0.6629317189388125D-08 , 0.3714791250709146D-11 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.4840290224699466D+00 , - 0.1854516247243134D-02 , 0.4796159363870475D-05 , & - 0.6562883657396799D-08 , 0.3666997168215664D-11 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.4833350907543018D+00 , & - 0.1846551445599100D-02 , 0.4761877482633163D-05 , - 0.6497303569310803D-08 , & 0.3619952457834625D-11 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.4826441343123345D+00 , - 0.1838643485045998D-02 , & 0.4727937644148629D-05 , - 0.6432563566301331D-08 , 0.3573643275573842D-11 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.4819561319766313D+00 , - 0.1830791799670365D-02 , 0.4694335474772563D-05 , & - 0.6368650535803136D-08 , 0.3528056071587735D-11 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.4812710627886177D+00 , & - 0.1822995830765324D-02 , 0.4661066668943000D-05 , - 0.6305551606293360D-08 , & 0.3483177583116665D-11 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.4805889059959904D+00 , - 0.1815255026719645D-02 , & 0.4628126987935643D-05 , - 0.6243254142202190D-08 , 0.3438994827619673D-11 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.4799096410501675D+00 , - 0.1807568842908612D-02 , 0.4595512258644464D-05 , & - 0.6181745738943248D-08 , 0.3395495096089068D-11 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.4792332476037513D+00 , & - 0.1799936741586575D-02 , 0.4563218372386708D-05 , - 0.6121014218060084D-08 , & 0.3352665946541253D-11 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.4785597055081402D+00 , - 0.1792358191782619D-02 , & 0.4531241283737608D-05 , - 0.6061047622496169D-08 , 0.3310495197685669D-11 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.4778889948109619D+00 , - 0.1784832669195826D-02 , 0.4499577009380164D-05 , & - 0.6001834211960270D-08 , 0.3268970922749950D-11 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.4772210957537435D+00 , & - 0.1777359656094537D-02 , 0.4468221626987408D-05 , - 0.5943362458416408D-08 , & 0.3228081443478067D-11 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.4765559887695208D+00 , - 0.1769938641216380D-02 , & 0.4437171274123630D-05 , - 0.5885621041672379D-08 , 0.3187815324281144D-11 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.4758936544804985D+00 , - 0.1762569119670260D-02 , 0.4406422147169045D-05 , & - 0.5828598845073000D-08 , 0.3148161366542415D-11 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.4752340736957696D+00 , & - 0.1755250592840343D-02 , 0.4375970500267610D-05 , - 0.5772284951295825D-08 , & 0.3109108603072161D-11 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.4745772274089466D+00 , - 0.1747982568290469D-02 , & 0.4345812644291452D-05 , - 0.5716668638236090D-08 , 0.3070646292701345D-11 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.4739230967960541D+00 , - 0.1740764559672624D-02 , 0.4315944945835875D-05 , & - 0.5661739375003809D-08 , 0.3032763915026627D-11 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.4732716632132358D+00 , & - 0.1733596086634762D-02 , 0.4286363826225950D-05 , - 0.5607486817997968D-08 , & 0.2995451165281185D-11 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.4726229081945943D+00 , - 0.1726476674731298D-02 , & 0.4257065760547555D-05 , - 0.5553900807078928D-08 , 0.2958697949343023D-11 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.4719768134500467D+00 , - 0.1719405855334977D-02 , 0.4228047276697302D-05 , & - 0.5500971361827683D-08 , 0.2922494378871022D-11 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.4713333608631776D+00 , & - 0.1712383165549980D-02 , 0.4199304954450600D-05 , - 0.5448688677889266D-08 , & 0.2886830766564796D-11 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.4706925324892540D+00 , - 0.1705408148127864D-02 , & 0.4170835424553640D-05 , - 0.5397043123408837D-08 , 0.2851697621551827D-11 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.4700543105530259D+00 , - 0.1698480351382463D-02 , 0.4142635367824034D-05 , & - 0.5346025235532635D-08 , 0.2817085644881702D-11 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.4694186774467861D+00 , & - 0.1691599329108631D-02 , 0.4114701514278696D-05 , - 0.5295625717004621D-08 , & 0.2782985725145587D-11 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.4687856157283498D+00 , - 0.1684764640501254D-02 , & 0.4087030642274833D-05 , - 0.5245835432833043D-08 , 0.2749388934202220D-11 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.4681551081190811D+00 , - 0.1677975850075871D-02 , 0.4059619577668961D-05 , & - 0.5196645407034107D-08 , 0.2716286523013282D-11 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.4675271375019553D+00 , & - 0.1671232527590705D-02 , 0.4032465192992778D-05 , - 0.5148046819449469D-08 , & 0.2683669917584157D-11 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.4669016869196519D+00 , - 0.1664534247970152D-02 , & 0.4005564406646273D-05 , - 0.5100031002637494D-08 , 0.2651530715008664D-11 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.4662787395725801D+00 , - 0.1657880591228436D-02 , 0.3978914182101689D-05 , & - 0.5052589438824565D-08 , 0.2619860679606186D-11 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.4656582788171542D+00 , & - 0.1651271142397070D-02 , 0.3952511527133831D-05 , - 0.5005713756944498D-08 , & 0.2588651739169392D-11 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.4650402881638630D+00 , - 0.1644705491451016D-02 , & 0.3926353493055133D-05 , - 0.4959395729725349D-08 , 0.2557895981292993D-11 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.4644247512754789D+00 , - 0.1638183233237343D-02 , 0.3900437173970872D-05 , & - 0.4913627270850468D-08 , 0.2527585649800371D-11 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.4638116519652721D+00 , & - 0.1631703967404860D-02 , 0.3874759706048050D-05 , - 0.4868400432181116D-08 , & 0.2497713141258063D-11 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.4632009741952136D+00 , - 0.1625267298334566D-02 , & 0.3849318266797195D-05 , - 0.4823707401038448D-08 , 0.2468271001575345D-11 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.4625927020743724D+00 , - 0.1618872835073018D-02 , 0.3824110074374884D-05 , & - 0.4779540497557099D-08 , 0.2439251922695218D-11 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.4619868198570096D+00 , & - 0.1612520191263494D-02 , 0.3799132386887177D-05 , - 0.4735892172075913D-08 , & 0.2410648739353724D-11 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.4613833119410110D+00 , - 0.1606208985081489D-02 , & 0.3774382501718711D-05 , - 0.4692755002606637D-08 , 0.2382454425931997D-11 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.4607821628661921D+00 , - 0.1599938839169770D-02 , 0.3749857754869028D-05 , & - 0.4650121692348627D-08 , 0.2354662093379624D-11 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.4601833573126547D+00 , & - 0.1593709380574807D-02 , 0.3725555520302871D-05 , - 0.4607985067260001D-08 , & 0.2327264986214672D-11 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.4595868800992058D+00 , - 0.1587520240684658D-02 , & 0.3701473209314481D-05 , - 0.4566338073684392D-08 , 0.2300256479598604D-11 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.4589927161816120D+00 , - 0.1581371055166037D-02 , 0.3677608269897276D-05 , & - 0.4525173776018229D-08 , 0.2273630076475578D-11 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.4584008506512317D+00 , & - 0.1575261463905933D-02 , 0.3653958186138673D-05 , - 0.4484485354450360D-08 , & 0.2247379404794730D-11 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.4578112687333296D+00 , - 0.1569191110950856D-02 , & 0.3630520477614119D-05 , - 0.4444266102730363D-08 , 0.2221498214787230D-11 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.4572239557855738D+00 , - 0.1563159644448686D-02 , 0.3607292698798632D-05 , & - 0.4404509425995019D-08 , 0.2195980376315355D-11 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.4566388972965243D+00 , & - 0.1557166716591168D-02 , 0.3584272438488424D-05 , - 0.4365208838639937D-08 , & 0.2170819876284472D-11 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.4560560788840997D+00 , - 0.1551211983556952D-02 , & 0.3561457319232073D-05 , - 0.4326357962234697D-08 , 0.2146010816115919D-11 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.4554754862942612D+00 , - 0.1545295105457477D-02 , 0.3538844996779480D-05 , & - 0.4287950523494258D-08 , 0.2121547409287605D-11 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.4548971053993425D+00 , & - 0.1539415746280119D-02 , 0.3516433159527991D-05 , - 0.4249980352272330D-08 , & 0.2097423978920415D-11 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.4543209221967560D+00 , - 0.1533573573835707D-02 , & 0.3494219527991622D-05 , - 0.4212441379618280D-08 , 0.2073634955434896D-11 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.4537469228075485D+00 , - 0.1527768259705266D-02 , 0.3472201854274261D-05 , & - 0.4175327635865744D-08 , 0.2050174874257884D-11 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.4531750934750081D+00 , & - 0.1521999479187922D-02 , 0.3450377921553924D-05 , - 0.4138633248763860D-08 , & 0.2027038373584873D-11 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.4526054205633336D+00 , - 0.1516266911250079D-02 , & 0.3428745543578200D-05 , - 0.4102352441650641D-08 , 0.2004220192196965D-11 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.4520378905561163D+00 , - 0.1510570238473447D-02 , 0.3407302564162025D-05 , & - 0.4066479531653704D-08 , 0.1981715167322682D-11 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.4514724900552331D+00 , & - 0.1504909147007648D-02 , 0.3386046856708319D-05 , - 0.4031008927950677D-08 , & 0.1959518232563308D-11 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.4509092057793811D+00 , - 0.1499283326520022D-02 , & 0.3364976323724709D-05 , - 0.3995935130045753D-08 , 0.1937624415854752D-11 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.4503480245628115D+00 , - 0.1493692470147942D-02 , 0.3344088896355367D-05 , & - 0.3961252726092335D-08 , 0.1916028837483242D-11 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.4497889333540452D+00 , & - 0.1488136274451570D-02 , 0.3323382533920351D-05 , - 0.3926956391249054D-08 , & 0.1894726708146438D-11 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.4492319192145604D+00 , - 0.1482614439366934D-02 , & 0.3302855223461927D-05 , - 0.3893040886067801D-08 , 0.1873713327058475D-11 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.4486769693177126D+00 , - 0.1477126668161789D-02 , 0.3282504979306481D-05 , & - 0.3859501054926844D-08 , 0.1852984080105998D-11 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.4481240709472608D+00 , & - 0.1471672667388322D-02 , 0.3262329842620808D-05 , - 0.3826331824475019D-08 , & 0.1832534438034314D-11 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.4475732114963027D+00 , - 0.1466252146840286D-02 , & 0.3242327880989568D-05 , - 0.3793528202128831D-08 , 0.1812359954687873D-11 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.4470243784660372D+00 , - 0.1460864819509049D-02 , 0.3222497187994261D-05 , & - 0.3761085274590938D-08 , 0.1792456265285706D-11 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.4464775594645799D+00 , & - 0.1455510401540688D-02 , 0.3202835882801105D-05 , - 0.3728998206401178D-08 , & 0.1772819084737841D-11 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.4459327422058413D+00 , - 0.1450188612194188D-02 , & 0.3183342109757933D-05 , - 0.3697262238519920D-08 , 0.1753444206001943D-11 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.4453899145081954D+00 , - 0.1444899173798221D-02 , 0.3164014037991159D-05 , & - 0.3665872686929232D-08 , 0.1734327498471112D-11 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.4448490642935916D+00 , & - 0.1439641811712561D-02 , 0.3144849861023884D-05 , - 0.3634824941284383D-08 , & 0.1715464906411314D-11 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.4443101795862736D+00 , - 0.1434416254286336D-02 , & 0.3125847796387738D-05 , - 0.3604114463572432D-08 , 0.1696852447422554D-11 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.4437732485117069D+00 , - 0.1429222232818725D-02 , 0.3107006085248012D-05 , & - 0.3573736786808081D-08 , 0.1678486210940938D-11 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.4432382592954859D+00 , & - 0.1424059481519929D-02 , 0.3088322992034357D-05 , - 0.3543687513754243D-08 , & 0.1660362356773770D-11 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.4427052002622032D+00 , - 0.1418927737472303D-02 , & 0.3069796804076539D-05 , - 0.3513962315666269D-08 , 0.1642477113666564D-11 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.4421740598345686D+00 , - 0.1413826740594214D-02 , 0.3051425831254117D-05 , & - 0.3484556931073018D-08 , 0.1624826777909091D-11 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.4416448265320965D+00 , & - 0.1408756233600413D-02 , 0.3033208405638369D-05 , - 0.3455467164561080D-08 , & 0.1607407711960546D-11 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.4411174889702316D+00 , - 0.1403715961966883D-02 , & 0.3015142881153956D-05 , - 0.3426688885604096D-08 , 0.1590216343117572D-11 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.4405920358592854D+00 , - 0.1398705673894374D-02 , 0.2997227633240236D-05 , & - 0.3398218027405887D-08 , 0.1573249162206628D-11 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.4400684560034234D+00 , & - 0.1393725120272868D-02 , 0.2979461058519815D-05 , - 0.3370050585768722D-08 , & 0.1556502722306814D-11 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.4395467382997185D+00 , - 0.1388774054647037D-02 , & 0.2961841574474542D-05 , - 0.3342182617986708D-08 , 0.1539973637502676D-11 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.4390268717369736D+00 , - 0.1383852233180050D-02 , 0.2944367619119787D-05 , & - 0.3314610241750025D-08 , 0.1523658581658470D-11 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.4385088453950186D+00 , & - 0.1378959414622092D-02 , 0.2927037650698615D-05 , - 0.3287329634092524D-08 , & 0.1507554287231981D-11 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.4379926484435794D+00 , - 0.1374095360275390D-02 , & 0.2909850147367854D-05 , - 0.3260337030339835D-08 , 0.1491657544103098D-11 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.4374782701413697D+00 , - 0.1369259833961679D-02 , 0.2892803606896122D-05 , & - 0.3233628723088186D-08 , 0.1475965198433966D-11 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.4369656998351559D+00 , & - 0.1364452601989790D-02 , 0.2875896546365906D-05 , - 0.3207201061201586D-08 , & 0.1460474151553309D-11 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.4364549269587779D+00 , - 0.1359673433123252D-02 , & 0.2859127501879257D-05 , - 0.3181050448826490D-08 , 0.1445181358864092D-11 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.4359459410324367D+00 , - 0.1354922098550634D-02 , 0.2842495028276135D-05 , & - 0.3155173344437159D-08 , 0.1430083828781557D-11 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.3333333333333355D+00 , & - 0.1206448831626068D-01 , 0.2599140687261692D-03 , - 0.4064995511873451D-05 , & 0.5015638261836376D-07 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.3333333329869434D+00 , - 0.1206448632311727D-01 , & 0.2599096103640721D-03 , - 0.4060048646935900D-05 , 0.4766204222838533D-07 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.3333333194723299D+00 , - 0.1206445241320479D-01 , 0.2598770889210297D-03 , & - 0.4045883868077594D-05 , 0.4529463742892937D-07 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.3333332278987315D+00 , & - 0.1206430916865215D-01 , 0.2597924045590268D-03 , - 0.4023451049756715D-05 , & 0.4304759582335387D-07 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.3333329011971821D+00 , - 0.1206394002116657D-01 , & 0.2596353437218440D-03 , - 0.3993626020518139D-05 , 0.4091468993499534D-07 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.3333320612291769D+00 , - 0.1206319838931554D-01 , 0.2593891698501641D-03 , & - 0.3957215752671268D-05 , 0.3889001890912375D-07 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.3333302896250453D+00 , & - 0.1206191558369142D-01 , 0.2590402501802782D-03 , - 0.3914963207535139D-05 , & 0.3696799119424323D-07 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.3333270167178882D+00 , - 0.1205990761180536D-01 , & 0.2585777157421210D-03 , - 0.3867551858383141D-05 , 0.3514330814993343D-07 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.3333215171464798D+00 , - 0.1205698100218008D-01 , 0.2579931518891001D-03 , & - 0.3815609911826983D-05 , 0.3341094853129144D-07 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.3333129108855911D+00 , & - 0.1205293775580178D-01 , 0.2572803168933054D-03 , - 0.3759714247073341D-05 , & 0.3176615380274300D-07 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.3333001686269551D+00 , - 0.1204757952276224D-01 , & 0.2564348863262809D-03 , - 0.3700394091261330D-05 , 0.3020441423655258D-07 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.3332821205805706D+00 , - 0.1204071109249454D-01 , 0.2554542211186440D-03 , & - 0.3638134447939930D-05 , 0.2872145575378379D-07 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.3332574678960224D+00 , & - 0.1203214327740409D-01 , 0.2543371573523694D-03 , - 0.3573379294666708D-05 , & 0.2731322746775030D-07 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.3332247960186684D+00 , - 0.1202169526185520D-01 , & 0.2530838159884199D-03 , - 0.3506534564698613D-05 , 0.2597588989216362D-07 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.3331825893973525D+00 , - 0.1200919648132671D-01 , 0.2516954308704129D-03 , & - 0.3437970926797703D-05 , 0.2470580377822779D-07 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.3331292470501611D+00 , & - 0.1199448809004352D-01 , 0.2501741934729293D-03 , - 0.3368026376286171D-05 , & 0.2349951954687104D-07 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.3330630985738313D+00 , - 0.1197742406946825D-01 , & 0.2485231129816125D-03 , - 0.3297008649651459D-05 , 0.2235376728412970D-07 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.3329824202518852D+00 , - 0.1195787202465214D-01 , 0.2467458904020310D-03 , & - 0.3225197474221069D-05 , 0.2126544726943298D-07 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.3328854509774145D+00 , & - 0.1193571371054958D-01 , 0.2448468054960112D-03 , - 0.3152846663694067D-05 , & 0.2023162100817232D-07 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.3327704077595642D+00 , - 0.1191084532595648D-01 , & 0.2428306154383543D-03 , - 0.3080186069629467D-05 , 0.1924950274148622D-07 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.3326355006290269D+00 , - 0.1188317760869985D-01 , 0.2407024641740793D-03 , & - 0.3007423398347897D-05 , 0.1831645140765489D-07 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.3324789467979651D+00 , & - 0.1185263576204952D-01 , 0.2384678015370690D-03 , - 0.2934745902099343D-05 , & 0.1742996303088208D-07 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.3322989839644406D+00 , - 0.1181915923901127D-01 , & 0.2361323112657090D-03 , - 0.2862321952784077D-05 , 0.1658766351455003D-07 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.3320938826812209D+00 , - 0.1178270140816306D-01 , 0.2337018471202355D-03 , & - 0.2790302505983575D-05 , 0.1578730181727077D-07 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.3318619577343323D+00 , & - 0.1174322912198626D-01 , 0.2311823763704345D-03 , - 0.2718822462561281D-05 , & 0.1502674349122668D-07 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.3316015784983969D+00 , - 0.1170072220619594D-01 , & 0.2285799299814514D-03 , - 0.2648001934627222D-05 , 0.1430396456340007D-07 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.3313111782541118D+00 , - 0.1165517288636596D-01 , 0.2259005588801155D-03 , & - 0.2577947422224072D-05 , 0.1361704574133763D-07 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.3309892624685482D+00 , & - 0.1160658516615455D-01 , 0.2231502957346809D-03 , - 0.2508752906683163D-05 , & 0.1296416692608560D-07 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.3306344160516891D+00 , - 0.1155497416964443D-01 , & 0.2203351217275369D-03 , - 0.2440500866215697D-05 , 0.1234360201586682D-07 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.3302453096130375D+00 , - 0.1150036545870174D-01 , 0.2174609378435321D-03 , & - 0.2373263218945332D-05 , 0.1175371398495691D-07 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.3298207047505614D+00 , & - 0.1144279433481190D-01 , 0.2145335402363283D-03 , - 0.2307102198251836D-05 , & 0.1119295022305292D-07 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.3293594584109135D+00 , - 0.1138230513355562D-01 , & 0.2115585992719229D-03 , - 0.2242071164980345D-05 , 0.1065983812122063D-07 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.3288605263650202D+00 , - 0.1131895051872810D-01 , 0.2085416418823466D-03 , & - 0.2178215360775501D-05 , 0.1015298089125473D-07 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.3283229658469752D+00 , & - 0.1125279078206907D-01 , 0.2054880368937873D-03 , - 0.2115572606523171D-05 , & 0.9671053605994972D-08 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.3277459374068837D+00 , - 0.1118389315364762D-01 , & 0.2024029830221976D-03 , - 0.2054173949623445D-05 , 0.9212799448811174D-08 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.3271287060300437D+00 , - 0.1111233112712355D-01 , 0.1992914992559825D-03 , & - 0.1994044263575959D-05 , 0.8777026161103550D-08 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.3264706415757566D+00 , & - 0.1103818380337749D-01 , 0.1961584173698282D-03 , - 0.1935202803131470D-05 , & 0.8362602677264492D-08 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.3257712185892813D+00 , - 0.1096153525535513D-01 , & 0.1930083763362428D-03 , - 0.1877663718050788D-05 , 0.7968455937114645D-08 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.3250300155400659D+00 , - 0.1088247391640012D-01 , 0.1898458184221164D-03 , & - 0.1821436528313031D-05 , 0.7593567866362650D-08 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.3242467135385296D+00 , & - 0.1080109199384672D-01 , 0.1866749867766749D-03 , - 0.1766526563428644D-05 , & 0.7236972516145105D-08 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.3234210945824083D+00 , - 0.1071748490920166D-01 , & 0.1834999243347407D-03 , - 0.1712935368338015D-05 , 0.6897753353183257D-08 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.3225530393820895D+00 , - 0.1063175076585800D-01 , 0.1803244738753365D-03 , & - 0.1660661078213091D-05 , 0.6575040692546916D-08 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.3216425248125153D+00 , & - 0.1054398984494714D-01 , 0.1771522790904757D-03 , - 0.1609698764326421D-05 , & 0.6268009265445483D-08 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.3206896210371971D+00 , - 0.1045430412964291D-01 , & 0.1739867865325865D-03 , - 0.1560040753008835D-05 , 0.5975875914872327D-08 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.3196944883476856D+00 , - 0.1036279685797950D-01 , 0.1708312483214928D-03 , & - 0.1511676919583014D-05 , 0.5697897412313029D-08 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.3186573737595522D+00 , & - 0.1026957210402919D-01 , 0.1676887255033257D-03 , - 0.1464594959034776D-05 , & 0.5433368389091588D-08 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.3175786074035700D+00 , - 0.1017473438710150D-01 , & 0.1645620919642306D-03 , - 0.1418780635066606D-05 , 0.5181619376272796D-08 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.3164585987483862D+00 , - 0.1007838830847017D-01 , 0.1614540388113458D-03 , & - 0.1374218009068179D-05 , 0.4942014947364262D-08 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.3152978326885748D+00 , & - 0.9980638215004528D-02 , 0.1583670791423317D-03 , - 0.1330889650435939D-05 , & 0.4713951958369623D-08 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.3140968655295659D+00 , - 0.9881587888974740D-02 , & 0.1553035531327769D-03 , - 0.1288776829577767D-05 , 0.4496857880035676D-08 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.3128563208985934D+00 , - 0.9781340263213164D-02 , 0.1522656333781622D-03 , & - 0.1247859694848902D-05 , 0.4290189217411869D-08 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.3115768856085010D+00 , & - 0.9679997160745321D-02 , 0.1492553304337968D-03 , - 0.1208117434581298D-05 , & 0.4093430012101313D-08 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.3102593054990043D+00 , - 0.9577659057949975D-02 , & 0.1462744985022621D-03 , - 0.1169528425290050D-05 , 0.3906090422829270D-08 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.3089043812778394D+00 , - 0.9474424870268497D-02 , 0.1433248412235034D-03 , & - 0.1132070367067024D-05 , 0.3727705380188503D-08 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.3075129643821476D+00 , & - 0.9370391759455872D-02 , 0.1404079175278003D-03 , - 0.1095720407103209D-05 , & 0.3557833311641804D-08 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.3060859528784481D+00 , - 0.9265654961348825D-02 , & 0.1375251475164897D-03 , - 0.1060455252217121D-05 , 0.3396054933071089D-08 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.3046242874176487D+00 , - 0.9160307633118519D-02 , 0.1346778183395309D-03 , & - 0.1026251271206559D-05 , 0.3241972103360162D-08 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.3031289472597389D+00 , & - 0.9054440718975454D-02 , 0.1318670900428350D-03 , - 0.9930845877850009D-06 , & 0.3095206738685538D-08 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.3016009463811026D+00 , - 0.8948142833300955D-02 , & 0.1290940013617557D-03 , - 0.9609311648115172D-06 , 0.2955399783366744D-08 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.3000413296757758D+00 , - 0.8841500160192375D-02 , 0.1263594754402886D-03 , & - 0.9297668804741436D-06 , 0.2822210234295198D-08 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.2984511692604656D+00 , & - 0.8734596368426608D-02 , 0.1236643254583740D-03 , - 0.8995675970409400D-06 , & 0.2695314216119343D-08 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.2968315608917310D+00 , - 0.8627512540868292D-02 , & 0.1210092601522749D-03 , - 0.8703092227502674D-06 , 0.2574404104513869D-08 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.2951836205024090D+00 , - 0.8520327117374117D-02 , 0.1183948892153234D-03 , & - 0.8419677673719271D-06 , 0.2459187695002865D-08 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.2935084808631471D+00 , & - 0.8413115850272504D-02 , 0.1158217285684210D-03 , - 0.8145193919335846D-06 , & 0.2349387414941251D-08 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.2918072883737617D+00 , - 0.8305951771528017D-02 , & 0.1132902054915586D-03 , - 0.7879404530721316D-06 , 0.2244739576386047D-08 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.2900811999881080D+00 , - 0.8198905170731638D-02 , 0.1108006636093105D-03 , & - 0.7622075424371962D-06 , 0.2144993667709470D-08 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.2883313802751715D+00 , & - 0.8092043583091152D-02 , 0.1083533677247656D-03 , - 0.7372975215437290D-06 , & 0.2049911681919854D-08 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.2865589986182249D+00 , - 0.7985431786629813D-02 , & 0.1059485084977106D-03 , - 0.7131875524423326D-06 , 0.1959267479764249D-08 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.2847652265530807D+00 , - 0.7879131807836035D-02 , 0.1035862069640795D-03 , & - 0.6898551245496425D-06 , 0.1872846185788679D-08 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.2829512352457458D+00 , & - 0.7773202935041698D-02 , 0.1012665188947524D-03 , - 0.6672780779564743D-06 , & 0.1790443615628697D-08 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.2811181931091261D+00 , - 0.7667701738841431D-02 , & 0.9898943899273389D-04 , - 0.6454346235085150D-06 , 0.1711865732894340D-08 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.2792672635578342D+00 , - 0.7562682098899993D-02 , 0.9675490492857011D-04 , & - 0.6243033599329563D-06 , 0.1636928134100211D-08 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.2773996028996237D+00 , & - 0.7458195236529018D-02 , 0.9456280121460190D-04 , - 0.6038632882645253D-06 , & 0.1565455560173379D-08 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.2755163583615055D+00 , - 0.7354289752448267D-02 , & 0.9241296291928844D-04 , - 0.5840938238057903D-06 , 0.1497281433149372D-08 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.2736186662481794D+00 , - 0.7251011669179444D-02 , 0.9030517922339300D-04 , & - 0.5649748058392960D-06 , 0.1432247416740028D-08 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.2717076502300558D+00 , & - 0.7148404477553043D-02 , 0.8823919682030671D-04 , - 0.5464865052929597D-06 , & 0.1370202999526471D-08 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.2697844197578219D+00 , - 0.7046509186840005D-02 , & 0.8621472316319581D-04 , - 0.5286096305451189D-06 , 0.1311005099596342D-08 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.2678500686002364D+00 , - 0.6945364378050486D-02 , 0.8423142956201249D-04 , & - 0.5113253315416389D-06 , 0.1254517689506723D-08 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.2659056735016070D+00 , & - 0.6845006259971457D-02 , 0.8228895413370239D-04 , - 0.4946152023844475D-06 , & 0.1200611440513190D-08 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.2639522929552103D+00 , - 0.6745468727543254D-02 , & 0.8038690460918961D-04 , - 0.4784612825387489D-06 , 0.1149163385061327D-08 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.2619909660887603D+00 , - 0.6646783422202571D-02 , 0.7852486100091853D-04 , & - 0.4628460567948706D-06 , 0.1100056596589864D-08 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.2600227116579057D+00 , & - 0.6548979793845537D-02 , 0.7670237813489309D-04 , - 0.4477524541102077D-06 , & 0.1053179885744750D-08 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.2580485271436418D+00 , - 0.6452085164089713D-02 , & 0.7491898805127729D-04 , - 0.4331638454469621D-06 , 0.1008427512150815D-08 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.2560693879494534D+00 , - 0.6356124790537716D-02 , 0.7317420227771141D-04 , & - 0.4190640407122907D-06 , 0.9656989109326190D-09 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.2540862466939701D+00 , & - 0.6261121931768214D-02 , 0.7146751397956286D-04 , - 0.4054372848990458D-06 , & 0.9248984332185787D-09 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.2521000325948833D+00 , - 0.6167097912801633D-02 , & 0.6979839999136575D-04 , - 0.3922682535174432D-06 , 0.8859350999026950D-09 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.2501116509398837D+00 , - 0.6074072190808714D-02 , 0.6816632273371844D-04 , & - 0.3795420474007130D-06 , 0.8487223679763527D-09 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.2481219826403934D+00 , & - 0.5982062420849628D-02 , 0.6657073201990310D-04 , - 0.3672441869610214D-06 , & 0.8131779087787301D-09 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.2461318838639009D+00 , - 0.5891084521449922D-02 , & 0.6501106675646878D-04 , - 0.3553606059656798D-06 , 0.7792233975485489D-09 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.2441421857407526D+00 , - 0.5801152739837057D-02 , 0.6348675654197899D-04 , & - 0.3438776448978197D-06 , 0.7467843136922563D-09 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.2421536941413251D+00 , & - 0.5712279716677925D-02 , 0.6199722316807657D-04 , - 0.3327820439603209D-06 , & 0.7157897512143852D-09 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.2401671895195648D+00 , - 0.5624476550173202D-02 , & 0.6054188202695264D-04 , - 0.3220609357767590D-06 , 0.6861722387848702D-09 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.2381834268189731D+00 , - 0.5537752859379153D-02 , 0.5912014342923616D-04 , & - 0.3117018378385033D-06 , 0.6578675689455938D-09 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.2362031354371985D+00 , & - 0.5452116846641054D-02 , 0.5773141383623673D-04 , - 0.3016926447427810D-06 , & 0.6308146359844566D-09 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.2342270192455025D+00 , - 0.5367575359035526D-02 , & 0.5637509701038847D-04 , - 0.2920216202625572D-06 , 0.6049552820299627D-09 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.2322557566594675D+00 , - 0.5284133948730866D-02 , 0.5505059508764614D-04 , & - 0.2826773892853750D-06 , 0.5802341509426348D-09 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.2302900007574202D+00 , & - 0.5201796932185827D-02 , 0.5375730957548747D-04 , - 0.2736489296549009D-06 , & 0.5565985496017240D-09 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.2283303794431649D+00 , - 0.5120567448117730D-02 , & 0.5249464228007314D-04 , - 0.2649255639457593D-06 , 0.5339983162066148D-09 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.2263774956497330D+00 , - 0.5040447514180615D-02 , 0.5126199616601130D-04 , & - 0.2564969511993324D-06 , 0.5123856952322096D-09 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.2244319275809745D+00 , & - 0.4961438082302993D-02 , 0.5005877615206487D-04 , - 0.2483530786455001D-06 , & 0.4917152186963367D-09 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.2224942289879358D+00 , - 0.4883539092643363D-02 , & 0.4888438984603297D-04 , - 0.2404842534328184D-06 , 0.4719435934150798D-09 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.2205649294770977D+00 , - 0.4806749526129295D-02 , 0.4773824822192791D-04 , & - 0.2328810943873406D-06 , 0.4530295939387822D-09 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.2186445348476554D+00 , & - 0.4731067455553005D-02 , 0.4661976624245883D-04 , - 0.2255345238181660D-06 , & 0.4349339608774592D-09 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.2167335274551584D+00 , - 0.4656490095203044D-02 , & 0.4552836342972544D-04 , - 0.2184357593858681D-06 , 0.4176193043395172D-09 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.2148323665989391D+00 , - 0.4583013849017713D-02 , 0.4446346438691550D-04 , & - 0.2115763060481496D-06 , 0.4010500122220090D-09 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.2129414889308827D+00 , & - 0.4510634357251345D-02 , 0.4342449927369249D-04 , - 0.2049479480954325D-06 , & 0.3851921631042522D-09 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.2110613088832081D+00 , - 0.4439346541649699D-02 , & 0.4241090423785382D-04 , - 0.1985427412875731D-06 , 0.3700134435095219D-09 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.2091922191130486D+00 , - 0.4369144649135391D-02 , 0.4142212180573599D-04 , & - 0.1923530051015072D-06 , 0.3554830693117331D-09 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.2073345909617311D+00 , & - 0.4300022294008322D-02 , 0.4045760123373913D-04 , - 0.1863713150983492D-06 , & 0.3415717110755785D-09 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.2054887749267676D+00 , - 0.4231972498670055D-02 , & 0.3951679882324414D-04 , - 0.1805904954173054D-06 , 0.3282514231295578D-09 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.2036551011446820D+00 , - 0.4164987732884396D-02 , 0.3859917820109683D-04 , & - 0.1750036114026931D-06 , 0.3154955761817102D-09 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.2018338798829030D+00 , & - 0.4099059951589593D-02 , 0.3770421056773769D-04 , - 0.1696039623693781D-06 , & 0.3032787932977011D-09 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.2000254020390509D+00 , - 0.4034180631280226D-02 , & 0.3683137491496161D-04 , - 0.1643850745110493D-06 , 0.2915768890702272D-09 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.1982299396460583D+00 , - 0.3970340804979437D-02 , 0.3598015821520295D-04 , & - 0.1593406939549410D-06 , 0.2803668118175588D-09 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.1964477463816512D+00 , & - 0.3907531095824253D-02 , 0.3515005558415139D-04 , - 0.1544647799658699D-06 , & 0.2696265886573908D-09 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.1946790580808190D+00 , - 0.3845741749288601D-02 , & 0.3434057041841909D-04 , - 0.1497514983017782D-06 , 0.2593352733101165D-09 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.1929240932499870D+00 , - 0.3784962664070404D-02 , 0.3355121450989751D-04 , & - 0.1451952147223692D-06 , 0.2494728964931636D-09 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.1911830535816980D+00 , & - 0.3725183421670436D-02 , 0.3278150813836091D-04 , - 0.1407904886518627D-06 , & 0.2400204187751425D-09 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.1894561244686916D+00 , - 0.3666393314691999D-02 , & 0.3203098014379853D-04 , - 0.1365320669964067D-06 , 0.2309596857653426D-09 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.1877434755163483D+00 , - 0.3608581373891288D-02 , 0.3129916797987996D-04 , & - 0.1324148781162183D-06 , 0.2222733855204773D-09 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.1860452610525480D+00 , & - 0.3551736394009373D-02 , 0.3058561774988904D-04 , - 0.1284340259521336D-06 , & 0.2139450080566772D-09 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.1843616206340638D+00 , - 0.3495846958417244D-02 , & 0.2988988422639104D-04 , - 0.1245847843058767D-06 , 0.2059588068604732D-09 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.1826926795486844D+00 , - 0.3440901462606064D-02 , 0.2921153085583285D-04 , & - 0.1208625912730378D-06 , 0.1982997622979687D-09 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.1810385493123228D+00 , & - 0.3386888136554829D-02 , 0.2855012974920918D-04 , - 0.1172630438274493D-06 , & 0.1909535468265545D-09 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.1793993281604408D+00 , - 0.3333795066008375D-02 , & 0.2790526165987099D-04 , - 0.1137818925554124D-06 , 0.1839064919184513D-09 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.1777751015331724D+00 , - 0.3281610212698351D-02 , 0.2727651594948962D-04 , & - 0.1104150365379793D-06 , 0.1771455566099815D-09 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.1761659425535938D+00 , & - 0.3230321433540114D-02 , 0.2666349054313609D-04 , - 0.1071585183793111D-06 , & 0.1706582975948946D-09 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.1745719124986360D+00 , - 0.3179916498838204D-02 , & 0.2606579187437988D-04 , - 0.1040085193789477D-06 , 0.1644328407842339D-09 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.1729930612622013D+00 , - 0.3130383109533235D-02 , 0.2548303482126257D-04 , & - 0.1009613548456889D-06 , 0.1584578542592164D-09 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.1714294278100770D+00 , & - 0.3081708913522377D-02 , 0.2491484263394826D-04 , - 0.9801346955063733D-07 , & 0.1527225225473158D-09 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.1698810406263020D+00 , - 0.3033881521085652D-02 , & 0.2436084685480979D-04 , - 0.9516143331686128D-07 , 0.1472165221553313D-09 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.1683479181506788D+00 , - 0.2986888519449751D-02 , 0.2382068723166289D-04 , & - 0.9240193674303420D-07 , 0.1419299982965851D-09 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.1668300692071670D+00 , & - 0.2940717486520728D-02 , 0.2329401162481847D-04 , - 0.8973178705833592D-07 , & 0.1368535427525984D-09 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.1653274934229287D+00 , - 0.2895356003816236D-02 , & 0.2278047590858054D-04 , - 0.8714790410582936D-07 , 0.1319781728126182D-09 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.1638401816378448D+00 , - 0.2850791668627876D-02 , 0.2227974386778240D-04 , & - 0.8464731645149678D-07 , 0.1272953112372729D-09 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.1623681163043421D+00 , & - 0.2807012105443236D-02 , 0.2179148708991278D-04 , - 0.8222715761606546D-07 , & 0.1227967671953365D-09 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.1609112718774123D+00 , - 0.2764004976656894D-02 , & 0.2131538485335095D-04 , - 0.7988466242673849D-07 , 0.1184747181251889D-09 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.1594696151947263D+00 , - 0.2721757992598835D-02 , 0.2085112401219485D-04 , & - 0.7761716348592522D-07 , 0.1143216924750029D-09 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.1580431058467897D+00 , & - 0.2680258920908439D-02 , 0.2039839887813756D-04 , - 0.7542208775407179D-07 , & 0.1103305532780392D-09 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.1566316965370908D+00 , - 0.2639495595281021D-02 , & 0.1995691109981276D-04 , - 0.7329695324367526D-07 , 0.1064944825216086D-09 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.1552353334322324D+00 , - 0.2599455923613683D-02 , 0.1952636954000557D-04 , & - 0.7123936582159289D-07 , 0.1028069662703839D-09 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.1538539565020569D+00 , & - 0.2560127895576345D-02 , 0.1910649015109592D-04 , - 0.6924701611676342D-07 , & 0.9926178050671957D-10 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.1524874998497940D+00 , - 0.2521499589633189D-02 , & 0.1869699584907718D-04 , - 0.6731767653048589D-07 , 0.9585297765252891D-10 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.1511358920322726D+00 , - 0.2483559179538849D-02 , 0.1829761638646616D-04 , & - 0.6544919834641691D-07 , 0.9257487373904170D-10 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.1497990563702729D+00 , & - 0.2446294940333376D-02 , 0.1790808822440184D-04 , - 0.6363950893749729D-07 , & 0.8942203619249218D-10 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.1484769112490931D+00 , - 0.2409695253858882D-02 , & 0.1752815440420435D-04 , - 0.6188660906703722D-07 , 0.8638927220536790D-10 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.1471693704094289D+00 , - 0.2373748613820280D-02 , 0.1715756441864779D-04 , & - 0.6018857028123778D-07 , 0.8347161766439500D-10 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.1458763432286756D+00 , & - 0.2338443630411810D-02 , 0.1679607408318027D-04 , - 0.5854353239046725D-07 , & 0.8066432660788088D-10 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.1445977349927707D+00 , - 0.2303769034530171D-02 , & 0.1644344540730562D-04 , - 0.5694970103665003D-07 , 0.7796286118640304D-10 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.1433334471587194D+00 , - 0.2269713681594818D-02 , 0.1609944646632723D-04 , & - 0.5540534534418891D-07 , 0.7536288210216235D-10 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.1420833776079296D+00 , & - 0.2236266554994612D-02 , 0.1576385127363267D-04 , - 0.5390879565186556D-07 , & 0.7286023950351873D-10 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.1408474208905195D+00 , - 0.2203416769179984D-02 , & 0.1543643965368810D-04 , - 0.5245844132323857D-07 , 0.7045096431243981D-10 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.1396254684607490D+00 , - 0.2171153572418707D-02 , 0.1511699711589367D-04 , & - 0.5105272863309604D-07 , 0.6813125996368576D-10 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.1384174089037460D+00 , & - 0.2139466349232966D-02 , 0.1480531472943992D-04 , - 0.4969015872758178D-07 , & 0.6589749453562698D-10 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.1372231281536858D+00 , - 0.2108344622534334D-02 , & 0.1450118899928856D-04 , - 0.4836928565565305D-07 , 0.6374619325357278D-10 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.1360425097036160D+00 , - 0.2077778055473310D-02 , 0.1420442174339551D-04 , & - 0.4708871446960520D-07 , 0.6167403134747766D-10 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.1348754348070926D+00 , & - 0.2047756453018778D-02 , 0.1391481997127647D-04 , - 0.4584709939243107D-07 , & 0.5967782724676395D-10 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.1337217826718193D+00 , - 0.2018269763282576D-02 , & 0.1363219576400903D-04 , - 0.4464314204985135D-07 , 0.5775453609587833D-10 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.1325814306454664D+00 , - 0.1989308078603418D-02 , 0.1335636615575265D-04 , & - 0.4347558976489779D-07 , 0.5590124357500244D-10 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.1314542543938739D+00 , & - 0.1960861636404398D-02 , 0.1308715301686303D-04 , - 0.4234323391300124D-07 , & 0.5411516001113333D-10 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.1303401280718097D+00 , - 0.1932920819836909D-02 , & 0.1282438293866231D-04 , - 0.4124490833556761D-07 , 0.5239361476545128D-10 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.1292389244864864D+00 , - 0.1905476158224039D-02 , 0.1256788711992472D-04 , & - 0.4017948781010126D-07 , 0.5073405088362227D-10 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.1281505152540247D+00 , & - 0.1878518327315515D-02 , 0.1231750125512640D-04 , - 0.3914588657497640D-07 , & 0.4913401999632620D-10 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.1270747709490530D+00 , - 0.1852038149365861D-02 , & 0.1207306542450180D-04 , - 0.3814305690701311D-07 , 0.4759117745793600D-10 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.1260115612476431D+00 , - 0.1826026593047109D-02 , 0.1183442398594430D-04 , & - 0.3716998775007287D-07 , 0.4610327771187718D-10 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.1249607550637541D+00 , & - 0.1800474773206336D-02 , 0.1160142546877785D-04 , - 0.3622570339292245D-07 , & 0.4466816987174032D-10 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.1239222206793981D+00 , - 0.1775373950478743D-02 , & 0.1137392246942836D-04 , - 0.3530926219469439D-07 , 0.4328379350779648D-10 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.1228958258686976D+00 , - 0.1750715530765641D-02 , 0.1115177154901119D-04 , & - 0.3441975535629528D-07 , 0.4194817462903966D-10 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.1218814380160310D+00 , & - 0.1726491064586804D-02 , 0.1093483313285066D-04 , - 0.3355630573617854D-07 , & 0.4065942185138818D-10 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.1208789242284404D+00 , - 0.1702692246315867D-02 , & 0.1072297141194010D-04 , - 0.3271806670893680D-07 , 0.3941572274312428D-10 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.1198881514425043D+00 , - 0.1679310913307598D-02 , 0.1051605424635168D-04 , & - 0.3190422106523248D-07 , 0.3821534033911188D-10 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.1189089865258293D+00 , & - 0.1656339044924584D-02 , 0.1031395307059401D-04 , - 0.3111397995160634D-07 , & 0.3705660981571313D-10 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.1179412963733576D+00 , - 0.1633768761471329D-02 , & 0.1011654280091926D-04 , - 0.3034658184877375D-07 , 0.3593793531875405D-10 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.1169849479986568D+00 , - 0.1611592323042918D-02 , 0.9923701744574045D-05 , & - 0.2960129158704871D-07 , 0.3485778693724468D-10 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.1160398086203661D+00 , & - 0.1589802128295166D-02 , 0.9735311510986715D-05 , - 0.2887739939758266D-07 , & 0.3381469781592130D-10 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.1151057457439688D+00 , - 0.1568390713142904D-02 , & 0.9551256924881942D-05 , - 0.2817421999815298D-07 , 0.3280726140002537D-10 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.1141826272390468D+00 , - 0.1547350749392353D-02 , 0.9371425941307118D-05 , & - 0.2749109171225957D-07 , 0.3183412880602852D-10 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.1132703214121968D+00 , & - 0.1526675043313909D-02 , 0.9195709562559683D-05 , - 0.2682737562035734D-07 , & 0.3089400631236233D-10 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.1123686970757516D+00 , - 0.1506356534160627D-02 , & 0.9024001756995533D-05 , - 0.2618245474206319D-07 , 0.2998565296446034D-10 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.1114776236124702D+00 , - 0.1486388292637843D-02 , 0.8856199379701254D-05 , & - 0.2555573324823196D-07 , 0.2910787828872132D-10 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.1105969710363380D+00 , & - 0.1466763519328756D-02 , 0.8692202095008047D-05 , - 0.2494663570182106D-07 , & 0.2825954011024879D-10 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.1097266100496481D+00 , - 0.1447475543081191D-02 , & 0.8531912300829338D-05 , - 0.2435460632651930D-07 , 0.2743954246949659D-10 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.1088664120964792D+00 , - 0.1428517819359402D-02 , 0.8375235054793990D-05 , & - 0.2377910830212021D-07 , 0.2664683363314847D-10 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.1080162494127311D+00 , & - 0.1409883928565581D-02 , 0.8222078002154330D-05 , - 0.2321962308568381D-07 , & 0.2588040419482191D-10 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.1071759950728476D+00 , - 0.1391567574334882D-02 , & 0.8072351305441968D-05 , - 0.2267564975754568D-07 , 0.2513928526137799D-10 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.1063455230333696D+00 , - 0.1373562581807930D-02 , 0.7925967575846863D-05 , & - 0.2214670439127613D-07 , 0.2442254672083663D-10 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.1055247081734262D+00 , & - 0.1355862895883874D-02 , 0.7782841806288967D-05 , - 0.2163231944670572D-07 , & 0.2372929558806794D-10 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.1047134263323196D+00 , - 0.1338462579457932D-02 , & 0.7642891306159244D-05 , - 0.2113204318519069D-07 , 0.2305867442464793D-10 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.1039115543443058D+00 , - 0.1321355811646121D-02 , 0.7506035637698486D-05 , & - 0.2064543910629523D-07 , 0.2240985982940901D-10 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.1031189700706982D+00 , & - 0.1304536886000255D-02 , 0.7372196553986363D-05 , - 0.2017208540511105D-07 , & 0.2178206099640073D-10 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.1023355524294112D+00 , - 0.1288000208716008D-02 , & 0.7241297938511645D-05 , - 0.1971157444945869D-07 , 0.2117451833712931D-10 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.1015611814220423D+00 , - 0.1271740296836342D-02 , 0.7113265746292218D-05 , & - 0.1926351227623483D-07 , 0.2058650216408674D-10 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.1007957381586340D+00 , & - 0.1255751776453342D-02 , 0.6988027946519667D-05 , - 0.1882751810621684D-07 , & 0.2001731143274806D-10 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.1000391048801792D+00 , - 0.1240029380909896D-02 , & 0.6865514466692791D-05 , - 0.1840322387662732D-07 , 0.1946627253931132D-10 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.9929116497900271D-01 , - 0.1224567949003934D-02 , 0.6745657138214258D-05 , & - 0.1799027379081798D-07 , 0.1893273817162196D-10 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.9855180301710245D-01 , & - 0.1209362423196867D-02 , 0.6628389643418425D-05 , - 0.1758832388443567D-07 , & 0.1841608621082306D-10 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.9782090474256197D-01 , - 0.1194407847828364D-02 , & 0.6513647464002370D-05 , - 0.1719704160746887D-07 , 0.1791571868140427D-10 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.9709835710409409D-01 , - 0.1179699367338560D-02 , 0.6401367830826140D-05 , & - 0.1681610542157534D-07 , 0.1743106074741055D-10 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.9638404826384545D-01 , & - 0.1165232224499998D-02 , 0.6291489675057578D-05 , - 0.1644520441214239D-07 , & 0.1696155975271219D-10 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.9567786760851846D-01 , - 0.1151001758660232D-02 , & 0.6183953580628441D-05 , - 0.1608403791452337D-07 , 0.1650668430330473D-10 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.9497970575890513D-01 , - 0.1137003403996615D-02 , 0.6078701737973751D-05 , & - 0.1573231515393008D-07 , 0.1606592338972238D-10 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.9428945457791377D-01 , & - 0.1123232687784547D-02 , 0.5975677899025389D-05 , - 0.1538975489847587D-07 , & 0.1563878554773420D-10 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.9360700717714807D-01 , - 0.1109685228679979D-02 , & 0.5874827333428842D-05 , - 0.1505608512487568D-07 , 0.1522479805557133D-10 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.9293225792215423D-01 , - 0.1096356735017963D-02 , 0.5776096785959559D-05 , & - 0.1473104269634887D-07 , 0.1482350616604071D-10 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.9226510243635505D-01 , & - 0.1083243003127249D-02 , 0.5679434435104159D-05 , - 0.1441437305225333D-07 , & 0.1443447237191905D-10 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.9160543760377748D-01 , - 0.1070339915662461D-02 , & 0.5584789852783192D-05 , - 0.1410582990902900D-07 , 0.1405727570313379D-10 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.9095316157062430D-01 , - 0.1057643439954374D-02 , 0.5492113965185997D-05 , & - 0.1380517497202594D-07 , 0.1369151105428639D-10 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.9030817374575757D-01 , & - 0.1045149626379020D-02 , 0.5401359014690628D-05 , - 0.1351217765781271D-07 , & 0.1333678854114667D-10 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.8967037480016019D-01 , - 0.1032854606746447D-02 , & 0.5312478522843599D-05 , - 0.1322661482658209D-07 , 0.1299273288481990D-10 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.8903966666541030D-01 , - 0.1020754592709132D-02 , 0.5225427254368678D-05 , & - 0.1294827052426365D-07 , 0.1265898282232078D-10 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.8841595253126246D-01 , & - 0.1008845874191352D-02 , 0.5140161182184729D-05 , - 0.1267693573400268D-07 , & 0.1233519054239264D-10 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.8779913684235949D-01 , - 0.9971248178393274D-03 , & 0.5056637453402634D-05 , - 0.1241240813664305D-07 , 0.1202102114542161D-10 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.8718912529414309D-01 , - 0.9855878654928562D-03 , 0.4974814356278331D-05 , & - 0.1215449187988627D-07 , 0.1171615212637439D-10 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.8658582482798947D-01 , & - 0.9742315326783466D-03 , 0.4894651288094751D-05 , - 0.1190299735579682D-07 , & 0.1142027287972247D-10 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.8598914362566729D-01 , - 0.9630524071243896D-03 , & 0.4816108723953955D-05 , - 0.1165774098635966D-07 , 0.1113308422538860D-10 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.8539899110310108D-01 , - 0.9520471472990357D-03 , 0.4739148186448801D-05 , & - 0.1141854501677078D-07 , 0.1085429795475774D-10 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.8481527790352784D-01 , & - 0.9412124809697214D-03 , 0.4663732216195841D-05 , - 0.1118523731618787D-07 , & 0.1058363639587562D-10 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.8423791589007235D-01 , - 0.9305452037857165D-03 , & 0.4589824343204793D-05 , - 0.1095765118565885D-07 , 0.1032083199697787D-10 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.8366681813777795D-01 , - 0.9200421778831581D-03 , 0.4517389059062040D-05 , & - 0.1073562517296117D-07 , 0.1006562692753695D-10 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.8310189892515858D-01 , & - 0.9097003305132000D-03 , 0.4446391789909127D-05 , - 0.1051900289410328D-07 , & 0.9817772696060905D-11 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.8254307372524519D-01 , - 0.8995166526922653D-03 , & 0.4376798870188248D-05 , - 0.1030763286122287D-07 , 0.9577029783885070D-11 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.8199025919624044D-01 , - 0.8894881978757428D-03 , 0.4308577517142176D-05 , & - 0.1010136831666772D-07 , 0.9343167294276991D-11 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.8144337317175870D-01 , & - 0.8796120806541568D-03 , 0.4241695806042218D-05 , - 0.9900067073013639D-08 , & 0.9115962616163819D-11 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.8090233465070863D-01 , - 0.8698854754722010D-03 , & 0.4176122646126899D-05 , - 0.9703591358806959D-08 , 0.8895201101848582D-11 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.8036706378682068D-01 , - 0.8603056153701063D-03 , 0.4111827757229015D-05 , & - 0.9511807669811805D-08 , 0.8680675758094497D-11 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.7983748187790558D-01 , & - 0.8508697907481923D-03 , 0.4048781647077831D-05 , - 0.9324586625574452D-08 , & 0.8472186950009776D-11 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.7931351135479904D-01 , - 0.8415753481532933D-03 , & 0.3986955589250370D-05 , - 0.9141802831087919D-08 , 0.8269542117153485D-11 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.7879507577006972D-01 , - 0.8324196890877747D-03 , 0.3926321601758897D-05 , & - 0.8963334743382549D-08 , 0.8072555501345310D-11 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.7828209978649575D-01 , & - 0.8234002688406602D-03 , 0.3866852426254837D-05 , - 0.8789064542855226D-08 , & 0.7881047885665051D-11 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.7777450916533160D-01 , - 0.8145145953406682D-03 , & 0.3808521507831621D-05 , - 0.8618878009161717D-08 , 0.7694846344156020D-11 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.7727223075441662D-01 , - 0.8057602280314494D-03 , 0.3751302975412459D-05 , & - 0.8452664401511582D-08 , 0.7513784001777036D-11 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.7677519247607639D-01 , & - 0.7971347767676864D-03 , 0.3695171622699706D-05 , - 0.8290316343184995D-08 , & 0.7337699804141676D-11 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.7628332331492615D-01 , - 0.7886359007332884D-03 , & 0.3640102889678484D-05 , - 0.8131729710139158D-08 , 0.7166438296646448D-11 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.7579655330553173D-01 , - 0.7802613073804225D-03 , 0.3586072844652703D-05 , & - 0.7976803523537225D-08 , 0.6999849412567194D-11 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.7531481351997116D-01 , & - 0.7720087513895546D-03 , 0.3533058166800627D-05 , - 0.7825439846061907D-08 , & 0.6837788269745126D-11 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.7483803605530806D-01 , - 0.7638760336501886D-03 , & 0.3481036129234990D-05 , - 0.7677543681874643D-08 , 0.6680114975494975D-11 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.7436615402098291D-01 , - 0.7558610002617950D-03 , 0.3429984582551037D-05 , & - 0.7533022880079340D-08 , 0.6526694439374922D-11 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.7389910152618000D-01 , & - 0.7479615415555017D-03 , 0.3379881938854376D-05 , - 0.7391788041580346D-08 , & 0.6377396193503704D-11 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.7343681366711807D-01 , - 0.7401755911350744D-03 , & 0.3330707156246785D-05 , - 0.7253752429186502D-08 , 0.6232094220077186D-11 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.7297922651433109D-01 , - 0.7325011249378381D-03 , 0.3282439723762714D-05 , & - 0.7118831880859714D-08 , 0.6090666785797278D-11 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.7252627709992450D-01 , & - 0.7249361603148042D-03 , 0.3235059646740589D-05 , - 0.6986944725985066D-08 , & 0.5952996282911613D-11 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.7207790340485587D-01 , - 0.7174787551302906D-03 , & 0.3188547432619640D-05 , - 0.6858011704560788D-08 , 0.5818969076592898D-11 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.7163404434617190D-01 , - 0.7101270068795282D-03 , 0.3142884077142881D-05 , & - 0.6731955889183450D-08 , 0.5688475358372589D-11 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.7119463976431338D-01 , & - 0.7028790518255191D-03 , 0.3098051050963301D-05 , - 0.6608702609749382D-08 , & 0.5561409005396137D-11 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.7075963041042557D-01 , - 0.6957330641537381D-03 , & 0.3054030286635175D-05 , - 0.6488179380757087D-08 , 0.5437667445239097D-11 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.7032895793371138D-01 , - 0.6886872551448134D-03 , 0.3010804165981669D-05 , & - 0.6370315831122297D-08 , 0.5317151526056938D-11 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.6990256486883833D-01 , & - 0.6817398723649256D-03 , 0.2968355507827942D-05 , - 0.6255043636414924D-08 , & 0.5199765391845695D-11 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.6948039462336734D-01 , - 0.6748891988730243D-03 , & 0.2926667556085639D-05 , - 0.6142296453421382D-08 , 0.5085416362591770D-11 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.6906239146530685D-01 , - 0.6681335524460117D-03 , 0.2885723968186572D-05 , & - 0.6032009856968527D-08 , 0.4974014819126591D-11 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.6864850051067768D-01 , & - 0.6614712848197531D-03 , 0.2845508803845060D-05 , - 0.5924121278901399D-08 , & 0.4865474092465772D-11 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.6823866771118174D-01 , - 0.6549007809469419D-03 , & 0.2806006514146616D-05 , - 0.5818569949155456D-08 , 0.4759710357464285D-11 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.6783283984194712D-01 , - 0.6484204582709980D-03 , 0.2767201930950519D-05 , & - 0.5715296838840563D-08 , 0.4656642530602223D-11 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.6743096448936174D-01 , & - 0.6420287660157840D-03 , 0.2729080256597220D-05 , - 0.5614244605264144D-08 , & 0.4556192171729946D-11 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.6703299003901679D-01 , - 0.6357241844911882D-03 , & 0.2691627053914177D-05 , - 0.5515357538831767D-08 , 0.4458283389618460D-11 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.6663886566370485D-01 , - 0.6295052244132057D-03 , 0.2654828236504281D-05 , & - 0.5418581511737446D-08 , 0.4362842751137088D-11 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.6624854131156825D-01 , & - 0.6233704262397680D-03 , 0.2618670059318044D-05 , - 0.5323863928405747D-08 , & 0.4269799193936679D-11 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.6586196769432973D-01 , - 0.6173183595208542D-03 , & 0.2583139109494116D-05 , - 0.5231153677603767D-08 , 0.4179083942475461D-11 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.6547909627564633D-01 , - 0.6113476222631832D-03 , 0.2548222297463570D-05 , & - 0.5140401086172092D-08 , 0.4090630427259712D-11 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.6509987925954097D-01 , & - 0.6054568403084879D-03 , 0.2513906848306258D-05 , - 0.5051557874307302D-08 , & 0.4004374207159415D-11 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.6472426957901938D-01 , - 0.5996446667266102D-03 , & 0.2480180293359949D-05 , - 0.4964577112360429D-08 , 0.3920252894691839D-11 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.6435222088474189D-01 , - 0.5939097812212044D-03 , 0.2447030462064419D-05 , & - 0.4879413179072312D-08 , 0.3838206084129832D-11 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.6398368753384867D-01 , & - 0.5882508895491711D-03 , 0.2414445474040947D-05 , - 0.4796021721212619D-08 , & 0.3758175282336761D-11 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.6361862457890315D-01 , - 0.5826667229530069D-03 , & 0.2382413731397401D-05 , - 0.4714359614565809D-08 , 0.3680103842211723D-11 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.6325698775695301D-01 , - 0.5771560376057674D-03 , 0.2350923911252009D-05 , & - 0.4634384926215740D-08 , 0.3603936898639402D-11 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.6289873347876239D-01 , & - 0.5717176140691137D-03 , 0.2319964958473244D-05 , - 0.4556056878092187D-08 , & 0.3529621306852149D-11 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.6254381881809266D-01 , - 0.5663502567624270D-03 , & 0.2289526078620161D-05 , - 0.4479335811712721D-08 , 0.3457105583087906D-11 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.6219220150119087D-01 , - 0.5610527934449688D-03 , 0.2259596731088984D-05 , & - 0.4404183154105539D-08 , 0.3386339847476975D-11 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.6184383989637411D-01 , & - 0.5558240747092328D-03 , 0.2230166622451447D-05 , - 0.4330561384851799D-08 , & 0.3317275769050880D-11 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.6149869300375357D-01 , - 0.5506629734858485D-03 , & 0.2201225699982413D-05 , - 0.4258434004215618D-08 , 0.3249866512795579D-11 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.6115672044510287D-01 , - 0.5455683845598486D-03 , 0.2172764145371443D-05 , & - 0.4187765502324172D-08 , 0.3184066688668332D-11 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.6081788245381069D-01 , & - 0.5405392240972029D-03 , 0.2144772368608434D-05 , - 0.4118521329350803D-08 , & 0.3119832302491352D-11 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.6048213986506285D-01 , - 0.5355744291834119D-03 , & 0.2117241002048676D-05 , - 0.4050667866690363D-08 , 0.3057120708669362D-11 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.6014945410606896D-01 , - 0.5306729573713385D-03 , 0.2090160894638693D-05 , & - 0.3984172399061264D-08 , 0.2995890564632061D-11 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.5981978718646717D-01 , & - 0.5258337862399089D-03 , 0.2063523106307669D-05 , - 0.3919003087524001D-08 , & 0.2936101786952951D-11 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.5949310168884585D-01 , - 0.5210559129626102D-03 , & 0.2037318902515202D-05 , - 0.3855128943374248D-08 , 0.2877715509069974D-11 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.5916936075944505D-01 , - 0.5163383538864247D-03 , 0.2011539748955201D-05 , & - 0.3792519802890206D-08 , 0.2820694040553918D-11 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.5884852809890755D-01 , & - 0.5116801441192032D-03 , 0.1986177306402252D-05 , - 0.3731146302883916D-08 , & 0.2765000827846322D-11 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.5853056795324416D-01 , - 0.5070803371275296D-03 , & 0.1961223425707718D-05 , - 0.3670979857054889D-08 , 0.2710600416432140D-11 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.5821544510489463D-01 , - 0.5025380043432404D-03 , 0.1936670142932954D-05 , & - 0.3611992633099589D-08 , 0.2657458414375269D-11 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.5790312486392878D-01 , & - 0.4980522347790165D-03 , 0.1912509674618733D-05 , - 0.3554157530557876D-08 , & 0.2605541457170211D-11 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.5759357305939089D-01 , - 0.4936221346528936D-03 , & 0.1888734413187116D-05 , - 0.3497448159371565D-08 , 0.2554817173859407D-11 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.5728675603072303D-01 , - 0.4892468270206396D-03 , 0.1865336922467586D-05 , & - 0.3441838819121033D-08 , 0.2505254154359283D-11 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.5698264061941894D-01 , & - 0.4849254514178435D-03 , 0.1842309933353952D-05 , - 0.3387304478939388D-08 , & 0.2456821917967627D-11 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.5668119416071268D-01 , - 0.4806571635089226D-03 , & 0.1819646339575290D-05 , - 0.3333820758052132D-08 , 0.2409490882982642D-11 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.5638238447509687D-01 , - 0.4764411347398787D-03 , 0.1797339193561128D-05 , & - 0.3281363906881393D-08 , 0.2363232337355420D-11 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.5608617986168983D-01 , & - 0.4722765520231385D-03 , 0.1775381702548393D-05 , - 0.3229910789048475D-08 , & 0.2318018410647390D-11 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.5579254908824329D-01 , - 0.4681626173808717D-03 , & 0.1753767224538512D-05 , - 0.3179438863342089D-08 , 0.2273822046449100D-11 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.5550146138482370D-01 , - 0.4640985476457861D-03 , 0.1732489264625824D-05 , & - 0.3129926166864923D-08 , 0.2230616976308344D-11 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.5521288643575141D-01 , & - 0.4600835741429675D-03 , 0.1711541471291321D-05 , - 0.3081351298393642D-08 , & 0.2188377694297832D-11 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.5492679437212505D-01 , - 0.4561169423852573D-03 , & 0.1690917632830574D-05 , - 0.3033693402336506D-08 , 0.2147079432540845D-11 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.5464315576441503D-01 , - 0.4521979117748920D-03 , 0.1670611673876033D-05 , & - 0.2986932153185834D-08 , 0.2106698137587286D-11 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.5436194161518820D-01 , & - 0.4483257553120733D-03 , 0.1650617652014910D-05 , - 0.2941047740457337D-08 , & 0.2067210447615263D-11 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.5408312335196455D-01 , - 0.4444997593103514D-03 , & 0.1630929754500134D-05 , - 0.2896020854100572D-08 , 0.2028593670427697D-11 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.5380667282012651D-01 , - 0.4407192231176137D-03 , 0.1611542295046425D-05 , & - 0.2851832670353236D-08 , 0.1990825762204864D-11 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.5353256227607138D-01 , & - 0.4369834588450818D-03 , 0.1592449710721516D-05 , - 0.2808464838051682D-08 , & 0.1953885307006664D-11 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.5326076438035740D-01 , - 0.4332917911008863D-03 , & 0.1573646558913852D-05 , - 0.2765899465347844D-08 , 0.1917751496968712D-11 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.5299125219102160D-01 , - 0.4296435567304437D-03 , 0.1555127514385938D-05 , & - 0.2724119106843745D-08 , 0.1882404113186422D-11 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.5272399915698570D-01 , & - 0.4260381045624166D-03 , 0.1536887366405710D-05 , - 0.2683106751118558D-08 , & 0.1847823507252612D-11 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.5245897911163543D-01 , - 0.4224747951612225D-03 , & 0.1518921015958898D-05 , - 0.2642845808646343D-08 , 0.1813990583433333D-11 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.5219616626639052D-01 , - 0.4189530005836614D-03 , 0.1501223473029235D-05 , & - 0.2603320100068569D-08 , 0.1780886781440087D-11 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.5193553520449545D-01 , & - 0.4154721041424631D-03 , 0.1483789853958296D-05 , - 0.2564513844838851D-08 , & 0.1748494059799723D-11 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.5167706087486279D-01 , - 0.4120315001745113D-03 , & 0.1466615378872827D-05 , - 0.2526411650206738D-08 , 0.1716794879783415D-11 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.5142071858603174D-01 , - 0.4086305938144337D-03 , 0.1449695369181379D-05 , & - 0.2488998500537387D-08 , 0.1685772189880622D-11 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.5116648400024583D-01 , & - 0.4052688007734935D-03 , 0.1433025245138571D-05 , - 0.2452259746956672D-08 , & 0.1655409410798550D-11 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.5091433312755969D-01 , - 0.4019455471225714D-03 , & 0.1416600523469944D-05 , - 0.2416181097300543D-08 , 0.1625690420959748D-11 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.5066424232018377D-01 , - 0.3986602690817205D-03 , 0.1400416815067716D-05 , & - 0.2380748606383646D-08 , 0.1596599542499248D-11 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.5041618826679758D-01 , & - 0.3954124128128623D-03 , 0.1384469822740127D-05 , - 0.2345948666545095D-08 , & 0.1568121527718362D-11 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.5017014798702275D-01 , - 0.3922014342178980D-03 , & 0.1368755339023789D-05 , - 0.2311767998485071D-08 , 0.1540241545996359D-11 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.4992609882598028D-01 , - 0.3890267987412069D-03 , 0.1353269244053045D-05 , & - 0.2278193642374113D-08 , 0.1512945171136736D-11 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.4968401844892447D-01 , & - 0.3858879811763573D-03 , 0.1338007503484410D-05 , - 0.2245212949225648D-08 , & 0.1486218369131979D-11 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.4944388483605298D-01 , - 0.3827844654781482D-03 , & 0.1322966166480091D-05 , - 0.2212813572534620D-08 , 0.1460047486340531D-11 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.4920567627725211D-01 , - 0.3797157445769648D-03 , 0.1308141363735688D-05 , & - 0.2180983460146635D-08 , 0.1434419238040499D-11 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.4896937136708056D-01 , & - 0.3766813201990653D-03 , 0.1293529305567620D-05 , - 0.2149710846384488D-08 , & 0.1409320697372967D-11 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.4873494899977154D-01 , - 0.3736807026900276D-03 , & 0.1279126280046549D-05 , - 0.2118984244399257D-08 , 0.1384739284642187D-11 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.4850238836433549D-01 , - 0.3707134108422881D-03 , 0.1264928651180116D-05 , & - 0.2088792438748154D-08 , 0.1360662756967206D-11 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.4827166893976877D-01 , & - 0.3677789717267548D-03 , 0.1250932857143931D-05 , - 0.2059124478192552D-08 , & 0.1337079198272935D-11 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.4804277049025295D-01 , - 0.3648769205270384D-03 , & 0.1237135408553351D-05 , - 0.2029969668696906D-08 , 0.1313977009599450D-11 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.4781567306061492D-01 , - 0.3620068003794696D-03 , 0.1223532886789417D-05 , & - 0.2001317566651283D-08 , 0.1291344899740236D-11 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.4759035697169989D-01 , & - 0.3591681622146604D-03 , 0.1210121942358973D-05 , - 0.1973157972273412D-08 , & 0.1269171876169950D-11 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.4736680281590529D-01 , - 0.3563605646035143D-03 , & 0.1196899293301249D-05 , - 0.1945480923211080D-08 , 0.1247447236271511D-11 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.4714499145276072D-01 , - 0.3535835736062486D-03 , 0.1183861723633601D-05 , & - 0.1918276688326571D-08 , 0.1226160558843080D-11 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.4692490400466792D-01 , & - 0.3508367626257092D-03 , 0.1171006081841356D-05 , - 0.1891535761669310D-08 , & 0.1205301695883993D-11 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.4670652185256138D-01 , - 0.3481197122620889D-03 , & 0.1158329279398146D-05 , - 0.1865248856606390D-08 , 0.1184860764631854D-11 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.4648982663179180D-01 , - 0.3454320101725614D-03 , 0.1145828289331620D-05 , & - 0.1839406900137035D-08 , 0.1164828139865076D-11 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.4627480022801311D-01 , & - 0.3427732509331730D-03 , 0.1133500144821992D-05 , - 0.1814001027363027D-08 , & 0.1145194446445201D-11 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.4606142477315500D-01 , - 0.3401430359039122D-03 , & 0.1121341937836832D-05 , - 0.1789022576118716D-08 , 0.1125950552097032D-11 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.4584968264148677D-01 , - 0.3375409730969564D-03 , 0.1109350817801420D-05 , & - 0.1764463081756242D-08 , 0.1107087560418795D-11 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.4563955644565795D-01 , & - 0.3349666770467185D-03 , 0.1097523990297992D-05 , - 0.1740314272070113D-08 , & 0.1088596804106413D-11 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.4543102903298374D-01 , - 0.3324197686847467D-03 , & 0.1085858715806575D-05 , - 0.1716568062383007D-08 , 0.1070469838403633D-11 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.4522408348163083D-01 , - 0.3298998752154265D-03 , 0.1074352308469123D-05 , & - 0.1693216550754515D-08 , 0.1052698434746034D-11 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.4501870309694891D-01 , & - 0.3274066299952881D-03 , 0.1063002134888596D-05 , - 0.1670252013332902D-08 , & 0.1035274574609702D-11 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.4481487140785242D-01 , - 0.3249396724147547D-03 , & 0.1051805612957328D-05 , - 0.1647666899836328D-08 , 0.1018190443550955D-11 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.4461257216324400D-01 , - 0.3224986477821934D-03 , 0.1040760210713546D-05 , & - 0.1625453829158965D-08 , 0.1001438425430228D-11 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.4441178932860533D-01 , & - 0.3200832072116544D-03 , 0.1029863445231439D-05 , - 0.1603605585109932D-08 , & 0.9850110968223286D-12 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.4421250708245143D-01 , - 0.3176930075107847D-03 , & 0.1019112881529193D-05 , - 0.1582115112252994D-08 , 0.9689012215867052D-12 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.4401470981303415D-01 , - 0.3153277110732769D-03 , 0.1008506131513168D-05 , & - 0.1560975511879585D-08 , 0.9531017456178857D-12 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.4381838211501516D-01 , & - 0.3129869857726118D-03 , 0.9980408529438505D-06 , - 0.1540180038085528D-08 , & 0.9376057917517290D-12 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.4362350878621462D-01 , - 0.3106705048582716D-03 , & 0.9877147484281224D-06 , - 0.1519722093958118D-08 , 0.9224066548292945D-12 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.4343007482444212D-01 , - 0.3083779468544470D-03 , 0.9775255644374901D-06 , & - 0.1499595227870854D-08 , 0.9074977969135046D-12 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.4323806542426622D-01 , & - 0.3061089954595930D-03 , 0.9674710903448748D-06 , - 0.1479793129870004D-08 , & 0.8928728426446575D-12 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.4304746597406242D-01 , - 0.3038633394506008D-03 , & 0.9575491574954127D-06 , - 0.1460309628180147D-08 , 0.8785255747512601D-12 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.4285826205290309D-01 , - 0.3016406725866544D-03 , 0.9477576382900536D-06 , & - 0.1441138685787052D-08 , 0.8644499296842157D-12 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.4267043942760199D-01 , & - 0.2994406935162429D-03 , 0.9380944452961784D-06 , - 0.1422274397122878D-08 , & 0.8506399933895351D-12 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.4248398404979175D-01 , - 0.2972631056859269D-03 , & 0.9285575303789329D-06 , - 0.1403710984840177D-08 , 0.8370899972076349D-12 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.4229888205302464D-01 , - 0.2951076172507214D-03 , 0.9191448838523367D-06 , & - 0.1385442796671363D-08 , 0.8237943138946110D-12 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.4211511975005557D-01 , & - 0.2929739409878139D-03 , 0.9098545336569057D-06 , - 0.1367464302384484D-08 , & 0.8107474537707700D-12 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.4193268362992472D-01 , - 0.2908617942093646D-03 , & 0.9006845445458043D-06 , - 0.1349770090800599D-08 , 0.7979440609701813D-12 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.4175156035532637D-01 , - 0.2887708986797246D-03 , 0.8916330173012921D-06 , & - 0.1332354866911462D-08 , 0.7853789098160565D-12 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.4157173675991209D-01 , & - 0.2867009805331576D-03 , 0.8826980879648857D-06 , - 0.1315213449065464D-08 , & 0.7730469012977023D-12 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.4139319984566271D-01 , - 0.2846517701935147D-03 , & 0.8738779270869199D-06 , - 0.1298340766230975D-08 , 0.7609430596534834D-12 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.4121593678033405D-01 , - 0.2826230022959059D-03 , 0.8651707389953875D-06 , & - 0.1281731855335520D-08 , 0.7490625290568313D-12 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.4103993489480953D-01 , & - 0.2806144156084610D-03 , 0.8565747610757998D-06 , - 0.1265381858664349D-08 , & 0.7374005703922883D-12 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.4086518168076374D-01 , - 0.2786257529586462D-03 , & 0.8480882630802768D-06 , - 0.1249286021350507D-08 , 0.7259525581417514D-12 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.4069166478811316D-01 , - 0.2766567611583150D-03 , 0.8397095464415141D-06 , & - 0.1233439688910642D-08 , 0.7147139773480158D-12 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.4051937202263241D-01 , & - 0.2747071909316393D-03 , 0.8314369436084451D-06 , - 0.1217838304856154D-08 , & 0.7036804206742208D-12 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.4034829134356169D-01 , - 0.2727767968439840D-03 , & 0.8232688173953758D-06 , - 0.1202477408363548D-08 , 0.6928475855466567D-12 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.4017841086138264D-01 , - 0.2708653372336010D-03 , 0.8152035603518779D-06 , & - 0.1187352632016002D-08 , 0.6822112713875169D-12 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.4000971883539278D-01 , & - 0.2689725741421637D-03 , 0.8072395941371825D-06 , - 0.1172459699585942D-08 , & 0.6717673769158165D-12 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.3984220367154940D-01 , - 0.2670982732491550D-03 , & 0.7993753689189847D-06 , - 0.1157794423893285D-08 , 0.6615118975384151D-12 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.3967585392024253D-01 , - 0.2652422038064399D-03 , 0.7916093627816440D-06 , & - 0.1143352704711438D-08 , 0.6514409228109940D-12 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.3951065827412674D-01 , & - 0.2634041385743936D-03 , 0.7839400811490611D-06 , - 0.1129130526729559D-08 , & 0.6415506339734228D-12 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.3934660556602040D-01 , - 0.2615838537596443D-03 , & 0.7763660562222134D-06 , - 0.1115123957570080D-08 , 0.6318373015575611D-12 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.3918368476670023D-01 , - 0.2597811289526003D-03 , 0.7688858464238777D-06 , & - 0.1101329145847409D-08 , 0.6222972830569562D-12 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.3902188498299963D-01 , & - 0.2579957470690399D-03 , 0.7614980358672565D-06 , - 0.1087742319296427D-08 , & 0.6129270206762023D-12 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.3886119545568741D-01 , - 0.2562274942902296D-03 , & 0.7542012338263707D-06 , - 0.1074359782930851D-08 , 0.6037230391323773D-12 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.3870160555750268D-01 , - 0.2544761600055112D-03 , 0.7469940742236322D-06 , & - 0.1061177917257870D-08 , 0.5946819435249591D-12 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.3854310479120057D-01 , & - 0.2527415367558046D-03 , 0.7398752151282262D-06 , - 0.1048193176536995D-08 , & 0.5858004172651793D-12 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.3838568278759809D-01 , - 0.2510234201779022D-03 , & 0.7328433382646484D-06 , - 0.1035402087081252D-08 , 0.5770752200625772D-12 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.3822932930380894D-01 , - 0.2493216089514915D-03 , 0.7258971485387440D-06 , & - 0.1022801245612704D-08 , 0.5685031859755793D-12 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.3807403422121402D-01 , & - 0.2476359047441882D-03 , 0.7190353735626769D-06 , - 0.1010387317639349D-08 , & 0.5600812215036473D-12 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.3791978754374561D-01 , - 0.2459661121605585D-03 , & 0.7122567632019613D-06 , - 0.9981570358928494D-09 , 0.5518063037458229D-12 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.3776657939606778D-01 , - 0.2443120386907790D-03 , 0.7055600891274014D-06 , & - 0.9861071987966209D-09 , 0.5436754786048803D-12 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.3761440002181295D-01 , & - 0.2426734946605796D-03 , 0.6989441443781926D-06 , - 0.9742346689744790D-09 , & 0.5356858590428929D-12 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.3746323978188451D-01 , - 0.2410502931825479D-03 , & 0.6924077429363007D-06 , - 0.9625363717993805D-09 , 0.5278346233870517D-12 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.3731308915261655D-01 , - 0.2394422501066469D-03 , 0.6859497193037095D-06 , & - 0.9510092939672525D-09 , 0.5201190136752937D-12 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.3716393872428937D-01 , & - 0.2378491839750206D-03 , 0.6795689281018631D-06 , - 0.9396504821283492D-09 , & 0.5125363340617886D-12 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.3701577919936132D-01 , - 0.2362709159745430D-03 , & 0.6732642436680175D-06 , - 0.9284570415323126D-09 , 0.5050839492533760D-12 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.3686860139087736D-01 , - 0.2347072698917971D-03 , 0.6670345596663534D-06 , & - 0.9174261347169061D-09 , 0.4977592829954870D-12 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.3672239622087602D-01 , & - 0.2331580720686488D-03 , 0.6608787887066589D-06 , - 0.9065549802275747D-09 , & 0.4905598165985875D-12 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.3657715471878297D-01 , - 0.2316231513582854D-03 , & 0.6547958619699656D-06 , - 0.8958408513662860D-09 , 0.4834830875035014D-12 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.3643286802002030D-01 , - 0.2301023390840110D-03 , 0.6487847288496604D-06 , & - 0.8852810749834749D-09 , 0.4765266878936870D-12 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.3628952736428119D-01 , & - 0.2285954689952488D-03 , 0.6428443565869641D-06 , - 0.8748730302770591D-09 , & 0.4696882633310403D-12 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.3614712409417317D-01 , - 0.2271023772278105D-03 , & 0.6369737299273426D-06 , - 0.8646141476427699D-09 , 0.4629655114425984D-12 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.3600564965372171D-01 , - 0.2256229022633081D-03 , 0.6311718507783434D-06 , & - 0.8545019075424722D-09 , 0.4563561806364538D-12 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.3586509558692978D-01 , & - 0.2241568848896621D-03 , 0.6254377378761185D-06 , - 0.8445338394022477D-09 , & 0.4498580688537602D-12 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.3572545353640511D-01 , - 0.2227041681628051D-03 , & 0.6197704264608768D-06 , - 0.8347075205401627D-09 , 0.4434690223561905D-12 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.3558671524180265D-01 , - 0.2212645973670690D-03 , 0.6141689679517857D-06 , & - 0.8250205751075825D-09 , 0.4371869345382596D-12 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.3544887253868524D-01 , & - 0.2198380199802180D-03 , 0.6086324296434228D-06 , - 0.8154706730802472D-09 , & 0.4310097447865420D-12 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.3531191735703011D-01 , - 0.2184242856354602D-03 , & 0.6031598943950946D-06 , - 0.8060555292511316D-09 , 0.4249354373553765D-12 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.3517584171993749D-01 , - 0.2170232460859417D-03 , 0.5977504603334338D-06 , & - 0.7967729022585675D-09 , 0.4189620402794427D-12 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.3504063774232635D-01 , & - 0.2156347551695820D-03 , 0.5924032405601881D-06 , - 0.7876205936358151D-09 , & 0.4130876243141183D-12 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.3490629762960328D-01 , - 0.2142586687741071D-03 , & 0.5871173628645899D-06 , - 0.7785964468807576D-09 , 0.4073103019023636D-12 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.3477281367658003D-01 , - 0.2128948448049606D-03 , 0.5818919694500430D-06 , & - 0.7696983465612533D-09 , 0.4016282261772138D-12 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.3464017826597894D-01 , & - 0.2115431431496283D-03 , 0.5767262166513058D-06 , - 0.7609242174168716D-09 , & 0.3960395899753445D-12 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.3450838386737078D-01 , - 0.2102034256466204D-03 , & 0.5716192746723432D-06 , - 0.7522720235059989D-09 , 0.3905426248913656D-12 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.3437742303593536D-01 , - 0.2088755560531389D-03 , 0.5665703273228239D-06 , & - 0.7437397673619638D-09 , 0.3851356003501157D-12 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.3424728841128603D-01 , & - 0.2075594000137639D-03 , 0.5615785717616839D-06 , - 0.7353254891715473D-09 , & 0.3798168227047174D-12 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.3411797271632566D-01 , - 0.2062548250299432D-03 , & 0.5566432182472764D-06 , - 0.7270272659754064D-09 , 0.3745846343601039D-12 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.3398946875597278D-01 , - 0.2049617004283889D-03 , 0.5517634898859499D-06 , & - 0.7188432108750086D-09 , 0.3694374129111364D-12 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.3386176941624531D-01 , & - 0.2036798973336216D-03 , 0.5469386223999547D-06 , - 0.7107714722827243D-09 , & 0.3643735703191160D-12 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.3373486766301172D-01 , - 0.2024092886374491D-03 , & 0.5421678638864734D-06 , - 0.7028102331660668D-09 , 0.3593915520946944D-12 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.3360875654093537D-01 , - 0.2011497489707735D-03 , 0.5374504745884328D-06 , & - 0.6949577103210669D-09 , 0.3544898365092217D-12 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.3348342917235653D-01 , & - 0.1999011546751469D-03 , 0.5327857266673048D-06 , - 0.6872121536581077D-09 , & 0.3496669338237370D-12 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.3335887875640451D-01 , - 0.1986633837768723D-03 , & 0.5281729039878790D-06 , - 0.6795718455159514D-09 , 0.3449213855447544D-12 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.3323509856772186D-01 , - 0.1974363159577595D-03 , 0.5236113018938923D-06 , & - 0.6720350999701090D-09 , 0.3402517636863136D-12 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.3311208195559084D-01 , & - 0.1962198325300509D-03 , 0.5191002270013095D-06 , - 0.6646002621779615D-09 , & 0.3356566700633521D-12 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.3298982234289174D-01 , - 0.1950138164100780D-03 , & 0.5146389969897315D-06 , - 0.6572657077292918D-09 , 0.3311347355973684D-12 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.3286831322511226D-01 , - 0.1938181520927286D-03 , 0.5102269403993121D-06 , & - 0.6500298420137681D-09 , 0.3266846196410058D-12 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.3274754816942159D-01 , & - 0.1926327256268422D-03 , 0.5058633964335056D-06 , - 0.6428910996056098D-09 , & 0.3223050093214015D-12 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.3262752081352815D-01 , - 0.1914574245888875D-03 , & 0.5015477147582682D-06 , - 0.6358479436505195D-09 , 0.3179946188932554D-12 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.3250822486499270D-01 , - 0.1902921380612206D-03 , 0.4972792553198429D-06 , & - 0.6288988652893817D-09 , 0.3137521891216892D-12 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.3238965410013629D-01 , & - 0.1891367566068383D-03 , 0.4930573881525655D-06 , - 0.6220423830736885D-09 , & 0.3095764866681079D-12 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.3227180236316357D-01 , - 0.1879911722464483D-03 , & 0.4888814931971615D-06 , - 0.6152770424046355D-09 , 0.3054663034976551D-12 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.3215466356526182D-01 , - 0.1868552784355961D-03 , 0.4847509601215122D-06 , & - 0.6086014149830870D-09 , 0.3014204563004866D-12 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.3203823168366093D-01 , & - 0.1857289700417150D-03 , 0.4806651881433788D-06 , - 0.6020140982694630D-09 , & 0.2974377859261044D-12 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.2000000000000023D+00 , - 0.8867688983801802D-02 , & 0.2140644163050782D-03 , - 0.3624104554650780D-05 , 0.4758777226867341D-07 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.1999999996543374D+00 , - 0.8867686994707386D-02 , 0.2140599664175936D-03 , & - 0.3619165777806159D-05 , 0.4509650462492553D-07 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.1999999861965852D+00 , & - 0.8867653223955278D-02 , 0.2140275746180622D-03 , - 0.3605055651281668D-05 , & 0.4273791757083171D-07 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.1999998952207363D+00 , - 0.8867510903959038D-02 , & 0.2139434303545353D-03 , - 0.3582764132364366D-05 , 0.4050484946970426D-07 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.1999995714394641D+00 , - 0.8867145035969399D-02 , 0.2137877560465484D-03 , & - 0.3553200701888388D-05 , 0.3839052941955260D-07 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.1999987410358716D+00 , & - 0.8866411816654639D-02 , 0.2135443637686745D-03 , - 0.3517200229261047D-05 , & 0.3638855574626542D-07 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.1999969939739060D+00 , - 0.8865146735875485D-02 , & 0.2132002525925519D-03 , - 0.3475528433565898D-05 , 0.3449287568930640D-07 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.1999937745145260D+00 , - 0.8863171493683835D-02 , 0.2127452432140674D-03 , & - 0.3428886967634410D-05 , 0.3269776621338736D-07 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.1999883784167220D+00 , & - 0.8860299870144792D-02 , 0.2121716467550474D-03 , - 0.3377918150226734D-05 , & 0.3099781588331535D-07 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.1999799555083926D+00 , - 0.8856342668441710D-02 , & 0.2114739648719072D-03 , - 0.3323209369823269D-05 , 0.2938790774273161D-07 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.1999675164944993D+00 , - 0.8851111839765870D-02 , 0.2106486185286289D-03 , & - 0.3265297181995047D-05 , 0.2786320314078430D-07 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.1999499430312705D+00 , & - 0.8844423887615636D-02 , 0.2096937029995133D-03 , - 0.3204671120885805D-05 , & 0.2641912645391293D-07 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.1999260002376583D+00 , - 0.8836102639243537D-02 , & 0.2086087668595891D-03 , - 0.3141777243995669D-05 , 0.2505135065288212D-07 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.1998943509407430D+00 , - 0.8825981463008507D-02 , 0.2073946128985069D-03 , & - 0.3077021428199890D-05 , 0.2375578366799614D-07 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.1998535710621070D+00 , & - 0.8813905002237830D-02 , 0.2060531190582472D-03 , - 0.3010772433760280D-05 , & 0.2252855550805901D-07 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.1998021656489536D+00 , - 0.8799730488807112D-02 , & 0.2045870776470164D-03 , - 0.2943364751987300D-05 , 0.2136600609113677D-07 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.1997385851383986D+00 , - 0.8783328692942445D-02 , 0.2030000512221922D-03 , & - 0.2875101251181586D-05 , 0.2026467374752186D-07 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.1996612415171981D+00 , & - 0.8764584559675931D-02 , 0.2012962436649703D-03 , - 0.2806255634521231D-05 , & 0.1922128435751747D-07 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.1995685241034019D+00 , - 0.8743397576889618D-02 , & 0.1994803850892288D-03 , - 0.2737074722660721D-05 , 0.1823274108875012D-07 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.1994588147320712D+00 , - 0.8719681914912382D-02 , 0.1975576293378076D-03 , & - 0.2667780572965288D-05 , 0.1729611469969210D-07 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.1993305021752565D+00 , & - 0.8693366373143826D-02 , 0.1955334629215652D-03 , - 0.2598572446516695D-05 , & 0.1640863437793796D-07 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.1991819956677456D+00 , - 0.8664394165125648D-02 , & 0.1934136243508567D-03 , - 0.2529628633289930D-05 , 0.1556767908353715D-07 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.1990117374454336D+00 , - 0.8632722569825774D-02 , 0.1912040328960603D-03 , & - 0.2461108145211281D-05 , 0.1477076936934406D-07 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.1988182142332435D+00 , & - 0.8598322473607811D-02 , 0.1889107258940040D-03 , - 0.2393152286164191D-05 , & 0.1401555965191258D-07 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.1985999676449483D+00 , - 0.8561177824395604D-02 , & 0.1865398037911136D-03 , - 0.2325886107406888D-05 , 0.1329983090794058D-07 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.1983556034785875D+00 , - 0.8521285016879864D-02 , 0.1840973821822829D-03 , & - 0.2259419756302670D-05 , 0.1262148377266445D-07 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.1980837999089144D+00 , & - 0.8478652225223622D-02 , 0.1815895501672931D-03 , - 0.2193849725737210D-05 , & 0.1197853201792115D-07 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.1977833145929238D+00 , - 0.8433298697580522D-02 , & 0.1790223344044752D-03 , - 0.2129260011105051D-05 , 0.1136909638883766D-07 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.1974529907163710D+00 , - 0.8385254024822092D-02 , 0.1764016682946024D-03 , & - 0.2065723181287405D-05 , 0.1079139877928137D-07 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.1970917620186804D+00 , & - 0.8334557394155716D-02 , 0.1737333657770465D-03 , - 0.2003301369613316D-05 , & 0.1024375672731229D-07 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.1966986568410537D+00 , - 0.8281256836785387D-02 , & 0.1710230992653690D-03 , - 0.1942047190394325D-05 , 0.9724578212923205D-08 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.1962728012482155D+00 , - 0.8225408477404781D-02 , 0.1682763812910338D-03 , & - 0.1882004586247199D-05 , 0.9232356741341091D-08 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.1958134212783328D+00 , & - 0.8167075792100792D-02 , 0.1654985494620968D-03 , - 0.1823209611068240D-05 , & 0.8765666696094263D-08 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.1953198443784226D+00 , - 0.8106328880170995D-02 , & 0.1626947543788112D-03 , - 0.1765691153194782D-05 , 0.8323158946929391D-08 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.1947915000842311D+00 , - 0.8043243754407146D-02 , 0.1598699501803166D-03 , & - 0.1709471602983007D-05 , 0.7903556698492533D-08 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.1942279200042855D+00 , & - 0.7977901653556831D-02 , 0.1570288874261688D-03 , - 0.1654567468744979D-05 , & 0.7505651566472086D-08 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.1936287371677600D+00 , - 0.7910388379935667D-02 , & 0.1541761080436361D-03 , - 0.1600989944720374D-05 , 0.7128299868641338D-08 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.1929936847950665D+00 , - 0.7840793664513020D-02 , 0.1513159420966028D-03 , & - 0.1548745434508575D-05 , 0.6770419118936810D-08 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.1923225945488244D+00 , & - 0.7769210561225882D-02 , 0.1484525061547696D-03 , - 0.1497836033153557D-05 , & 0.6430984713367948D-08 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.1916153943211661D+00 , - 0.7695734871780283D-02 , & 0.1455897030627837D-03 , - 0.1448259970856071D-05 , 0.6109026797176282D-08 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.1908721056112917D+00 , - 0.7620464601769334D-02 , 0.1427312229281074D-03 , & - 0.1400012021084242D-05 , 0.5803627303249867D-08 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.1900928405448785D+00 , & - 0.7543499448565744D-02 , 0.1398805451639972D-03 , - 0.1353083875663715D-05 , & 0.5513917152353804D-08 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.1892777985844393D+00 , - 0.7464940321127146D-02 , & 0.1370409414400250D-03 , - 0.1307464489251144D-05 , 0.5239073606261472D-08 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.1884272629770699D+00 , - 0.7384888891580182D-02 , 0.1342154794072633D-03 , & - 0.1263140395429299D-05 , 0.4978317765365826D-08 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.1875415969832819D+00 , & - 0.7303447178218282D-02 , 0.1314070270786775D-03 , - 0.1220095996507516D-05 , & 0.4730912202817122D-08 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.1866212399278215D+00 , - 0.7220717159354079D-02 , & 0.1286182577575182D-03 , - 0.1178313828967015D-05 , 0.4496158727674450D-08 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.1856667031105573D+00 , - 0.7136800417306188D-02 , 0.1258516554176930D-03 , & - 0.1137774806356030D-05 , 0.4273396269974819D-08 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.1846785656127363D+00 , & - 0.7051797811668166D-02 , 0.1231095204502888D-03 , - 0.1098458441314135D-05 , & 0.4061998881016717D-08 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.1836574700311351D+00 , - 0.6965809180900440D-02 , & 0.1203939756996980D-03 , - 0.1060343048287946D-05 , 0.3861373842526316D-08 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.1826041181699554D+00 , - 0.6878933071202905D-02 , 0.1177069727212678D-03 , & - 0.1023405928391174D-05 , 0.3670959878725047D-08 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.1815192667176816D+00 , & - 0.6791266491560983D-02 , 0.1150502982000635D-03 , - 0.9876235377599679D-06 , & 0.3490225465648282D-08 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.1804037229335989D+00 , - 0.6702904693811716D-02 , & 0.1124255804773345D-03 , - 0.9529716406595036D-06 , 0.3318667232377497D-08 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.1792583403662411D+00 , - 0.6613940976544571D-02 , 0.1098342961376036D-03 , & - 0.9194254485090534D-06 , 0.3155808449143404D-08 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.1780840146237208D+00 , & - 0.6524466511633203D-02 , 0.1072777766150501D-03 , - 0.8869597459101688D-06 , & 0.3001197597536370D-08 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.1768816792136920D+00 , - 0.6434570192187088D-02 , & 0.1047572147830644D-03 , - 0.8555490046855188D-06 , 0.2854407018323615D-08 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.1756523014686074D+00 , - 0.6344338500714509D-02 , 0.1022736714955562D-03 , & - 0.8251674868641196D-06 , 0.2715031632621341D-08 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.1743968785699697D+00 , & - 0.6253855396299063D-02 , 0.9982808205285704D-04 , - 0.7957893374817551D-06 , & 0.2582687732404699D-08 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.1731164336834288D+00 , - 0.6163202219609597D-02 , & 0.9742126256888839D-04 , - 0.7673886680030115D-06 , 0.2457011836560221D-08 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.1718120122148522D+00 , - 0.6072457614587158D-02 , 0.9505391621972869D-04 , & - 0.7399396311132364D-06 , 0.2337659608894753D-08 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.1704846781958865D+00 , & - 0.5981697465680919D-02 , 0.9272663935681606D-04 , - 0.7134164875746140D-06 , & 0.2224304834712737D-08 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.1691355108060408D+00 , - 0.5890994849537510D-02 , & 0.9043992747081509D-04 , - 0.6877936657901175D-06 , 0.2116638452760424D-08 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.1677656010369367D+00 , - 0.5800420000083807D-02 , 0.8819418099467491D-04 , & - 0.6630458146721617D-06 , 0.2014367639512062D-08 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.1663760485031081D+00 , & - 0.5710040285981220D-02 , 0.8598971093664077D-04 , - 0.6391478503690642D-06 , & 0.1917214942939740D-08 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.1649679584025624D+00 , - 0.5619920199469572D-02 , & 0.8382674433597489D-04 , - 0.6160749973617393D-06 , 0.1824917463065928D-08 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.1635424386292581D+00 , - 0.5530121355659823D-02 , 0.8170542953591547D-04 , & - 0.5938028244051752D-06 , 0.1737226076746454D-08 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.1621005970386807D+00 , & - 0.5440702501377112D-02 , 0.7962584126997721D-04 , - 0.5723072757540103D-06 , & 0.1653904704272054D-08 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.1606435388668287D+00 , - 0.5351719532698152D-02 , & 0.7758798555908855D-04 , - 0.5515646980787431D-06 , 0.1574729615509278D-08 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.1591723643021322D+00 , - 0.5263225520369728D-02 , 0.7559180441828857D-04 , & - 0.5315518634486134D-06 , 0.1499488773426831D-08 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.1576881662091192D+00 , & - 0.5175270742337596D-02 , 0.7363718037278332D-04 , - 0.5122459887288439D-06 , & 0.1427981212971804D-08 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.1561920280020199D+00 , - 0.5087902722657109D-02 , & 0.7172394078410384D-04 , - 0.4936247517135592D-06 , 0.1360016453371998D-08 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.1546850216659399D+00 , - 0.5001166276098420D-02 , 0.6985186198792823D-04 , & - 0.4756663042912015D-06 , 0.1295413942046232D-08 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.1531682059227515D+00 , & - 0.4915103557799577D-02 , 0.6802067324583686D-04 , - 0.4583492829164851D-06 , & 0.1234002528404250D-08 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.1516426245384202D+00 , - 0.4829754117360475D-02 , & 0.6623006051388020D-04 , - 0.4416528166417729D-06 , 0.1175619965912129D-08 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.1501093047681287D+00 , - 0.4745154956809185D-02 , 0.6447967003135576D-04 , & - 0.4255565329411131D-06 , 0.1120112440888117D-08 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.1485692559352403D+00 , & - 0.4661340591909275D-02 , 0.6276911173362843D-04 , - 0.4100405615419143D-06 , & 0.1067334126578002D-08 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.1470234681398923D+00 , - 0.4578343116312862D-02 , & 0.6109796249319204D-04 , - 0.3950855364623059D-06 , 0.1017146761138531D-08 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.1454729110927925D+00 , - 0.4496192268098780D-02 , 0.5946576919347031D-04 , & - 0.3806725964365022D-06 , 0.9694192482325645D-09 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.1439185330696215D+00 , & - 0.4414915498268338D-02 , 0.5787205164009404D-04 , - 0.3667833838959028D-06 , & 0.9240272790105435D-09 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.1423612599813152D+00 , - 0.4334538040803195D-02 , & 0.5631630531458117D-04 , - 0.3534000426601291D-06 , 0.8808529743199280D-09 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.1408019945554040D+00 , - 0.4255082983920120D-02 , 0.5479800397548764D-04 , & - 0.3405052144796520D-06 , 0.8397845460475737D-09 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.1392416156235231D+00 , & - 0.4176571342186508D-02 , 0.5331660211219791D-04 , - 0.3280820345600389D-06 , & 0.8007159765598899D-09 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.1376809775101749D+00 , - 0.4099022129187987D-02 , & 0.5187153725658738D-04 , - 0.3161141261870633D-06 , 0.7635467152621441D-09 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.1361209095178147D+00 , - 0.4022452430465659D-02 , 0.5046223215782196D-04 , & - 0.3045855945619512D-06 , 0.7281813913517504D-09 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.1345622155033539D+00 , & - 0.3946877476465321D-02 , 0.4908809682556317D-04 , - 0.2934810199467835D-06 , & 0.6945295418908418D-09 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.1330056735412034D+00 , - 0.3872310715264316D-02 , & 0.4774853044682553D-04 , - 0.2827854502115285D-06 , 0.6625053543711659D-09 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.1314520356680440D+00 , - 0.3798763884863816D-02 , 0.4644292318169077D-04 , & - 0.2724843928662538D-06 , 0.6320274229894119D-09 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.1299020277045803D+00 , & - 0.3726247084855156D-02 , 0.4517065784302264D-04 , - 0.2625638066547616D-06 , & 0.6030185178937271D-09 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.1283563491496200D+00 , - 0.3654768847288232D-02 , & 0.4393111146524656D-04 , - 0.2530100927791042D-06 , 0.5754053667023979D-09 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.1268156731419254D+00 , - 0.3584336206588489D-02 , 0.4272365676716969D-04 , & - 0.2438100858182034D-06 , 0.5491184476337757D-09 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.1252806464853910D+00 , & - 0.3514954768386021D-02 , 0.4154766351371268D-04 , - 0.2349510443980140D-06 , & 0.5240917936224745D-09 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.1237518897332201D+00 , - 0.3446628777136375D-02 , & 0.4040249978131168D-04 , - 0.2264206416653353D-06 , 0.5002628068308471D-09 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.1222299973269053D+00 , - 0.3379361182427669D-02 , 0.3928753313163087D-04 , & - 0.2182069556124743D-06 , 0.4775720829969115D-09 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.1207155377859463D+00 , & - 0.3313153703882445D-02 , 0.3820213169809623D-04 , - 0.2102984592954107D-06 , & 0.4559632450902256D-09 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.1192090539443813D+00 , - 0.3248006894575665D-02 , & 0.3714566518963162D-04 , - 0.2026840109839477D-06 , 0.4353827857759343D-09 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.1177110632303467D+00 , - 0.3183920202902188D-02 , 0.3611750581584109D-04 , & - 0.1953528442784771D-06 , 0.4157799182143283D-09 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.1162220579850312D+00 , & - 0.3120892032838305D-02 , 0.3511702913774458D-04 , - 0.1882945582244542D-06 , & 0.3971064347489139D-09 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.1147425058175300D+00 , - 0.3058919802551881D-02 , & 0.3414361484803172D-04 , - 0.1814991074524059D-06 , 0.3793165730602015D-09 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.1132728499922587D+00 , - 0.2998000001325332D-02 , 0.3319664748465926D-04 , & - 0.1749567923683162D-06 , 0.3623668893853642D-09 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.1118135098457338D+00 , & - 0.2938128244764210D-02 , 0.3227551708147560D-04 , - 0.1686582494164736D-06 , & 0.3462161384255550D-09 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.1103648812296728D+00 , - 0.2879299328272135D-02 , & 0.3137961975941511D-04 , - 0.1625944414343489D-06 , 0.3308251595831622D-09 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.1089273369775130D+00 , - 0.2821507278780006D-02 , 0.3050835826166437D-04 , & - 0.1567566481167482D-06 , 0.3161567691906125D-09 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.1075012273916003D+00 , & - 0.2764745404724202D-02 , 0.2966114243606608D-04 , - 0.1511364566043829D-06 , & 0.3021756584106666D-09 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.1060868807484313D+00 , - 0.2709006344274310D-02 , & 0.2883738966788805D-04 , - 0.1457257522100429D-06 , 0.2888482965054163D-09 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.1046846038194831D+00 , - 0.2654282111816501D-02 , 0.2803652526595204D-04 , & - 0.1405167092937993D-06 , 0.2761428391875693D-09 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.1032946824052947D+00 , & - 0.2600564142703461D-02 , 0.2725798280498489D-04 , - 0.1355017822970339D-06 , & 0.2640290417830544D-09 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.1019173818806066D+00 , - 0.2547843336286398D-02 , & 0.2650120442692773D-04 , - 0.1306736969436321D-06 , 0.2524781769486263D-09 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.1005529477484862D+00 , - 0.2496110097248320D-02 , 0.2576564110381116D-04 , & - 0.1260254416153105D-06 , 0.2414629567019342D-09 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.9920160620150476D-01 , & - 0.2445354375261536D-02 , 0.2505075286468441D-04 , - 0.1215502589068460D-06 , & 0.2309574585346213D-09 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.9786356468814814D-01 , - 0.2395565702995359D-02 , & 0.2435600898896774D-04 , - 0.1172416373658567D-06 , 0.2209370553913708D-09 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.9653901248276241D-01 , - 0.2346733232502598D-02 , 0.2368088816848023D-04 , & - 0.1130933034207698D-06 , 0.2113783493094853D-09 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.9522812125745936D-01 , & - 0.2298845770016088D-02 , 0.2302487864028697D-04 , - 0.1090992134997177D-06 , & 0.2022591085246658D-09 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.9393104565450737D-01 , - 0.2251891809188268D-02 , & 0.2238747829239908D-04 , - 0.1052535463422624D-06 , 0.1935582078590804D-09 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.9264792385784829D-01 , - 0.2205859562808796D-02 , 0.2176819474425750D-04 , & - 0.1015506955051195D-06 , 0.1852555722177091D-09 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.9137887816247797D-01 , & - 0.2160736993036505D-02 , 0.2116654540383004D-04 , - 0.9798526206237607D-07 , & 0.1773321230282862D-09 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.9012401554053469D-01 , - 0.2116511840183468D-02 , & 0.2058205750305661D-04 , - 0.9455204750010993D-07 , 0.1697697274690201D-09 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.8888342820302111D-01 , - 0.2073171650089582D-02 , 0.2001426811328133D-04 , & - 0.9124604680476749D-07 , 0.1625511503365984D-09 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.8765719415619014D-01 , & - 0.2030703800127231D-02 , 0.1946272414222403D-04 , - 0.8806244174419372D-07 , & 0.1556600084149177D-09 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.8644537775169892D-01 , - 0.1989095523875886D-02 , & 0.1892698231395594D-04 , - 0.8499659433977608D-07 , 0.1490807272124432D-09 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.8524803022972603D-01 , - 0.1948333934507118D-02 , 0.1840660913326364D-04 , & - 0.8204404052779528D-07 , 0.1427984999431806D-09 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.8406519025431448D-01 , & - 0.1908406046920468D-02 , 0.1790118083570422D-04 , - 0.7920048400773449D-07 , & 0.1367992486329151D-09 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.8289688444028917D-01 , - 0.1869298798671053D-02 , & 0.1741028332458283D-04 , - 0.7646179027502702D-07 , 0.1310695872387316D-09 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.8174312787115587D-01 , - 0.1830999069729418D-02 , 0.1693351209600834D-04 , & - 0.7382398083545444D-07 , 0.1255967866757815D-09 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.8060392460746266D-01 , & - 0.1793493701114186D-02 , 0.1647047215311650D-04 , - 0.7128322759820032D-07 , & 0.1203687416509466D-09 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.7947926818515960D-01 , - 0.1756769512437593D-02 , & 0.1602077791048214D-04 , - 0.6883584744437119D-07 , 0.1153739392083881D-09 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.7836914210356274D-01 , - 0.1720813318403918D-02 , 0.1558405308968281D-04 , & - 0.6647829696765180D-07 , 0.1106014288970605D-09 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.7727352030256784D-01 , & - 0.1685611944299939D-02 , 0.1515993060691196D-04 , - 0.6420716738361177D-07 , & 0.1060407944750296D-09 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.7619236762882590D-01 , - 0.1651152240516369D-02 , & 0.1474805245348748D-04 , - 0.6201917960409049D-07 , 0.1016821270699993D-09 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.7512564029063129D-01 , - 0.1617421096138398D-02 , 0.1434806957004452D-04 , & - 0.5991117947299024D-07 , 0.9751599971972242D-10 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.7407328630132597D-01 , & - 0.1584405451642953D-02 , 0.1395964171515224D-04 , - 0.5788013315974833D-07 , & 0.9353344322004588D-10 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.7303524591105534D-01 , - 0.1552092310739302D-02 , & 0.1358243732904284D-04 , - 0.5592312270669721D-07 , 0.8972592321215536D-10 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.7201145202676552D-01 , - 0.1520468751389250D-02 , 0.1321613339309860D-04 , & - 0.5403734172650713D-07 , 0.8608531844425545D-10 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.7100183062035462D-01 , & - 0.1489521936041991D-02 , 0.1286041528569573D-04 , - 0.5222009124586866D-07 , & 0.8260390014632592D-10 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.7000630112493371D-01 , - 0.1459239121118100D-02 , & 0.1251497663496387D-04 , - 0.5046877569157775D-07 , 0.7927431245986873D-10 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.6902477681917740D-01 , - 0.1429607665776070D-02 , 0.1217951916897980D-04 , & - 0.4878089901518237D-07 , 0.7608955386762581D-10 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.6805716519978552D-01 , & - 0.1400615039994239D-02 , 0.1185375256387932D-04 , - 0.4715406095237966D-07 , & 0.7304295957118354D-10 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.6710336834208565D-01 , - 0.1372248831999607D-02 , & 0.1153739429033147D-04 , - 0.4558595341335614D-07 , 0.7012818476710350D-10 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.6616328324884874D-01 , - 0.1344496755074525D-02 , 0.1123016945879099D-04 , & - 0.4407435700031602D-07 , 0.6733918877486084D-10 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.6523680218740105D-01 , & - 0.1317346653771089D-02 , 0.1093181066391010D-04 , - 0.4261713764847075D-07 , & 0.6467021997232186D-10 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.6432381301514448D-01 , - 0.1290786509562310D-02 , & 0.1064205782846369D-04 , - 0.4121224338681698D-07 , 0.6211580149684279D-10 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.6342419949360320D-01 , - 0.1264804445957915D-02 , 0.1036065804711075D-04 , & - 0.3985770121506906D-07 , 0.5967071767226313D-10 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.6253784159115033D-01 , & - 0.1239388733112154D-02 , 0.1008736543029323D-04 , - 0.3855161409318848D-07 , & 0.5733000112419307D-10 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.6166461577456574D-01 , - 0.1214527791949654D-02 , & 0.9821940948544672D-05 , - 0.3729215803999425D-07 , 0.5508892054794653D-10 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.6080439528959958D-01 , - 0.1190210197834672D-02 , 0.9564152277459943D-05 , & - 0.3607757933741338D-07 , 0.5294296909536416D-10 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.5995705043072680D-01 , & - 0.1166424683808178D-02 , 0.9313773643555323D-05 , - 0.3490619183699516D-07 , & 0.5088785334854385D-10 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.5912244880028131D-01 , - 0.1143160143416111D-02 , & 0.9070585671226009D-05 , - 0.3377637436537633D-07 , 0.4891948285016760D-10 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.5830045555718757D-01 , - 0.1120405633151771D-02 , 0.8834375230993382D-05 , & - 0.3268656822547441D-07 , 0.4703396016173414D-10 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.5749093365548563D-01 , & - 0.1098150374533702D-02 , 0.8604935289209514D-05 , - 0.3163527479023024D-07 , & 0.4522757142246866D-10 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.5669374407288038D-01 , - 0.1076383755840259D-02 , & 0.8382064759375910D-05 , - 0.3062105318582307D-07 , 0.4349677738315044D-10 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.5590874602953508D-01 , - 0.1055095333520812D-02 , 0.8165568355213859D-05 , & - 0.2964251806133968D-07 , 0.4183820489042395D-10 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.5513579719734645D-01 , & - 0.1034274833303016D-02 , 0.7955256445611704D-05 , - 0.2869833744196617D-07 , & 0.4024863879845570D-10 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.5437475389992033D-01 , - 0.1013912151014256D-02 , & 0.7750944911555915D-05 , - 0.2778723066282870D-07 , 0.3872501428598133D-10 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.5362547130350439D-01 , - 0.9939973531354267D-03 , 0.7552455005147116D-05 , & - 0.2690796638071385D-07 , 0.3726440955797797D-10 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.5288780359910365D-01 , & - 0.9745206771036349D-03 , 0.7359613210783392D-05 , - 0.2605936066094785D-07 , & 0.3586403891224091D-10 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.5216160417602658D-01 , - 0.9554725313801976D-03 , & 0.7172251108586246D-05 , - 0.2524027513680649D-07 , 0.3452124615219755D-10 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.5144672578709567D-01 , - 0.9368434952992240D-03 , 0.6990205240131310D-05 , & - 0.2444961523889096D-07 , 0.3323349832824845D-10 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.5074302070578092D-01 , & - 0.9186243187119379D-03 , 0.6813316976540944D-05 , - 0.2368632849199742D-07 , & 0.3199837979087436D-10 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.5005034087547761D-01 , - 0.9008059214403873D-03 , & 0.6641432388979798D-05 , - 0.2294940287705421D-07 , 0.3081358653958110D-10 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.4936853805118321D-01 , - 0.8833793925543195D-03 , 0.6474402121592888D-05 , & - 0.2223786525579890D-07 , 0.2967692085261978D-10 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.4869746393380648D-01 , & - 0.8663359894838875D-03 , 0.6312081266913969D-05 , - 0.2155077985592340D-07 , & 0.2858628618318051D-10 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.4803697029735363D-01 , - 0.8496671369805713D-03 , & 0.6154329243767635D-05 , - 0.2088724681449606D-07 , 0.2753968230851485D-10 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.4738690910921026D-01 , - 0.8333644259375527D-03 , 0.6001009677677499D-05 , & - 0.2024640077752118D-07 , 0.2653520071912078D-10 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.4674713264377268D-01 , & - 0.8174196120810495D-03 , 0.5851990283793764D-05 , - 0.1962740955359125D-07 , & 0.2557102023582796D-10 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.4611749358964261D-01 , - 0.8018246145427650D-03 , & 0.5707142752341263D-05 , - 0.1902947281962750D-07 , 0.2464540284321534D-10 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.4549784515061893D-01 , - 0.7865715143235563D-03 , 0.5566342636588031D-05 , & - 0.1845182087678564D-07 , 0.2375668972841322D-10 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.4488804114070055D-01 , & - 0.7716525526575845D-03 , 0.5429469243327065D-05 , - 0.1789371345465590D-07 , & 0.2290329751489334D-10 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.4428793607333663D-01 , - 0.7570601292862698D-03 , & 0.5296405525864233D-05 , - 0.1735443856196667D-07 , 0.2208371468141081D-10 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.4369738524511699D-01 , - 0.7427868006500425D-03 , 0.5167037979494401D-05 , & - 0.1683331138203467D-07 , 0.2129649815673369D-10 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.4311624481412922D-01 , & - 0.7288252780062517D-03 , 0.5041256539451065D-05 , - 0.1632967321128925D-07 , & 0.2054027008131241D-10 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.4254437187318232D-01 , - 0.7151684254806659D-03 , & 0.4918954481307650D-05 , - 0.1584289043924148D-07 , 0.1981371472747771D-10 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.4198162451809832D-01 , - 0.7018092580597141D-03 , 0.4800028323806766D-05 , & - 0.1537235356832818D-07 , 0.1911557557019286D-10 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.4142786191127937D-01 , & - 0.6887409395304348D-03 , 0.4684377734092973D-05 , - 0.1491747627212280D-07 , & 0.1844465250080535D-10 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.4088294434071801D-01 , - 0.6759567803739722D-03 , & 0.4571905435316318D-05 , - 0.1447769449043633D-07 , 0.1779979917660239D-10 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.4034673327467021D-01 , - 0.6634502356192833D-03 , 0.4462517116581361D-05 , & - 0.1405246555991749D-07 , 0.1717992049938889D-10 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.3981909141215124D-01 , & - 0.6512149026622170D-03 , 0.4356121345205446D-05 , - 0.1364126737877869D-07 , & 0.1658397021661125D-10 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.3929988272944402D-01 , - 0.6392445190554932D-03 , & 0.4252629481253929D-05 , - 0.1324359760434280D-07 , 0.1601094863890784D-10 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.3878897252278001D-01 , - 0.6275329602743018D-03 , 0.4151955594314878D-05 , & - 0.1285897288213987D-07 , 0.1545990046826285D-10 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.3828622744738774D-01 , & - 0.6160742374627209D-03 , 0.4054016382480660D-05 , - 0.1248692810534973D-07 , & 0.1492991273126519D-10 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.3779151555303981D-01 , - 0.6048624951646619D-03 , & 0.3958731093493475D-05 , - 0.1212701570339862D-07 , 0.1442011281221333D-10 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.3730470631628037D-01 , - 0.5938920090439055D-03 , 0.3866021448019859D-05 , & - 0.1177880495859155D-07 , 0.1392966658111428D-10 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.3682567066947634D-01 , & - 0.5831571835968326D-03 , 0.3775811565013050D-05 , - 0.1144188134968533D-07 , & 0.1345777661185382D-10 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.3635428102685426D-01 , - 0.5726525498616722D-03 , & 0.3688027889125182D-05 , - 0.1111584592135932D-07 , 0.1300368048607063D-10 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.3589041130764087D-01 , - 0.5623727631270617D-03 , 0.3602599120124805D-05 , & - 0.1080031467856059D-07 , 0.1256664917846935D-10 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.3543393695648040D-01 , & - 0.5523126006436754D-03 , 0.3519456144283973D-05 , - 0.1049491800476762D-07 , & 0.1214598551956189D-10 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.3498473496124027D-01 , - 0.5424669593413270D-03 , & 0.3438531967690247D-05 , - 0.1019930010322459D-07 , 0.1174102273199407D-10 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.3454268386834475D-01 , - 0.5328308535543825D-03 , 0.3359761651443779D-05 , & - 0.9913118460249876D-08 , 0.1135112303682951D-10 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.3410766379576378D-01 , & - 0.5233994127579779D-03 , 0.3283082248698389D-05 , - 0.9636043329752231D-08 , & 0.1097567632634192D-10 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.3367955644376393D-01 , - 0.5141678793170180D-03 , & 0.3208432743503208D-05 , - 0.9367757238113528D-08 , 0.1061409890003113D-10 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.3325824510357424D-01 , - 0.5051316062507603D-03 , 0.3135753991408997D-05 , & - 0.9107954508652721D-08 , 0.1026583226077466D-10 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.3284361466403492D-01 , & - 0.4962860550140188D-03 , 0.3064988661791601D-05 , - 0.8856340804877503D-08 , & 0.9930341968134402D-11 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.3243555161637025D-01 , - 0.4876267932973973D-03 , & 0.2996081181856579D-05 , - 0.8612632691796987D-08 , 0.9607116546033906D-11 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.3203394405717521D-01 , - 0.4791494928478680D-03 , 0.2928977682282435D-05 , & - 0.8376557214574410D-08 , 0.9295666442134154D-11 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.3163868168973427D-01 , & - 0.4708499273115067D-03 , 0.2863625944464838D-05 , - 0.8147851493841404D-08 , & 0.8995523036388331D-11 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.3124965582373285D-01 , - 0.4627239700990281D-03 , & 0.2799975349317207D-05 , - 0.7926262336997857D-08 , 0.8706237696353876D-11 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.3086675937350043D-01 , - 0.4547675922762044D-03 , 0.2737976827594794D-05 , & - 0.7711545864883474D-08 , 0.8427380877005060D-11 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.3048988685484205D-01 , & - 0.4469768604796378D-03 , 0.2677582811699057D-05 , - 0.7503467153196818D-08 , & 0.8158541262861140D-11 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.3011893438055919D-01 , - 0.4393479348591474D-03 , & 0.2618747188926232D-05 , - 0.7301799888082532D-08 , 0.7899324950379451D-11 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.2975379965472488D-01 , - 0.4318770670473175D-03 , 0.2561425256120158D-05 , & - 0.7106326035316447D-08 , 0.7649354668649039D-11 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.2939438196582824D-01 , & - 0.4245605981576495D-03 , 0.2505573675697065D-05 , - 0.6916835522562339D-08 , & 0.7408269036544372D-11 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.2904058217881809D-01 , - 0.4173949568111421D-03 , & 0.2451150432999837D-05 , - 0.6733125934161573D-08 , 0.7175721854551269D-11 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.2869230272615050D-01 , - 0.4103766571924853D-03 , 0.2398114794950181D-05 , & - 0.6555002217969532D-08 , 0.6951381429603502D-11 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.2834944759789713D-01 , & - 0.4035022971361456D-03 , 0.2346427269961846D-05 , - 0.6382276403753836D-08 , & 0.6734929931329934D-11 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.2801192233097861D-01 , - 0.3967685562427313D-03 , & 0.2296049569080116D-05 , - 0.6214767332692730D-08 , 0.6526062778196695D-11 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.2767963399760695D-01 , - 0.3901721940263641D-03 , 0.2246944568316227D-05 , & - 0.6052300397538740D-08 , 0.6324488052113828D-11 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.2735249119294824D-01 , & - 0.3837100480924519D-03 , 0.2199076272137365D-05 , - 0.5894707293003651D-08 , & 0.6129925940116690D-11 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.2703040402212508D-01 , - 0.3773790323472031D-03 , & 0.2152409778087364D-05 , - 0.5741825775979912D-08 , 0.5942108201848753D-11 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.2671328408656960D-01 , - 0.3711761352382382D-03 , 0.2106911242500699D-05 , & - 0.5593499435189306D-08 , 0.5760777661590128D-11 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.2640104446979959D-01 , & - 0.3650984180267710D-03 , 0.2062547847281061D-05 , - 0.5449577469889924D-08 , & 0.5585687723665555D-11 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.2609359972264455D-01 , - 0.3591430130910006D-03 , & 0.2019287767711249D-05 , - 0.5309914477271444D-08 , 0.5416601910105361D-11 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.2579086584801733D-01 , - 0.3533071222615699D-03 , 0.1977100141270193D-05 , & - 0.5174370248208418D-08 , 0.5253293419516401D-11 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.2549276028521533D-01 , & - 0.3475880151879670D-03 , 0.1935955037420724D-05 , - 0.5042809571016462D-08 , & 0.5095544706128751D-11 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.2519920189383761D-01 , - 0.3419830277365602D-03 , & 0.1895823428344759D-05 , - 0.4915102042906630D-08 , 0.4943147078075318D-11 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.2491011093734200D-01 , - 0.3364895604198472D-03 , 0.1856677160596078D-05 , & - 0.4791121888824608D-08 , 0.4795900313984491D-11 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.2462540906627980D-01 , & - 0.3311050768567377D-03 , 0.1818488927643369D-05 , - 0.4670747787379041D-08 , & 0.4653612297016848D-11 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.2434501930126747D-01 , - 0.3258271022641090D-03 , & 0.1781232243279979D-05 , - 0.4553862703584432D-08 , 0.4516098665529587D-11 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.2406886601567354D-01 , - 0.3206532219783788D-03 , 0.1744881415867538D-05 , & - 0.4440353728125870D-08 , 0.4383182479560360D-11 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.2379687491812693D-01 , & - 0.3155810800081779D-03 , 0.1709411523397194D-05 , - 0.4330111922910906D-08 , & 0.4254693902412246D-11 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.2352897303482442D-01 , - 0.3106083776168935D-03 , & 0.1674798389337548D-05 , - 0.4223032172639104D-08 , 0.4130469896608386D-11 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.2326508869169194D-01 , - 0.3057328719352363D-03 , 0.1641018559248314D-05 , & - 0.4119013042157369D-08 , 0.4010353933549496D-11 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.2300515149639799D-01 , & - 0.3009523746030177D-03 , 0.1608049278133264D-05 , - 0.4017956639361084D-08 , & 0.3894195716221194D-11 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.2274909232030683D-01 , - 0.2962647504408427D-03 , & 0.1575868468516422D-05 , - 0.3919768483438334D-08 , 0.3781850914359293D-11 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.2249684328031828D-01 , - 0.2916679161500524D-03 , 0.1544454709211067D-05 , & - 0.3824357378220592D-08 , 0.3673180911464929D-11 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.2224833772067301D-01 , & - 0.2871598390414934D-03 , 0.1513787214766112D-05 , - 0.3731635290452922D-08 , & 0.3568052563133738D-11 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.2200351019472251D-01 , - 0.2827385357923575D-03 , & 0.1483845815566618D-05 , - 0.3641517232781128D-08 , 0.3466337966164606D-11 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.2176229644669035D-01 , - 0.2784020712307700D-03 , 0.1454610938568391D-05 , & - 0.3553921151267820D-08 , 0.3367914237945377D-11 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.2152463339345227D-01 , & - 0.2741485571479644D-03 , 0.1426063588649049D-05 , - 0.3468767817264740D-08 , & 0.3272663305647781D-11 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.2129045910631533D-01 , - 0.2699761511368400D-03 , & 0.1398185330550415D-05 , - 0.3385980723448458D-08 , 0.3180471704752994D-11 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.2105971279287237D-01 , - 0.2658830554576348D-03 , 0.1370958271401820D-05 , & - 0.3305485983879126D-08 , 0.3091230386505166D-11 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.2083233477890012D-01 , & - 0.2618675159294048D-03 , 0.1344365043800089D-05 , - 0.3227212237903948D-08 , & 0.3004834533859092D-11 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.2060826649034087D-01 , - 0.2579278208473276D-03 , & 0.1318388789431626D-05 , - 0.3151090557761140D-08 , 0.2921183385539503D-11 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.2038745043534582D-01 , - 0.2540622999248158D-03 , 0.1293013143215961D-05 , & - 0.3077054359727725D-08 , 0.2840180067828178D-11 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.2016983018646937D-01 , & - 0.2502693232612373D-03 , 0.1268222217961738D-05 , - 0.3005039318690680D-08 , & 0.2761731433744128D-11 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.1995535036292921D-01 , - 0.2465473003332372D-03 , & 0.1244000589509501D-05 , - 0.2934983285980179D-08 , 0.2685747909251358D-11 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.1974395661301256D-01 , - 0.2428946790103396D-03 , 0.1220333282352529D-05 , & - 0.2866826210353751D-08 , 0.2612143346190686D-11 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.1953559559660675D-01 , & - 0.2393099445938713D-03 , 0.1197205755717451D-05 , - 0.2800510061998307D-08 , & 0.2540834881619610D-11 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.1933021496789852D-01 , - 0.2357916188793225D-03 , & 0.1174603890093276D-05 , - 0.2735978759439378D-08 , 0.2471742803276461D-11 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.1912776335817765D-01 , - 0.2323382592405428D-03 , 0.1152513974187707D-05 , & - 0.2673178099224436D-08 , 0.2404790420871517D-11 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.1892819035884547D-01 , & - 0.2289484577368017D-03 , 0.1130922692305677D-05 , - 0.2612055688293630D-08 , & 0.2339903942962951D-11 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.1873144650456902D-01 , - 0.2256208402412196D-03 , & 0.1109817112130443D-05 , - 0.2552560878915471D-08 , 0.2277012359147666D-11 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.1853748325661310D-01 , - 0.2223540655905371D-03 , 0.1089184672896653D-05 , & - 0.2494644706092571D-08 , 0.2216047327332363D-11 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.1834625298635872D-01 , & - 0.2191468247558281D-03 , 0.1069013173943043D-05 , - 0.2438259827340655D-08 , & 0.2156943065855596D-11 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.1815770895897439D-01 , - 0.2159978400331195D-03 , & 0.1049290763629018D-05 , - 0.2383360464738337D-08 , 0.2099636250232859D-11 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.1797180531733789D-01 , - 0.2129058642549259D-03 , 0.1030005928611693D-05 , & - 0.2329902349179846D-08 , 0.2044065914337439D-11 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.1778849706609499D-01 , & - 0.2098696800204511D-03 , 0.1011147483461280D-05 , - 0.2277842666716941D-08 , & 0.1990173355790882D-11 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.1760774005594334D-01 , - 0.2068880989453410D-03 , & 0.9927045606113484D-06 , - 0.2227140006927384D-08 , 0.1937902045393061D-11 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.1742949096810609D-01 , - 0.2039599609299732D-03 , 0.9746666006297151D-06 , & - 0.2177754313221672D-08 , 0.1887197540402215D-11 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.1725370729904029D-01 , & - 0.2010841334465155D-03 , 0.9570233428032444D-06 , - 0.2129646835021423D-08 , & 0.1838007401501784D-11 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.1708034734529494D-01 , - 0.1982595108430108D-03 , & 0.9397648160188118D-06 , - 0.2082780081716928D-08 , 0.1790281113270990D-11 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.1690937018863215D-01 , - 0.1954850136657830D-03 , 0.9228813299403821D-06 , & - 0.2037117778358651D-08 , 0.1743970008026446D-11 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.1674073568133337D-01 , & - 0.1927595879985545D-03 , 0.9063634664657747D-06 , - 0.1992624822997625D-08 , & 0.1699027192868274D-11 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.1657440443172282D-01 , - 0.1900822048183503D-03 , & 0.8902020714566249D-06 , - 0.1949267245617068D-08 , 0.1655407479794914D-11 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.1641033778991229D-01 , - 0.1874518593678503D-03 , 0.8743882467329203D-06 , & - 0.1907012168593858D-08 , 0.1613067318751295D-11 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.1624849783372188D-01 , & - 0.1848675705431243D-03 , 0.8589133423196750D-06 , - 0.1865827768620797D-08 , & 0.1571964733471780D-11 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.1608884735452073D-01 , - 0.1823283802921926D-03 , & 0.8437689489119465D-06 , - 0.1825683239963837D-08 , 0.1532059259924895D-11 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.1593134984505629D-01 , - 0.1798333530570450D-03 , 0.8289468907474300D-06 , & - 0.1786548759523430D-08 , 0.1493311887763591D-11 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.1577596948382978D-01 , & - 0.1773815751721512D-03 , 0.8144392183621457D-06 , - 0.1748395452277480D-08 , & 0.1455685003306666D-11 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.1562267112339696D-01 , - 0.1749721543365232D-03 , & 0.8002382019221675D-06 , - 0.1711195358912753D-08 , 0.1419142335790711D-11 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.1547142027701555D-01 , - 0.1726042190701496D-03 , 0.7863363245936933D-06 , & - 0.1674921404188736D-08 , 0.1383648905389637D-11 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.1532218310590192D-01 , & - 0.1702769181906133D-03 , 0.7727262761608407D-06 , - 0.1639547366563150D-08 , & 0.1349170973478125D-11 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.1517492640664718D-01 , - 0.1679894203022790D-03 , & 0.7594009468402284D-06 , - 0.1605047848915893D-08 , 0.1315675994926579D-11 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.1502961759890244D-01 , - 0.1657409132995585D-03 , 0.7463534212970648D-06 , & - 0.1571398250359370D-08 , 0.1283132572369847D-11 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.1488622471324511D-01 , & - 0.1635306038825319D-03 , 0.7335769728479237D-06 , - 0.1538574739071511D-08 , & 0.1251510412342277D-11 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.1474471637926967D-01 , - 0.1613577170853024D-03 , & 0.7210650578480631D-06 , - 0.1506554226122390D-08 , 0.1220780283208210D-11 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.1460506181384164D-01 , - 0.1592214958159134D-03 , 0.7088113102526256D-06 , & - 0.1475314340245163D-08 , 0.1190913974800115D-11 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.1446723080964117D-01 , & - 0.1571212004093530D-03 , 0.6968095363557779D-06 , - 0.1444833403538450D-08 , & 0.1161884259711789D-11 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.1433119372383177D-01 , - 0.1550561081910249D-03 , & 0.6850537096896711D-06 , - 0.1415090408035089D-08 , 0.1133664856148827D-11 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.1419692146696907D-01 , - 0.1530255130520602D-03 , 0.6735379660867951D-06 , & - 0.1386064993125224D-08 , 0.1106230392288509D-11 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.1406438549210286D-01 , & - 0.1510287250355483D-03 , 0.6622565988970409D-06 , - 0.1357737423793133D-08 , & 0.1079556372077187D-11 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.1393355778406595D-01 , - 0.1490650699333459D-03 , & 0.6512040543541051D-06 , - 0.1330088569636102D-08 , 0.1053619142403132D-11 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.1380441084901408D-01 , - 0.1471338888941211D-03 , 0.6403749270912232D-06 , & - 0.1303099884647019D-08 , 0.1028395861596235D-11 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.1367691770405681D-01 , & - 0.1452345380401561D-03 , 0.6297639557898659D-06 , - 0.1276753387704759D-08 , & 0.1003864469174297D-11 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.1355105186717808D-01 , - 0.1433663880954608D-03 , & 0.6193660189716285D-06 , - 0.1251031643779666D-08 , 0.9800036568130959D-12 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.1342678734729980D-01 , - 0.1415288240229220D-03 , 0.6091761309182446D-06 , & - 0.1225917745802747D-08 , 0.9567928404668891D-12 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.1330409863455248D-01 , & - 0.1397212446711659D-03 , 0.5991894377203029D-06 , - 0.1201395297184566D-08 , & 0.9342121336004492D-12 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.1318296069067981D-01 , - 0.1379430624299161D-03 , & 0.5894012134454821D-06 , - 0.1177448394947853D-08 , 0.9122423214757470D-12 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.1306334893972138D-01 , - 0.1361937028956272D-03 , 0.5798068564327280D-06 , & - 0.1154061613474468D-08 , 0.8908648364694701D-12 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.1294523925878456D-01 , & - 0.1344726045445950D-03 , 0.5704018856952263D-06 , - 0.1131219988813580D-08 , & 0.8700617343520412D-12 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.1282860796903682D-01 , - 0.1327792184151603D-03 , & 0.5611819374379592D-06 , - 0.1108909003551479D-08 , 0.8498156715064402D-12 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.1271343182686466D-01 , - 0.1311130077980761D-03 , 0.5521427616825688D-06 , & - 0.1087114572213796D-08 , 0.8301098830404484D-12 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.1259968801519151D-01 , & - 0.1294734479347584D-03 , 0.5432802189957058D-06 , - 0.1065823027179515D-08 , & 0.8109281617544475D-12 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.1248735413502716D-01 , - 0.1278600257242220D-03 , & 0.5345902773226145D-06 , - 0.1045021105099169D-08 , 0.7922548379389397D-12 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.1237640819706758D-01 , - 0.1262722394360882D-03 , 0.5260690089104692D-06 , & - 0.1024695933771225D-08 , 0.7740747599442036D-12 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.1226682861356967D-01 , & - 0.1247095984325278D-03 , 0.5177125873338510D-06 , - 0.1004835019494094D-08 , & 0.7563732755193877D-12 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.1215859419033532D-01 , - 0.1231716228967431D-03 , & 0.5095172846081312D-06 , - 0.9854262348515021D-09 , 0.7391362138683174D-12 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.1205168411887681D-01 , - 0.1216578435688045D-03 , 0.5014794683929009D-06 , & - 0.9664578069263304D-09 , 0.7223498684019295D-12 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.1194607796868199D-01 , & - 0.1201678014876039D-03 , 0.4935955992773303D-06 , - 0.9479183059155129D-09 , & 0.7060009801489765D-12 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.1184175567974072D-01 , - 0.1187010477409219D-03 , & 0.4858622281555661D-06 , - 0.9297966341550579D-09 , 0.6900767218179181D-12 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.1173869755512107D-01 , - 0.1172571432206584D-03 , 0.4782759936756450D-06 , & - 0.9120820155098342D-09 , 0.6745646824580683D-12 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.1163688425374266D-01 , & - 0.1158356583850453D-03 , 0.4708336197692872D-06 , - 0.8947639851363238D-09 , & 0.6594528527135583D-12 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.1153629678328707D-01 , - 0.1144361730269096D-03 , & 0.4635319132562541D-06 , - 0.8778323795963895D-09 , 0.6447296106390535D-12 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.1143691649323715D-01 , - 0.1130582760477534D-03 , 0.4563677615205331D-06 , & - 0.8612773273084929D-09 , 0.6303837080538180D-12 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.1133872506812639D-01 , & - 0.1117015652385780D-03 , 0.4493381302613174D-06 , - 0.8450892393354971D-09 , & 0.6164042574216804D-12 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.1124170452079696D-01 , - 0.1103656470647109D-03 , & 0.4424400613038914D-06 , - 0.8292588004695774D-09 , 0.6027807192133423D-12 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.1114583718591694D-01 , - 0.1090501364577771D-03 , 0.4356706704843351D-06 , & - 0.8137769606378804D-09 , 0.5895028897597683D-12 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.1105110571357262D-01 , & - 0.1077546566123012D-03 , 0.4290271455943706D-06 , - 0.7986349265926397D-09 , & 0.5765608895567056D-12 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.1095749306300318D-01 , - 0.1064788387877051D-03 , & 0.4225067443887490D-06 , - 0.7838241538848297D-09 , 0.5639451520098968D-12 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.1086498249648135D-01 , - 0.1052223221156392D-03 , 0.4161067926535715D-06 , & - 0.7693363391118955D-09 , 0.5516464126039364D-12 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.1077355757323844D-01 , & - 0.1039847534112353D-03 , 0.4098246823275044D-06 , - 0.7551634124166240D-09 , & 0.5396556984673597D-12 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.1068320214366840D-01 , - 0.1027657869911880D-03 , & 0.4036578696886545D-06 , - 0.7412975302589611D-09 , 0.5279643183429345D-12 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.1059390034350615D-01 , - 0.1015650844946603D-03 , 0.3976038735866929D-06 , & - 0.7277310684118202D-09 , 0.5165638529156025D-12 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.1050563658819514D-01 , & - 0.1003823147096725D-03 , 0.3916602737318948D-06 , - 0.7144566152008123D-09 , & 0.5054461455063260D-12 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.1041839556734244D-01 , - 0.9921715340358077D-04 , & 0.3858247090333303D-06 , - 0.7014669649664573D-09 , 0.4946032931071733D-12 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.1033216223936393D-01 , - 0.9806928315884611D-04 , 0.3800948759908423D-06 , & - 0.6887551117539653D-09 , 0.4840276377544905D-12 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.1024692182609921D-01 , & - 0.9693839321123900D-04 , 0.3744685271263201D-06 , - 0.6763142431955715D-09 , & 0.4737117582055697D-12 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.1016265980767198D-01 , - 0.9582417929385775D-04 , & 0.3689434694692531D-06 , - 0.6641377346126641D-09 , 0.4636484619338278D-12 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.1007936191739396D-01 , - 0.9472634348434077D-04 , 0.3635175630832439D-06 , & - 0.6522191433055006D-09 , 0.4538307774107199D-12 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.9997014136786999D-02 , & - 0.9364459405613028D-04 , 0.3581887196366334D-06 , - 0.6405522030331800D-09 , & 0.4442519466705298D-12 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.9915602690727991D-02 , - 0.9257864533376361D-04 , & 0.3529549010162290D-06 , - 0.6291308186778951D-09 , 0.4349054181475592D-12 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.9835114042605425D-02 , - 0.9152821755074671D-04 , 0.3478141179765922D-06 , & - 0.6179490610741752D-09 , 0.4257848397651887D-12 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.9755534889745527D-02 , & - 0.9049303671311570D-04 , 0.3427644288384630D-06 , - 0.6070011620276139D-09 , & 0.4168840522905375D-12 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.9676852158774608D-02 , - 0.8947283446450411D-04 , & 0.3378039382161377D-06 , - 0.5962815094779545D-09 , 0.4081970829145897D-12 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.9599053001153775D-02 , - 0.8846734795556042D-04 , 0.3329307957862377D-06 , & - 0.5857846428289766D-09 , 0.3997181390704075D-12 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.9522124788775092D-02 , & - 0.8747631971628433D-04 , 0.3281431950905108D-06 , - 0.5755052484268664D-09 , & 0.3914416024705919D-12 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.9446055109731274D-02 , - 0.8649949753257913D-04 , & 0.3234393723778849D-06 , - 0.5654381551946534D-09 , 0.3833620233653333D-12 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.9370831764020468D-02 , - 0.8553663432406253D-04 , 0.3188176054715871D-06 , & - 0.5555783303909379D-09 , 0.3754741149924662D-12 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.9296442759485712D-02 , & - 0.8458748802671394D-04 , 0.3142762126770061D-06 , - 0.5459208755219983D-09 , & 0.3677727482377000D-12 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.9222876307770564D-02 , - 0.8365182147764299D-04 , & 0.3098135517172551D-06 , - 0.5364610223780375D-09 , 0.3602529464787313D-12 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.9150120820372375D-02 , - 0.8272940230291300D-04 , 0.3054280187000861D-06 , & - 0.5271941291984115D-09 , 0.3529098806132156D-12 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.9078164904798670D-02 , & - 0.8182000280842463D-04 , 0.3011180471155645D-06 , - 0.5181156769621117D-09 , & 0.3457388642641352D-12 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.9006997360707474D-02 , - 0.8092339987238549D-04 , & 0.2968821068573185D-06 , - 0.5092212657867326D-09 , 0.3387353491465035D-12 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.8936607176309782D-02 , - 0.8003937484262966D-04 , 0.2927187032814400D-06 , & - 0.5005066114617255D-09 , 0.3318949206114549D-12 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.8866983524675652D-02 , & - 0.7916771343445971D-04 , 0.2886263762830867D-06 , - 0.4919675420738315D-09 , & 0.3252132933329048D-12 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.8798115760198845D-02 , - 0.7830820563200393D-04 , & 0.2846036994036966D-06 , - 0.4835999947483714D-09 , 0.3186863071515417D-12 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.8729993415119833D-02 , - 0.7746064559184445D-04 , 0.2806492789627292D-06 , & - 0.4754000124921611D-09 , 0.3123099230625414D-12 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.8662606196097085D-02 , & - 0.7662483154875550D-04 , 0.2767617532127553D-06 , - 0.4673637411337783D-09 , & 0.3060802193410502D-12 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.8595943980963489D-02 , - 0.7580056572510882D-04 , & 0.2729397915242757D-06 , - 0.4594874263717631D-09 , 0.2999933878105267D-12 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.8529996815336581D-02 , - 0.7498765424002022D-04 , 0.2691820935825253D-06 , & - 0.4517674108940841D-09 , 0.2940457302243035D-12 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.8464754909501654D-02 , & - 0.7418590702310698D-04 , 0.2654873886172823D-06 , - 0.4442001316083657D-09 , & 0.2882336547870384D-12 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.8400208635263818D-02 , - 0.7339513772925066D-04 , & 0.2618544346493644D-06 , - 0.4367821169491158D-09 , 0.2825536727887559D-12 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.8336348522905795D-02 , - 0.7261516365592546D-04 , 0.2582820177602661D-06 , & - 0.4295099842729629D-09 , 0.2770023953573136D-12 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.8273165258106480D-02 , & - 0.7184580566137625D-04 , 0.2547689513770792D-06 , - 0.4223804373250809D-09 , & 0.2715765303148422D-12 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.8210649679116645D-02 , - 0.7108688808703093D-04 , & 0.2513140755870062D-06 , - 0.4153902638029537D-09 , 0.2662728791550598D-12 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.8148792773810708D-02 , - 0.7033823867970742D-04 , 0.2479162564618127D-06 , & - 0.4085363329779661D-09 , 0.2610883341106964D-12 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.8087585676886328D-02 , & - 0.6959968851672105D-04 , 0.2445743854053588D-06 , - 0.4018155933988485D-09 , & 0.2560198753265827D-12 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.8027019667105634D-02 , - 0.6887107193262961D-04 , & 0.2412873785183727D-06 , - 0.3952250706643093D-09 , 0.2510645681273246D-12 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.7967086164567941D-02 , - 0.6815222644747113D-04 , 0.2380541759795321D-06 , & - 0.3887618652617871D-09 , 0.2462195603755939D-12 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.7907776728158934D-02 , & - 0.6744299269810678D-04 , 0.2348737414494033D-06 , - 0.3824231504834873D-09 , & 0.2414820799272756D-12 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.7849083052826529D-02 , - 0.6674321436866593D-04 , & 0.2317450614798419D-06 , - 0.3762061703854034D-09 , 0.2368494321573061D-12 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.7790996967126878D-02 , - 0.6605273812509963D-04 , 0.2286671449499282D-06 , & - 0.3701082378282316D-09 , 0.2323189975824283D-12 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.7733510430719523D-02 , & - 0.6537141355016500D-04 , 0.2256390225124348D-06 , - 0.3641267325685832D-09 , & 0.2278882295567495D-12 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.7676615531933460D-02 , - 0.6469909308019604D-04 , & 0.2226597460563386D-06 , - 0.3582590994099053D-09 , 0.2235546520453726D-12 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.7620304485413203D-02 , - 0.6403563194372927D-04 , 0.2197283881853675D-06 , & - 0.3525028464119846D-09 , 0.2193158574738684D-12 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.7564569629673411D-02 , & - 0.6338088810004386D-04 , 0.2168440417041783D-06 , - 0.3468555431423116D-09 , & 0.2151695046404801D-12 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.7509403424967329D-02 , - 0.6273472218211409D-04 , & 0.2140058191307845D-06 , - 0.3413148190031222D-09 , 0.2111133167135137D-12 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.7454798450949500D-02 , - 0.6209699743814511D-04 , 0.2112128522105102D-06 , & - 0.3358783615869300D-09 , 0.2071450792794954D-12 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.7400747404504799D-02 , & - 0.6146757967582443D-04 , 0.2084642914485908D-06 , - 0.3305439150916698D-09 , & 0.2032626384627798D-12 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.7347243097540340D-02 , - 0.6084633720707558D-04 , & 0.2057593056522698D-06 , - 0.3253092787782180D-09 , 0.1994638991039140D-12 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.7294278455109203D-02 , - 0.6023314079690678D-04 , 0.2030970814949603D-06 , & - 0.3201723054883410D-09 , 0.1957468230048807D-12 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.7241846513013501D-02 , & - 0.5962786360806855D-04 , 0.2004768230731971D-06 , - 0.3151309001790439D-09 , & 0.1921094272178809D-12 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.7189940416002537D-02 , - 0.5903038115228574D-04 , & 0.1978977514937321D-06 , - 0.3101830185269995D-09 , 0.1885497824027977D-12 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.7138553415740146D-02 , - 0.5844057124007195D-04 , 0.1953591044627411D-06 , & - 0.3053266655614394D-09 , 0.1850660112318118D-12 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.7087678868865859D-02 , & - 0.5785831393222971D-04 , 0.1928601358876892D-06 , - 0.3005598943398691D-09 , & 0.1816562868468427D-12 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.7037310235126402D-02 , - 0.5728349149282723D-04 , & 0.1904001154911220D-06 , - 0.2958808046652399D-09 , 0.1783188313684841D-12 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.6987441075399552D-02 , - 0.5671598834170408D-04 , 0.1879783284282725D-06 , & - 0.2912875418291763D-09 , 0.1750519144450562D-12 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.6938065050032450D-02 , & - 0.5615569101105974D-04 , 0.1855940749268471D-06 , - 0.2867782954139038D-09 , & 0.1718538518631693D-12 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.6889175916953549D-02 , - 0.5560248810024415D-04 , & 0.1832466699248568D-06 , - 0.2823512981084458D-09 , 0.1687230041886908D-12 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.6840767529946135D-02 , - 0.5505627023293870D-04 , 0.1809354427233992D-06 , & - 0.2780048245691569D-09 , 0.1656577754578360D-12 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.6792833836933066D-02 , & - 0.5451693001507888D-04 , 0.1786597366475052D-06 , - 0.2737371903114974D-09 , & 0.1626566119086993D-12 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.6745368878260188D-02 , - 0.5398436199337293D-04 , & 0.1764189087143266D-06 , - 0.2695467506312123D-09 , 0.1597180007512806D-12 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.6698366785182286D-02 , - 0.5345846261657135D-04 , 0.1742123293171454D-06 , & - 0.2654318995694810D-09 , 0.1568404689850644D-12 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.6651821778062186D-02 , & - 0.5293913019425417D-04 , 0.1720393819040823D-06 , - 0.2613910688838065D-09 , & 0.1540225822378404D-12 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.6605728164906356D-02 , - 0.5242626485976833D-04 , & 0.1698994626779531D-06 , - 0.2574227270713434D-09 , 0.1512629436564386D-12 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.6560080339786960D-02 , - 0.5191976853249809D-04 , 0.1677919802978121D-06 , & - 0.2535253784094052D-09 , 0.1485601928250946D-12 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.6514872781323294D-02 , & - 0.5141954488129509D-04 , 0.1657163555893695D-06 , - 0.2496975620255025D-09 , & 0.1459130047191336D-12 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.6470100051230429D-02 , - 0.5092549928915650D-04 , & 0.1636720212645439D-06 , - 0.2459378509969192D-09 , 0.1433200886933696D-12 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.6425756792713708D-02 , - 0.5043753881673733D-04 , 0.1616584216403038D-06 , & - 0.2422448514619041D-09 , 0.1407801874928293D-12 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.6381837729246394D-02 , & - 0.4995557217045127D-04 , 0.1596750123797110D-06 , - 0.2386172017825892D-09 , & 0.1382920763117327D-12 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.6338337663035780D-02 , - 0.4947950966772364D-04 , & 0.1577212602253644D-06 , - 0.2350535717065397D-09 , 0.1358545618651552D-12 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.6295251473680056D-02 , - 0.4900926320473681D-04 , 0.1557966427464121D-06 , & - 0.2315526615639232D-09 , 0.1334664814973018D-12 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.6252574116784138D-02 , & - 0.4854474622420029D-04 , 0.1539006480892333D-06 , - 0.2281132014824770D-09 , & 0.1311267023141624D-12 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.6210300622775436D-02 , - 0.4808587368563658D-04 , & 0.1520327747414008D-06 , - 0.2247339506365863D-09 , 0.1288341203507246D-12 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.6168426095416941D-02 , - 0.4763256203296403D-04 , 0.1501925312885051D-06 , & - 0.2214136964947052D-09 , 0.1265876597489969D-12 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.6126945710658414D-02 , & - 0.4718472916600614D-04 , 0.1483794361895549D-06 , - 0.2181512541093649D-09 , & 0.1243862719752381D-12 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.6085854715363137D-02 , - 0.4674229441112082D-04 , & 0.1465930175521312D-06 , - 0.2149454654167630D-09 , 0.1222289350544644D-12 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.6045148426087608D-02 , - 0.4630517849277751D-04 , 0.1448328129143227D-06 , & - 0.2117951985578042D-09 , 0.1201146528295718D-12 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.6004822227927120D-02 , & - 0.4587330350619899D-04 , 0.1430983690337761D-06 , - 0.2086993472207964D-09 , & 0.1180424542447917D-12 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.5964871573186028D-02 , - 0.4544659288859735D-04 , & 0.1413892416743046D-06 , - 0.2056568299891895D-09 , 0.1160113926424549D-12 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.5925291980447398D-02 , - 0.4502497139485730D-04 , 0.1397049954124059D-06 , & - 0.2026665897322015D-09 , 0.1140205450969707D-12 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.5886079033306539D-02 , & - 0.4460836507015010D-04 , 0.1380452034347773D-06 , - 0.1997275929886708D-09 , & 0.1120690117538131D-12 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.5847228379297500D-02 , - 0.4419670122487058D-04 , & 0.1364094473474334D-06 , - 0.1968388293790542D-09 , 0.1101559151955903D-12 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.5808735728808139D-02 , - 0.4378990840980063D-04 , 0.1347973169883023D-06 , & - 0.1939993110314139D-09 , 0.1082803998257885D-12 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.5770596853968063D-02 , & - 0.4338791639133772D-04 , 0.1332084102426348D-06 , - 0.1912080720200504D-09 , & 0.1064416312690497D-12 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.5732807587783825D-02 , - 0.4299065612953648D-04 , & 0.1316423328715228D-06 , - 0.1884641678338254D-09 , 0.1046387957984406D-12 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.5695363822863972D-02 , - 0.4259805975234726D-04 , 0.1300986983284723D-06 , & - 0.1857666748318053D-09 , 0.1028710997626636D-12 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.5658261510573248D-02 , & - 0.4221006053448231D-04 , 0.1285771275958079D-06 , - 0.1831146897394314D-09 , & 0.1011377690465432D-12 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.5621496660010428D-02 , - 0.4182659287481078D-04 , & 0.1270772490177921D-06 , - 0.1805073291460934D-09 , 0.9943804853979228D-13 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.5585065337085107D-02 , - 0.4144759227503874D-04 , 0.1255986981407901D-06 , & - 0.1779437290212291D-09 , 0.9777120162459723D-13 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.5548963663411385D-02 , & - 0.4107299531686294D-04 , 0.1241411175499152D-06 , - 0.1754230442311685D-09 , & 0.9613650967066484D-13 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.5513187815601775D-02 , - 0.4070273964338029D-04 , & 0.1227041567236553D-06 , - 0.1729444480922077D-09 , 0.9453327155961447D-13 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.5477734024214849D-02 , - 0.4033676393733376D-04 , 0.1212874718787385D-06 , & - 0.1705071319136291D-09 , 0.9296080320960523D-13 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.5442598572893892D-02 , & - 0.3997500790152448D-04 , 0.1198907258250725D-06 , - 0.1681103045634322D-09 , & 0.9141843712041985D-13 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.5407777797489238D-02 , - 0.3961741223932262D-04 , & 0.1185135878229791D-06 , - 0.1657531920436538D-09 , 0.8990552193059568D-13 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.5373268085148524D-02 , - 0.3926391863512256D-04 , 0.1171557334421259D-06 , & - 0.1634350370741494D-09 , 0.8842142198571827D-13 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.5339065873652345D-02 , & - 0.3891446973744772D-04 , 0.1158168444320328D-06 , - 0.1611550987008106D-09 , & 0.8696551692748268D-13 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.5305167650330955D-02 , - 0.3856900913820136D-04 , & 0.1144966085802063D-06 , - 0.1589126518888659D-09 , 0.8553720127914401D-13 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.5271569951410567D-02 , - 0.3822748135635983D-04 , 0.1131947195883471D-06 , & - 0.1567069871509274D-09 , 0.8413588405769450D-13 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.5238269361177082D-02 , & - 0.3788983182010998D-04 , 0.1119108769445229D-06 , - 0.1545374101734257D-09 , & 0.8276098839022511D-13 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.5205262511192582D-02 , - 0.3755600684972932D-04 , & 0.1106447857997171D-06 , - 0.1524032414550490D-09 , 0.8141195114266989D-13 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.5172546079581473D-02 , - 0.3722595364135955D-04 , 0.1093961568492237D-06 , & - 0.1503038159577561D-09 , 0.8008822256108179D-13 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.5140116790070992D-02 , & - 0.3689962024862962D-04 , 0.1081647062078300D-06 , - 0.1482384827523919D-09 , & 0.7878926591439395D-13 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.5107971411538999D-02 , - 0.3657695556938165D-04 , & 0.1069501553050064D-06 , - 0.1462066047010350D-09 , 0.7751455716401713D-13 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.5076106757105582D-02 , - 0.3625790932820193D-04 , 0.1057522307663776D-06 , & - 0.1442075581215423D-09 , 0.7626358462708114D-13 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.5044519683462549D-02 , & - 0.3594243206144866D-04 , 0.1045706643056848D-06 , - 0.1422407324732209D-09 , & 0.7503584865676185D-13 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.5013207090173033D-02 , - 0.3563047510218700D-04 , & 0.1034051926178125D-06 , - 0.1403055300482785D-09 , 0.7383086133024579D-13 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.4982165918922052D-02 , - 0.3532199056484884D-04 , 0.1022555572722087D-06 , & - 0.1384013656679065D-09 , 0.7264814614353121D-13 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.1428571428571452D+00 , - 0.7071922873799152D-02 , 0.1841354341576480D-03 , & - 0.3305723274634706D-05 , 0.4558636501258938D-07 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.1428571425121142D+00 , & - 0.7071920888234207D-02 , 0.1841309916580316D-03 , - 0.3300791549573212D-05 , & 0.4309777687280559D-07 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.1428571291038197D+00 , - 0.7071887238533979D-02 , & 0.1840987126432859D-03 , - 0.3286728973847372D-05 , 0.4074686273225630D-07 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.1428570386466976D+00 , - 0.7071745720922082D-02 , 0.1840150371429491D-03 , & - 0.3264560101063491D-05 , 0.3852592440964743D-07 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.1428567173935553D+00 , & - 0.7071382692194166D-02 , 0.1838605633044070D-03 , - 0.3235223177833524D-05 , & 0.3642769796171300D-07 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.1428558952497274D+00 , - 0.7070656738201937D-02 , & 0.1836195734003852D-03 , - 0.3199576647912918D-05 , 0.3444532900895190D-07 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.1428541693296458D+00 , - 0.7069406927061015D-02 , 0.1832796048057684D-03 , & - 0.3158405193863151D-05 , 0.3257234947212718D-07 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.1428509957978146D+00 , & - 0.7067459810279146D-02 , 0.1828310620907967D-03 , - 0.3112425347990448D-05 , & 0.3080265563843546D-07 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.1428456883909842D+00 , - 0.7064635318567076D-02 , & 0.1822668666871279D-03 , - 0.3062290702181936D-05 , 0.2913048748093814D-07 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.1428374222434778D+00 , - 0.7060751684175475D-02 , 0.1815821408689284D-03 , & - 0.3008596744270997D-05 , 0.2755040915925680D-07 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.1428252418362274D+00 , & - 0.7055629508067132D-02 , 0.1807739230548255D-03 , - 0.2951885346705427D-05 , & 0.2605729063369057D-07 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.1428080720649274D+00 , - 0.7049095077962935D-02 , & 0.1798409116798607D-03 , - 0.2892648931556846D-05 , 0.2464629032882851D-07 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.1427847315763389D+00 , - 0.7040983032182894D-02 , 0.1787832351110468D-03 , & - 0.2831334334289322D-05 , 0.2331283878641736D-07 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.1427539476564528D+00 , & - 0.7031138454138024D-02 , 0.1776022452871654D-03 , - 0.2768346387192262D-05 , & 0.2205262325072057D-07 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.1427143720719983D+00 , - 0.7019418473222577D-02 , & 0.1763003329543425D-03 , - 0.2704051241969637D-05 , 0.2086157313287414D-07 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.1426645973695188D+00 , - 0.7005693439623949D-02 , 0.1748807625449354D-03 , & - 0.2638779449658953D-05 , 0.1973584630383410D-07 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.1426031732255890D+00 , & - 0.6989847733131341D-02 , 0.1733475249094596D-03 , - 0.2572828814821676D-05 , & 0.1867181616840949D-07 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.1425286225192176D+00 , - 0.6971780259313120D-02 , & 0.1717052062607327D-03 , - 0.2506467039797499D-05 , 0.1766605947561545D-07 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.1424394568644127D+00 , - 0.6951404680381070D-02 , 0.1699588718270761D-03 , & - 0.2439934173741767D-05 , 0.1671534482315796D-07 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.1423341913984876D+00 , & - 0.6928649422607998D-02 , 0.1681139628381786D-03 , - 0.2373444880163801D-05 , & 0.1581662181629166D-07 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.1422113586710407D+00 , - 0.6903457497258613D-02 , & 0.1661762055839340D-03 , - 0.2307190535749161D-05 , 0.1496701084358072D-07 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.1420695215206252D+00 , - 0.6875786167582486D-02 , 0.1641515313939621D-03 , & - 0.2241341172376492D-05 , 0.1416379343424941D-07 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.1419072848617988D+00 , & - 0.6845606490456491D-02 , 0.1620460064843430D-03 , - 0.2176047273425505D-05 , & 0.1340440316384093D-07 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.1417233063352892D+00 , - 0.6812902757710767D-02 , & 0.1598657707089700D-03 , - 0.2111441434713070D-05 , 0.1268641707681708D-07 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.1415163057991267D+00 , - 0.6777671858988976D-02 , 0.1576169843364950D-03 , & - 0.2047639899685590D-05 , 0.1200754759653576D-07 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.1412850736593947D+00 , & - 0.6739922585145534D-02 , 0.1553057820506324D-03 , - 0.1984743977834602D-05 , & 0.1136563489474220D-07 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.1410284780562848D+00 , - 0.6699674888638018D-02 , & 0.1529382334421547D-03 , - 0.1922841354685693D-05 , 0.1075863969431176D-07 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.1407454709349170D+00 , - 0.6656959115103281D-02 , 0.1505203093257203D-03 , & - 0.1862007301135354D-05 , 0.1018463648049099D-07 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.1404350930413166D+00 , & - 0.6611815218284148D-02 , 0.1480578532741697D-03 , - 0.1802305789373735D-05 , & 0.9641807097305156D-08 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.1400964778924337D+00 , - 0.6564291968676668D-02 , & 0.1455565578175324D-03 , - 0.1743790522130643D-05 , 0.9128434707140978D-08 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.1397288547754815D+00 , - 0.6514446164673084D-02 , 0.1430219448040740D-03 , & - 0.1686505881515341D-05 , 0.8642898092774930D-08 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.1393315508364579D+00 , & - 0.6462341853563642D-02 , 0.1404593494666427D-03 , - 0.1630487803285393D-05 , & 0.8183666282307997D-08 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.1389039923207838D+00 , - 0.6408049568512805D-02 , & 0.1378739077796728D-03 , - 0.1575764581973950D-05 , 0.7749293478588186D-08 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.1384457050307569D+00 , - 0.6351645586525734D-02 , 0.1352705467307629D-03 , & - 0.1522357611926434D-05 , 0.7338414275759027D-08 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.1379563140652058D+00 , & - 0.6293211211454437D-02 , 0.1326539771660628D-03 , - 0.1470282068944876D-05 , & 0.6949739146567511D-08 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.1374355429065151D+00 , - 0.6232832085245911D-02 , & 0.1300286889010215D-03 , - 0.1419547536909322D-05 , 0.6582050185003360D-08 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.1368832119192256D+00 , - 0.6170597529894671D-02 , 0.1273989478176061D-03 , & - 0.1370158583439283D-05 , 0.6234197089725494D-08 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.1362992363228534D+00 , & - 0.6106599921918152D-02 , 0.1247687946961371D-03 , - 0.1322115288372598D-05 , & 0.5905093374564906D-08 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.1356836236995194D+00 , - 0.6040934100615384D-02 , & 0.1221420455545710D-03 , - 0.1275413728572942D-05 , 0.5593712793178330D-08 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.1350364710945582D+00 , - 0.5973696810887937D-02 , 0.1195222932906189D-03 , & - 0.1230046422329281D-05 , 0.5299085965667215D-08 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.1343579617655561D+00 , & - 0.5904986180989114D-02 , 0.1169129104426637D-03 , - 0.1186002736379515D-05 , & 0.5020297195673913D-08 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.1336483616323479D+00 , - 0.5834901235215087D-02 , & 0.1143170529042092D-03 , - 0.1143269258375419D-05 , 0.4756481467124394D-08 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.1329080154774305D+00 , - 0.5763541441253762D-02 , 0.1117376644436979D-03 , & - 0.1101830137405524D-05 , 0.4506821610406311D-08 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.1321373429430993D+00 , & - 0.5691006291656774D-02 , 0.1091774818971113D-03 , - 0.1061667395005926D-05 , & 0.4270545628355129D-08 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.1313368343684186D+00 , - 0.5617394918692502D-02 , & 0.1066390409149404D-03 , - 0.1022761208915223D-05 , 0.4046924172971446D-08 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.1305070465059432D+00 , - 0.5542805741667555D-02 , 0.1041246821580051D-03 , & - 0.9850901716679212D-06 , 0.3835268164311296D-08 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.1296485981549553D+00 , & - 0.5467336145667101D-02 , 0.1016365578483118D-03 , - 0.9486315259700207D-06 , & 0.3634926543480161D-08 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.1287621657448753D+00 , - 0.5391082190555665D-02 , & 0.9917663859175889D-04 , - 0.9133613786602108D-06 , 0.3445284152122292D-08 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.1278484788995046D+00 , - 0.5314138348997610D-02 , 0.9674672039915446D-04 , & - 0.8792548949296861D-06 , 0.3265759731231285D-08 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.1269083160098394D+00 , & - 0.5236597272194964D-02 , 0.9434843184072481D-04 , - 0.8462864743520387D-06 , & 0.3095804032517301D-08 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.1259424998404012D+00 , - 0.5158549581998979D-02 , & 0.9198324127720586D-04 , - 0.8144299101617657D-06 , 0.2934898035952323D-08 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.1249518931913643D+00 , - 0.5080083688026335D-02 , 0.8965246411774639D-04 , & - 0.7836585331147639D-06 , 0.2782551267478576D-08 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.1239373946362207D+00 , & - 0.5001285628400231D-02 , 0.8735727006130246D-04 , - 0.7539453411664336D-06 , & 0.2638300211208231D-08 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.1228999343523266D+00 , - 0.4922238932737719D-02 , & 0.8509869028401524D-04 , - 0.7252631161120733D-06 , 0.2501706810765805D-08 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.1218404700594189D+00 , - 0.4843024506016438D-02 , 0.8287762454029998D-04 , & - 0.6975845282496969D-06 , 0.2372357054729357D-08 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.1207599830790743D+00 , & - 0.4763720531974119D-02 , 0.8069484815007929D-04 , - 0.6708822300468043D-06 , & 0.2249859641413946D-08 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.1196594745261116D+00 , - 0.4684402394722001D-02 , & 0.7855101884881867D-04 , - 0.6451289397195708D-06 , 0.2133844718511607D-08 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.1185399616411022D+00 , - 0.4605142617286773D-02 , 0.7644668348080595D-04 , & - 0.6202975155650138D-06 , 0.2023962693357408D-08 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.1174024742714614D+00 , & - 0.4526010815834218D-02 , 0.7438228451950219D-04 , - 0.5963610218236095D-06 , & 0.1919883109831912D-08 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.1162480515070259D+00 , - 0.4447073668369977D-02 , & 0.7235816640181064D-04 , - 0.5732927867912106D-06 , 0.1821293588137242D-08 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.1150777384745891D+00 , - 0.4368394896758164D-02 , 0.7037458166580077D-04 , & - 0.5510664538446756D-06 , 0.1727898823897917D-08 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.1138925832945594D+00 , & - 0.4290035260946064D-02 , 0.6843169688381287D-04 , - 0.5296560259950667D-06 , & 0.1639419643239357D-08 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.1126936342017094D+00 , - 0.4212052564332184D-02 , & 0.6652959838498360D-04 , - 0.5090359045353228D-06 , 0.1555592110687066D-08 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.1114819368309100D+00 , - 0.4134501669264938D-02 , 0.6466829776310206D-04 , & - 0.4891809223057571D-06 , 0.1476166686908896D-08 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.1102585316677712D+00 , & - 0.4057434521709788D-02 , 0.6284773716734925D-04 , - 0.4700663720602809D-06 , & 0.1400907433491778D-08 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.1090244516632424D+00 , - 0.3980900184173110D-02 , & 0.6106779437491451D-04 , - 0.4516680303787403D-06 , 0.1329591262103739D-08 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.1077807200104505D+00 , - 0.3904944876021365D-02 , 0.5932828764574109D-04 , & - 0.4339621775359574D-06 , 0.1262007225542344D-08 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.1065283480813750D+00 , & - 0.3829612020383659D-02 , 0.5762898036074373D-04 , - 0.4169256137057825D-06 , & 0.1197955848312371D-08 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.1052683335203534D+00 , - 0.3754942296874499D-02 , & 0.5596958544578538D-04 , - 0.4005356718485502D-06 , 0.1137248494509201D-08 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.1040016584908979D+00 , - 0.3680973699421183D-02 , 0.5434976958450776D-04 , & - 0.3847702276025943D-06 , 0.1079706770910400D-08 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.1027292880718469D+00 , & - 0.3607741598526459D-02 , 0.5276915722379852D-04 , - 0.3696077064747716D-06 , & 0.1025161963296776D-08 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.1014521687985053D+00 , - 0.3535278807342098D-02 , & 0.5122733437625731D-04 , - 0.3550270886011438D-06 , 0.9734545041362662D-09 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.1001712273440992D+00 , - 0.3463615650972293D-02 , 0.4972385222450574D-04 , & - 0.3410079113269115D-06 , 0.9244334698696538D-09 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.9888736933661914D-01 , & - 0.3392780038467541D-02 , 0.4825823053258106D-04 , - 0.3275302698342828D-06 , & 0.8779561061367585D-09 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.9760147830591066D-01 , - 0.3322797537009718D-02 , & 0.4682996086997236D-04 , - 0.3145748160280616D-06 , 0.8338873793757064D-09 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.9631441475571667D-01 , - 0.3253691447827439D-02 , 0.4543850965410807D-04 , & - 0.3021227558712714D-06 , 0.7920995533165264D-09 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.9502701535525571D-01 , & - 0.3185482883417230D-02 , 0.4408332101728990D-04 , - 0.2901558453469430D-06 , & 0.7524717889738470D-09 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.9374009224484717D-01 , - 0.3118190845681060D-02 , & 0.4276381950420489D-04 , - 0.2786563852072640D-06 , 0.7148897668223276D-09 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.9245443245004911D-01 , - 0.3051832304623656D-02 , 0.4147941260623224D-04 , & - 0.2676072146574631D-06 , 0.6792453299127789D-09 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.9117079739877045D-01 , & - 0.2986422277284542D-02 , 0.4022949313880620D-04 , - 0.2569917041090336D-06 , & 0.6454361467570168D-09 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.8988992253583629D-01 , - 0.2921973906609259D-02 , & 0.3901344146810509D-04 , - 0.2467937471251244D-06 , 0.6133653928756546D-09 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.8861251702953019D-01 , - 0.2858498539992221D-02 , 0.3783062759331087D-04 , & - 0.2369977516700329D-06 , 0.5829414499653722D-09 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.8733926356470728D-01 , & - 0.2796005807249970D-02 , 0.3668041309063278D-04 , - 0.2275886307647021D-06 , & 0.5540776217010476D-09 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.8607081821715742D-01 , - 0.2734503697808294D-02 , & 0.3556215292521148D-04 , - 0.2185517926408540D-06 , 0.5266918652435990D-09 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.8480781040400528D-01 , - 0.2673998636909946D-02 , 0.3447519713692570D-04 , & - 0.2098731304778728D-06 , 0.5007065375767612D-09 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.8355084290505085D-01 , & - 0.2614495560671209D-02 , 0.3341889240600666D-04 , - 0.2015390117986607D-06 , & 0.4760481558453323D-09 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.8230049195008851D-01 , - 0.2555997989835996D-02 , & 0.3239258350423995D-04 , - 0.1935362675934698D-06 , 0.4526471709140442D-09 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.8105730736738626D-01 , - 0.2498508102094925D-02 , 0.3139561463739284D-04 , & - 0.1858521812340349D-06 , 0.4304377534101128D-09 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.7982181278865461D-01 , & - 0.2442026802854326D-02 , 0.3042733068435391D-04 , - 0.1784744772341985D-06 , & 0.4093575915539563D-09 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.7859450590599969D-01 , - 0.2386553794356577D-02 , & 0.2948707833831596D-04 , - 0.1713913099075946D-06 , 0.3893477001216864D-09 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.7737585877651401D-01 , - 0.2332087643068025D-02 , 0.2857420715516667D-04 , & - 0.1645912519677662D-06 , 0.3703522399198292D-09 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.7616631817033012D-01 , & - 0.2278625845264846D-02 , 0.2768807051408385D-04 , - 0.1580632831113468D-06 , & 0.3523183471875349D-09 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.7496630595813190D-01 , - 0.2226164890759893D-02 , & 0.2682802649515995D-04 , - 0.1517967786205694D-06 , 0.3351959723743493D-09 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.7377621953429514D-01 , - 0.2174700324725550D-02 , 0.2599343867870738D-04 , & - 0.1457814980173774D-06 , 0.3189377277726052D-09 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.7259643227199705D-01 , & - 0.2124226807578201D-02 , 0.2518367687071980D-04 , - 0.1400075737977398D-06 , & 0.3034987435126696D-09 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.7142729400681387D-01 , - 0.2074738172900026D-02 , & 0.2439811775879209D-04 , - 0.1344655002714295D-06 , 0.2888365314568819D-09 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.7026913154549647D-01 , - 0.2026227483382777D-02 , 0.2363614550262726D-04 , & - 0.1291461225294640D-06 , 0.2749108565540098D-09 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.6912224919678227D-01 , & - 0.1978687084786322D-02 , 0.2289715226308562D-04 , - 0.1240406255585952D-06 , & 0.2616836152405731D-09 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.6798692932127615D-01 , - 0.1932108657912348D-02 , & 0.2218053867356422D-04 , - 0.1191405235197026D-06 , 0.2491187204985705D-09 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.6686343289759344D-01 , - 0.1886483268600166D-02 , 0.2148571425732545D-04 , & - 0.1144376492046005D-06 , 0.2371819932009598D-09 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.6575200010212411D-01 , & - 0.1841801415757697D-02 , 0.2081209779423136D-04 , - 0.1099241436836603D-06 , & 0.2258410593968728D-09 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.6465285089993260D-01 , - 0.1798053077446043D-02 , & 0.2015911764017918D-04 , - 0.1055924461547211D-06 , 0.2150652532079882D-09 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.6356618564446803D-01 , - 0.1755227755041018D-02 , 0.1952621200237951D-04 , & - 0.1014352840020181D-06 , 0.2048255250258596D-09 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.6249218568390147D-01 , & - 0.1713314515499049D-02 , 0.1891282917346331D-04 , - 0.9744566307226497D-07 , & 0.1950943547172885D-09 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.6143101397205974D-01 , - 0.1672302031758841D-02 , & 0.1831842772725936D-04 , - 0.9361685817360140D-07 , 0.1858456695612039D-09 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.6038281568206145D-01 , - 0.1632178621313329D-02 , 0.1774247667893899D-04 , & - 0.8994240380181635D-07 , 0.1770547666559244D-09 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.5934771882089983D-01 , & - 0.1592932282989425D-02 , 0.1718445561208745D-04 , - 0.8641608509709463D-07 , & 0.1686982395502462D-09 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.5832583484334190D-01 , - 0.1554550731975298D-02 , & 0.1664385477512535D-04 , - 0.8303192903347162D-07 , 0.1607539088655154D-09 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.5731725926364618D-01 , - 0.1517021433137269D-02 , 0.1612017514937819D-04 , & - 0.7978419584225683D-07 , 0.1532007566888533D-09 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.5632207226371614D-01 , & - 0.1480331632669891D-02 , 0.1561292849096397D-04 , - 0.7666737066982418D-07 , & 0.1460188645298995D-09 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.5534033929642278D-01 , - 0.1444468388124332D-02 , & 0.1512163734855179D-04 , - 0.7367615546942429D-07 , 0.1391893546450175D-09 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.5437211168293815D-01 , - 0.1409418596861149D-02 , 0.1464583505892764D-04 , & - 0.7080546112599462D-07 , 0.1326943345437889D-09 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.5341742720303237D-01 , & - 0.1375169022974675D-02 , 0.1418506572219631D-04 , - 0.6805039981236343D-07 , & 0.1265168445029466D-09 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.5247631067737510D-01 , - 0.1341706322736454D-02 , & 0.1373888415833854D-04 , - 0.6540627757469613D-07 , 0.1206408079225654D-09 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.5154877454098709D-01 , - 0.1309017068605867D-02 , 0.1330685584674537D-04 , & - 0.6286858714459086D-07 , 0.1150509843685391D-09 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.5063481940707332D-01 , & - 0.1277087771856208D-02 , 0.1288855685025350D-04 , - 0.6043300097481967D-07 , & 0.1097329251540126D-09 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.4973443462054898D-01 , - 0.1245904903864291D-02 , & 0.1248357372511193D-04 , - 0.5809536449535312D-07 , 0.1046729313205949D-09 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.4884759880065969D-01 , - 0.1215454916111837D-02 , 0.1209150341822528D-04 , & - 0.5585168958602141D-07 , 0.9985801388792630D-10 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.4797428037216281D-01 , & - 0.1185724258946304D-02 , 0.1171195315293210D-04 , - 0.5369814826189023D-07 , & 0.9527585624742005D-10 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.4711443808461371D-01 , - 0.1156699399148546D-02 , & 0.1134454030449878D-04 , - 0.5163106656722211D-07 , 0.9091477858289668D-10 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.4626802151936237D-01 , - 0.1128366836354045D-02 , 0.1098889226643196D-04 , & - 0.4964691867370390D-07 , 0.8676370420730313D-10 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.4543497158393665D-01 , & - 0.1100713118374001D-02 , 0.1064464630864282D-04 , - 0.4774232117848582D-07 , & 0.8281212771086148D-10 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.4461522099353418D-01 , - 0.1073724855461506D-02 , & 0.1031144942842425D-04 , - 0.4591402759743859D-07 , 0.7905008482174120D-10 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.4380869473941101D-01 , - 0.1047388733567521D-02 , 0.9988958195140256D-05 , & - 0.4415892304896104D-07 , 0.7546812388584587D-10 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.4301531054399834D-01 , & - 0.1021691526630289D-02 , 0.9676838589463358D-05 , - 0.4247401912359198D-07 , & 0.7205727887744212D-10 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.4223497930263184D-01 , - 0.9966201079410380D-03 , & 0.9374765837938742D-05 , - 0.4085644893464182D-07 , 0.6880904385724395D-10 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.4146760551181109D-01 , - 0.9721614606275453D-03 , 0.9082424243595805D-05 , & - 0.3930346234501872D-07 , 0.6571534879913884D-10 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.4071308768396248D-01 , & - 0.9483026872965110D-03 , 0.8799507013279940D-05 , - 0.3781242136543652D-07 , & 0.6276853671112288D-10 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.3997131874870188D-01 , - 0.9250310188742509D-03 , & 0.8525716082323831D-05 , - 0.3638079571917844D-07 , 0.5996134198007793D-10 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.3924218644063601D-01 , - 0.9023338226843301D-03 , 0.8260761937133323D-05 , & - 0.3500615856862269D-07 , 0.5728686987391593D-10 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.3852557367376606D-01 , & - 0.8801986097994867D-03 , 0.8004363436217233D-05 , - 0.3368618239876080D-07 , & 0.5473857713825998D-10 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.3782135890259845D-01 , - 0.8586130417043729D-03 , & 0.7756247630152225D-05 , - 0.3241863505299813D-07 , 0.5231025362830985D-10 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.3712941647007413D-01 , - 0.8375649363040099D-03 , 0.7516149580929826D-05 , & - 0.3120137591655659D-07 , 0.4999600491976262D-10 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.3644961694246998D-01 , & - 0.8170422733121809D-03 , 0.7283812181100707D-05 , - 0.3003235224288295D-07 , & 0.4779023584577765D-10 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.3578182743143572D-01 , - 0.7970331990525455D-03 , & 0.7058985973093871D-05 , - 0.2890959561852200D-07 , 0.4568763490986155D-10 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.3512591190335754D-01 , - 0.7775260307043381D-03 , 0.6841428969058138D-05 , & - 0.2783121856199865D-07 , 0.4368315952731378D-10 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.3448173147624185D-01 , & - 0.7585092600230008D-03 , 0.6630906471539150D-05 , - 0.2679541125231752D-07 , & 0.4177202205044212D-10 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.3384914470435030D-01 , - 0.7399715565655494D-03 , & 0.6427190895282168D-05 , - 0.2580043838279830D-07 , 0.3994967653525072D-10 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.3322800785080913D-01 , - 0.7219017704488129D-03 , 0.6230061590418905D-05 , & - 0.2484463613603106D-07 , 0.3821180620958063D-10 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.3261817514844094D-01 , & - 0.7042889346679278D-03 , 0.6039304667274793D-05 , - 0.2392640927584144D-07 , & 0.3655431160489452D-10 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.3201949904906707D-01 , - 0.6871222670011459D-03 , & 0.5854712823007402D-05 , - 0.2304422835224097D-07 , 0.3497329931594818D-10 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.3143183046155433D-01 , - 0.6703911715263647D-03 , 0.5676085170268741D-05 , & - 0.2219662701545018D-07 , 0.3346507135457107D-10 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.3085501897886148D-01 , & - 0.6540852397731240D-03 , 0.5503227068057758D-05 , - 0.2138219943515509D-07 , & 0.3202611506558175D-10 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.3028891309437107D-01 , - 0.6381942515333954D-03 , & 0.5335949954916065D-05 , - 0.2059959782128053D-07 , 0.3065309357464661D-10 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.2973336040778185D-01 , - 0.6227081753531231D-03 , 0.5174071184598598D-05 , & - 0.1984753004264836D-07 , 0.2934283673951265D-10 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.2918820782085180D-01 , & - 0.6076171687257758D-03 , 0.5017413864336983D-05 , - 0.1912475733999840D-07 , & 0.2809233257761773D-10 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.2865330172326553D-01 , - 0.5929115780077732D-03 , & 0.4865806695793803D-05 , - 0.1843009212993245D-07 , 0.2689871914452473D-10 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.2812848816892981D-01 , - 0.5785819380754145D-03 , 0.4719083818798128D-05 , & - 0.1776239589646667D-07 , 0.2575927683905626D-10 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.2761361304297490D-01 , & - 0.5646189717413953D-03 , 0.4577084657933362D-05 , - 0.1712057716695111D-07 , & 0.2467142111228013D-10 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.2710852221975585D-01 , - 0.5510135889485269D-03 , & 0.4439653772040002D-05 , - 0.1650358956922783D-07 , 0.2363269555875986D-10 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.2661306171213474D-01 , - 0.5377568857571523D-03 , 0.4306640706681948D-05 , & - 0.1591042996698476D-07 , 0.2264076536964051D-10 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.2612707781234491D-01 , & - 0.5248401431424234D-03 , 0.4177899849618973D-05 , - 0.1534013667037528D-07 , & 0.2169341112827474D-10 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.2565041722470355D-01 , - 0.5122548256160727D-03 , & 0.4053290289311669D-05 , - 0.1479178771903984D-07 , 0.2078852293009975D-10 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.2518292719046716D-01 , - 0.4999925796872636D-03 , 0.3932675676482654D-05 , & - 0.1426449923478413D-07 , 0.1992409480950435D-10 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.2472445560510275D-01 , & - 0.4880452321759409D-03 , 0.3815924088745903D-05 , - 0.1375742384124272D-07 , & 0.1909821945733673D-10 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.2427485112825700D-01 , - 0.4764047883916945D-03 , & 0.3702907898311204D-05 , - 0.1326974914795660D-07 , 0.1830908321360345D-10 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.2383396328667921D-01 , - 0.4650634301899526D-03 , 0.3593503642759470D-05 , & - 0.1280069629636190D-07 , 0.1755496132071918D-10 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.2340164257038428D-01 , & - 0.4540135139174652D-03 , 0.3487591898885323D-05 , - 0.1234951856529950D-07 , & 0.1683421342349664D-10 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.2297774052230400D-01 , - 0.4432475682576438D-03 , & 0.3385057159591055D-05 , - 0.1191550003371163D-07 , 0.1614527930277434D-10 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.2256210982169041D-01 , - 0.4327582919861834D-03 , 0.3285787713815013D-05 , & - 0.1149795429828897D-07 , 0.1548667483030842D-10 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.2215460436151507D-01 , & - 0.4225385516464851D-03 , 0.3189675529469914D-05 , - 0.1109622324389923D-07 , & 0.1485698813320659D-10 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.2175507932012816D-01 , - 0.4125813791543987D-03 , & 0.3096616139367184D-05 , - 0.1070967586472347D-07 , 0.1425487595683824D-10 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.2136339122739678D-01 , - 0.4028799693404139D-03 , 0.3006508530092338D-05 , & - 0.1033770713407343D-07 , 0.1367906021571172D-10 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.2097939802557321D-01 , & - 0.3934276774377328D-03 , 0.2919255033799976D-05 , - 0.9979736920962335D-08 , & 0.1312832472241118D-10 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.2060295912511663D-01 , - 0.3842180165237015D-03 , & 0.2834761222889958D-05 , - 0.9635208951557116D-08 , 0.1260151208519641D-10 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.2023393545569192D-01 , - 0.3752446549217260D-03 , 0.2752935807524611D-05 , & - 0.9303589813712252D-08 , 0.1209752076537875D-10 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.1987218951257146D-01 , & - 0.3665014135705721D-03 , 0.2673690535946496D-05 , - 0.8984368002859842D-08 , & 0.1161530228607259D-10 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.1951758539862983D-01 , - 0.3579822633668024D-03 , & 0.2596940097547798D-05 , - 0.8677053007570899D-08 , 0.1115385858433993D-10 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.1916998886216560D-01 , - 0.3496813224868681D-03 , 0.2522602028650853D-05 , & - 0.8381174433203898D-08 , 0.1071223949922411D-10 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.1882926733072854D-01 , & - 0.3415928536938500D-03 , 0.2450596620947986D-05 , - 0.8096281162080552D-08 , & 0.1028954038852125D-10 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.1849528994115615D-01 , - 0.3337112616341786D-03 , & 0.2380846832553526D-05 , - 0.7821940548709769D-08 , 0.9884899867549760D-11 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.1816792756599332D-01 , - 0.3260310901288017D-03 , 0.2313278201615656D-05 , & - 0.7557737648622541D-08 , 0.9497497663518082D-11 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.1784705283650456D-01 , & - 0.3185470194638051D-03 , 0.2247818762441775D-05 , - 0.7303274479460096D-08 , & 0.9126552579465187D-11 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.1753254016241880D-01 , - 0.3112538636838411D-03 , & 0.2184398964079788D-05 , - 0.7058169312972949D-08 , 0.8771320562019489D-11 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.1722426574860123D-01 , - 0.3041465678926893D-03 , 0.2122951591307302D-05 , & - 0.6822055996675930D-08 , 0.8431092867575792D-11 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.1692210760880396D-01 , & - 0.2972202055642135D-03 , 0.2063411687974218D-05 , - 0.6594583303931813D-08 , & 0.8105194321748484D-11 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.1662594557666751D-01 , - 0.2904699758672415D-03 , & 0.2005716482648149D-05 , - 0.6375414311298821D-08 , 0.7792981667251880D-11 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.1633566131409537D-01 , - 0.2838912010067432D-03 , 0.1949805316505078D-05 , & - 0.6164225801999160D-08 , 0.7493841995584750D-11 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.1605113831718573D-01 , & - 0.2774793235848100D-03 , 0.1895619573418331D-05 , - 0.5960707694447458D-08 , & 0.7207191258189122D-11 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.1577226191983484D-01 , - 0.2712299039833976D-03 , & 0.1843102612188912D-05 , - 0.5764562494785336D-08 , 0.6932472852937704D-11 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.1549891929515986D-01 , - 0.2651386177713777D-03 , 0.1792199700866663D-05 , & - 0.5575504772431396D-08 , 0.6669156282051286D-11 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.1523099945485718D-01 , & - 0.2592012531376839D-03 , 0.1742857953107862D-05 , - 0.5393260657681341D-08 , & 0.6416735877735502D-11 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.1496839324665213D-01 , - 0.2534137083530664D-03 , & 0.1695026266522183D-05 , - 0.5217567360454908D-08 , 0.6174729592052230D-11 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.1471099334992142D-01 , - 0.2477719892613752D-03 , 0.1648655262951820D-05 , & - 0.5048172709287269D-08 , 0.5942677847679820D-11 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.1445869426963116D-01 , & - 0.2422722068024675D-03 , 0.1603697230636286D-05 , - 0.4884834709732701D-08 , & 0.5720142446435846D-11 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.1421139232868817D-01 , - 0.2369105745678506D-03 , & 0.1560106068210786D-05 , - 0.4727321121361628D-08 , 0.5506705532574932D-11 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.1396898565882561D-01 , - 0.2316834063905828D-03 , 0.1517837230490965D-05 , & - 0.4575409052579193D-08 , 0.5301968608048867D-11 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.1373137419009182D-01 , & - 0.2265871139698761D-03 , 0.1476847675990562D-05 , - 0.4428884572502436D-08 , & 0.5105551597036221D-11 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.1349845963908025D-01 , - 0.2216182045321414D-03 , & 0.1437095816129909D-05 , - 0.4287542339198686D-08 , 0.4917091957232840D-11 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.1327014549596363D-01 , - 0.2167732785287239D-03 , 0.1398541466083779D-05 , & - 0.4151185243583675D-08 , 0.4736243835485858D-11 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.1304633701043213D-01 , & - 0.2120490273712435D-03 , 0.1361145797223807D-05 , - 0.4019624068325390D-08 , & 0.4562677265503843D-11 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.1282694117662124D-01 , - 0.2074422312051578D-03 , & 0.1324871291110085D-05 , - 0.3892677161122201D-08 , 0.4396077405489010D-11 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.1261186671709066D-01 , - 0.2029497567216615D-03 , 0.1289681694984533D-05 , & - 0.3770170121740595D-08 , 0.4236143813639092D-11 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.1240102406597640D-01 , & - 0.1985685550091877D-03 , 0.1255541978728516D-05 , - 0.3651935502251865D-08 , & 0.4082589759608298D-11 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.1219432535133129D-01 , - 0.1942956594436988D-03 , & 0.1222418293233745D-05 , - 0.3537812519885135D-08 , 0.3935141570062127D-11 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.1199168437676458D-01 , - 0.1901281836187734D-03 , 0.1190277930150091D-05 , & - 0.3427646781981315D-08 , 0.3793538006609979D-11 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.1179301660242720D-01 , & - 0.1860633193152564D-03 , 0.1159089282966531D-05 , - 0.3321290022527962D-08 , & 0.3657529674457680D-11 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.1159823912542825D-01 , - 0.1820983345109629D-03 , & 0.1128821809387959D-05 , - 0.3218599849794190D-08 , 0.3526878460229166D-11 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.1140727065969444D-01 , - 0.1782305714295440D-03 , 0.1099445994962324D-05 , & - 0.3119439504576406D-08 , 0.3401356997453762D-11 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.1122003151538902D-01 , & - 0.1744574446295729D-03 , 0.1070933317927551D-05 , - 0.3023677628629409D-08 , & 0.3280748158344598D-11 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.1103644357790106D-01 , - 0.1707764391329308D-03 , & 0.1043256215235170D-05 , - 0.2931188042834049D-08 , 0.3164844570516649D-11 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.1085643028647537D-01 , - 0.1671851085926880D-03 , 0.1016388049716654D-05 , & - 0.2841849534696393D-08 , 0.3053448157392264D-11 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.1067991661250801D-01 , & - 0.1636810734998396D-03 , 0.9903030783539361D-06 , - 0.2755545654773759D-08 , & 0.2946369701087589D-11 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.1050682903760104D-01 , - 0.1602620194295070D-03 , & 0.9649764216253784D-06 , - 0.2672164521667001D-08 , 0.2843428426666884D-11 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.1033709553135799D-01 , - 0.1569256953251873D-03 , 0.9403840338856987D-06 , & - 0.2591598635192476D-08 , 0.2744451606661903D-11 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.1017064552900401D-01 , & - 0.1536699118214992D-03 , 0.9165026747523441D-06 , - 0.2513744697402649D-08 , & 0.2649274184855547D-11 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.1000740990884839D-01 , - 0.1504925396046799D-03 , & 0.8933098814637020D-06 , - 0.2438503441114499D-08 , 0.2557738418353360D-11 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.9847320969648514D-02 , - 0.1473915078108433D-03 , 0.8707839421807201D-06 , & - 0.2365779465635130D-08 , 0.2469693537034700D-11 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.9690312407859798D-02 , & - 0.1443648024606898D-03 , 0.8489038701957301D-06 , - 0.2295481079361565D-08 , & 0.2384995419493374D-11 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.9536319294865276D-02 , - 0.1414104649313130D-03 , & 0.8276493790263408D-06 , - 0.2227520148984330D-08 , 0.2303506284667096D-11 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.9385278054170061D-02 , - 0.1385265904638318D-03 , 0.8070008583604185D-06 , & - 0.2161811954998836D-08 , 0.2225094398354530D-11 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.9237126438605258D-02 , & - 0.1357113267066469D-03 , 0.7869393508262875D-06 , - 0.2098275053262350D-08 , & 0.2149633793883663D-11 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.9091803507569727D-02 , - 0.1329628722938428D-03 , & 0.7674465295613176D-06 , - 0.2036831142340388D-08 , 0.2077004006227185D-11 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.8949249604305147D-02 , - 0.1302794754577053D-03 , 0.7485046765493705D-06 , & - 0.1977404936387226D-08 , 0.2007089818885569D-11 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.8809406333294689D-02 , & - 0.1276594326759781D-03 , 0.7300966617092135D-06 , - 0.1919924043347299D-08 , & 0.1939781022927559D-11 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.8672216537720660D-02 , - 0.1251010873518175D-03 , & 0.7122059226994547D-06 , - 0.1864318848223857D-08 , 0.1874972187554637D-11 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.8537624277061734D-02 , - 0.1226028285269356D-03 , 0.6948164454228746D-06 , & - 0.1810522401219225D-08 , 0.1812562441640027D-11 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.8405574804819521D-02 , & - 0.1201630896268664D-03 , 0.6779127452036570D-06 , - 0.1758470310530780D-08 , & 0.1752455265689530D-11 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.8276014546423530D-02 , - 0.1177803472383214D-03 , & 0.6614798486184271D-06 , - 0.1708100639614896D-08 , 0.1694558293720056D-11 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.8148891077262327D-02 , - 0.1154531199169009D-03 , 0.6455032759518584D-06 , & - 0.1659353808708590D-08 , 0.1638783124544600D-11 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.8024153100940800D-02 , & - 0.1131799670260235D-03 , 0.6299690242648939D-06 , - 0.1612172500454129D-08 , & 0.1585045142028200D-11 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.7901750427715430D-02 , - 0.1109594876054412D-03 , & 0.6148635510483581D-06 , - 0.1566501569434089D-08 , 0.1533263343853969D-11 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.7781633953147970D-02 , - 0.1087903192692285D-03 , 0.6001737584450875D-06 , & - 0.1522287955459477D-08 , 0.1483360178390367D-11 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.7663755636956241D-02 , & - 0.1066711371321141D-03 , 0.5858869780179064D-06 , - 0.1479480600442531D-08 , & 0.1435261389252752D-11 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.7548068482139408D-02 , - 0.1046006527646804D-03 , & 0.5719909560517402D-06 , - 0.1438030368721508D-08 , 0.1388895867202771D-11 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.7434526514301376D-02 , - 0.1025776131754226D-03 , 0.5584738393628980D-06 , & - 0.1397889970667013D-08 , 0.1344195509001491D-11 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.7323084761241440D-02 , & - 0.1006007998200922D-03 , 0.5453241616043342D-06 , - 0.1359013889448141D-08 , & 0.1301095082894992D-11 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.7213699232796146D-02 , - 0.9866902763735027D-04 , & 0.5325308300475062D-06 , - 0.1321358310818166D-08 , 0.1259532100402408D-11 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.7106326900935803D-02 , - 0.9678114411010316D-04 , 0.5200831128241316D-06 , & - 0.1284881055791288D-08 , 0.1219446694099015D-11 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.7000925680159574D-02 , & - 0.9493602835256094D-04 , 0.5079706266157327D-06 , - 0.1249541516098392D-08 , & 0.1180781501113656D-11 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.6897454407705618D-02 , - 0.9313259021405839D-04 , & 0.4961833247215138D-06 , - 0.1215300592149512D-08 , 0.1143481551896487D-11 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.6795872826095204D-02 , - 0.9136976944269841D-04 , 0.4847114857736433D-06 , & - 0.1182120634212563D-08 , 0.1107494164886036D-11 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.6696141561904876D-02 , & - 0.8964653480195121D-04 , 0.4735457023918564D-06 , - 0.1149965384688904D-08 , & 0.1072768844636953D-11 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.6598222108881939D-02 , - 0.8796188328098978D-04 , & 0.4626768706869045D-06 , - 0.1118799924064632D-08 , 0.1039257186091470D-11 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.6502076809279476D-02 , - 0.8631483929143040D-04 , 0.4520961799013762D-06 , & - 0.1088590618411198D-08 , 0.1006912782559181D-11 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.6407668835946765D-02 , & - 0.8470445389402433D-04 , 0.4417951024626601D-06 , - 0.1059305069176357D-08 , & 0.9756911380999797D-12 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.6314962174654581D-02 , - 0.8312980404582902D-04 , & 0.4317653843779417D-06 , - 0.1030912065010402D-08 , 0.9455495839288453D-12 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.6223921606737054D-02 , - 0.8158999186861642D-04 , 0.4219990359667815D-06 , & - 0.1003381535562040D-08 , 0.9164471986696589D-12 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.6134512692013431D-02 , & - 0.8008414393741224D-04 , 0.4124883229160242D-06 , - 0.9766845071520070D-09 , & 0.8883447322647086D-12 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.6046701752031727D-02 , - 0.7861141058931065D-04 , & 0.4032257576495491D-06 , - 0.9507930602555194D-09 , 0.8612045333750045D-12 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.5960455853547002D-02 , - 0.7717096525070914D-04 , 0.3942040909939534D-06 , & - 0.9256802886971059D-09 , 0.8349904800846574D-12 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.5875742792344309D-02 , & - 0.7576200378419650D-04 , 0.3854163041397224D-06 , - 0.9013202605119902D-09 , & 0.8096679137775076D-12 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.5792531077326445D-02 , - 0.7438374385337994D-04 , & 0.3768556008804334D-06 , - 0.8776879803857650D-09 , 0.7852035760170483D-12 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.5710789914895689D-02 , - 0.7303542430565231D-04 , 0.3685154001229169D-06 , & - 0.8547593536133466D-09 , 0.7615655482940386D-12 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.5630489193631831D-02 , & - 0.7171630457249033D-04 , 0.3603893286591548D-06 , - 0.8325111515144758D-09 , & 0.7387231945066768D-12 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.5551599469216585D-02 , - 0.7042566408609614D-04 , & 0.3524712141865193D-06 , - 0.8109209782342537D-09 , 0.7166471060338478D-12 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.5474091949716910D-02 , - 0.6916280171367819D-04 , 0.3447550785774685D-06 , & - 0.7899672388961072D-09 , 0.6953090493032519D-12 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.5397938481080028D-02 , & - 0.6792703520672614D-04 , 0.3372351313774465D-06 , - 0.7696291090190281D-09 , & 0.6746819157062982D-12 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.5323111532941703D-02 , - 0.6671770066643533D-04 , & 0.3299057635318131D-06 , - 0.7498865051690673D-09 , 0.6547396737711197D-12 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.5249584184697262D-02 , - 0.6553415202413390D-04 , 0.3227615413296432D-06 , & - 0.7307200567833909D-09 , 0.6354573234777690D-12 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.5177330111885928D-02 , & - 0.6437576053710062D-04 , 0.3157972005611880D-06 , - 0.7121110791293452D-09 , & 0.6168108526257569D-12 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.5106323572774526D-02 , - 0.6324191429771302D-04 , & 0.3090076408722194D-06 , - 0.6940415473282877D-09 , 0.5987771951360935D-12 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.5036539395278615D-02 , - 0.6213201775764344D-04 , 0.3023879203199540D-06 , & - 0.6764940714292334D-09 , 0.5813341912250371D-12 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.4967952964116997D-02 , & - 0.6104549126521026D-04 , 0.2959332501151270D-06 , - 0.6594518724680396D-09 , & 0.5644605493426899D-12 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.4900540208235069D-02 , - 0.5998177061608999D-04 , & 0.2896389895467952D-06 , - 0.6428987594792760D-09 , 0.5481358098017951D-12 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.4834277588498210D-02 , - 0.5894030661708840D-04 , 0.2835006410837589D-06 , & - 0.6268191074222565D-09 , 0.5323403100189913D-12 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.4769142085591175D-02 , & - 0.5792056466172908D-04 , 0.2775138456415135D-06 , - 0.6111978359716254D-09 , & 0.5170551512828218D-12 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.4705111188263878D-02 , - 0.5692202431941438D-04 , & 0.2716743780203048D-06 , - 0.5960203891648849D-09 , 0.5022621670037168D-12 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.4642162881737350D-02 , - 0.5594417893514801D-04 , 0.2659781424937865D-06 , & - 0.5812727158361785D-09 , 0.4879438923448551D-12 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.4580275636397122D-02 , & - 0.5498653524140254D-04 , 0.2604211685532477D-06 , - 0.5669412508292189D-09 , & 0.4740835351935130D-12 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.4519428396709924D-02 , - 0.5404861298092739D-04 , & 0.2549996067971811D-06 , - 0.5530128969458281D-09 , 0.4606649484006318D-12 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.4459600570426438D-02 , - 0.5312994454113820D-04 , 0.2497097249661761D-06 , & - 0.5394750076122839D-09 , 0.4476726032415973D-12 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.4400772017927755D-02 , & - 0.5223007459778965D-04 , 0.2445479041073605D-06 , - 0.5263153702084732D-09 , & 0.4350915640190806D-12 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.4342923041887789D-02 , - 0.5134855977016179D-04 , & 0.2395106348772460D-06 , - 0.5135221900650697D-09 , 0.4229074637849825D-12 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.4286034377121708D-02 , - 0.5048496828565488D-04 , 0.2345945139684967D-06 , & - 0.5010840750783917D-09 , 0.4111064811095265D-12 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.4230087180665306D-02 , & - 0.4963887965420602D-04 , 0.2297962406598992D-06 , - 0.4889900209265248D-09 , & 0.3996753178577344D-12 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.4175063022084254D-02 , - 0.4880988435230558D-04 , & 0.2251126134855343D-06 , - 0.4772293968631043D-09 , 0.3886011779282528D-12 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.4120943873942652D-02 , - 0.4799758351535033D-04 , 0.2205405270135243D-06 , & - 0.4657919320522620D-09 , 0.3778717468993250D-12 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.4067712102591149D-02 , & - 0.4720158864046977D-04 , 0.2160769687433470D-06 , - 0.4546677024534464D-09 , & 0.3674751725680459D-12 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.4015350459058776D-02 , - 0.4642152129649479D-04 , & 0.2117190161012154D-06 , - 0.4438471181949925D-09 , 0.3574000463081082D-12 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.3963842070198178D-02 , - 0.4565701284303578D-04 , 0.2074638335417148D-06 , & - 0.4333209114443132D-09 , 0.3476353852336424D-12 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.3913170430008663D-02 , & - 0.4490770415740177D-04 , 0.2033086697465931D-06 , - 0.4230801247419785D-09 , & 0.3381706151216871D-12 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.3863319391214230D-02 , - 0.4417324537024806D-04 , & 0.1992508549230837D-06 , - 0.4131160997944250D-09 , 0.3289955540709737D-12 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.3814273156923217D-02 , - 0.4345329560737903D-04 , 0.1952877981862043D-06 , & - 0.4034204666789016D-09 , 0.3201003968397060D-12 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.3766016272581385D-02 , & - 0.4274752274046345D-04 , 0.1914169850373061D-06 , - 0.3939851334793159D-09 , & 0.3114756998626687D-12 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.3718533618060202D-02 , - 0.4205560314430733D-04 , & 0.1876359749246135D-06 , - 0.3848022763104948D-09 , 0.3031123668954198D-12 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.3671810399947917D-02 , - 0.4137722146145609D-04 , 0.1839423988878460D-06 , & - 0.3758643297267514D-09 , 0.2950016352675914D-12 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.3625832143962151D-02 , & - 0.4071207037286419D-04 , 0.1803339572786030D-06 , - 0.3671639774871188D-09 , & 0.2871350627077126D-12 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.3580584687642243D-02 , - 0.4005985037663170D-04 , & 0.1768084175649577D-06 , - 0.3586941436882662D-09 , 0.2795045147358460D-12 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.3536054173112105D-02 , - 0.3942026957181715D-04 , 0.1733636122032467D-06 , & - 0.3504479842184164D-09 , 0.2721021525715018D-12 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.3492227040057536D-02 , & - 0.3879304344914439D-04 , 0.1699974365847254D-06 , - 0.3424188785422714D-09 , & 0.2649204215535840D-12 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.3449090018857996D-02 , - 0.3817789468765088D-04 , & 0.1667078470506360D-06 , - 0.3346004217950615D-09 , 0.2579520400423386D-12 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.3406630123863335D-02 , - 0.3757455295702142D-04 , 0.1634928589728932D-06 , & - 0.3269864171725589D-09 , 0.2511899887813893D-12 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.3364834646897891D-02 , & - 0.3698275472657650D-04 , 0.1603505449037754D-06 , - 0.3195708686179960D-09 , & 0.2446275007102993D-12 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.3323691150784723D-02 , - 0.3640224307803142D-04 , & 0.1572790327787580D-06 , - 0.3123479737641124D-09 , 0.2382580511827377D-12 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.3283187463145966D-02 , - 0.3583276752531831D-04 , 0.1542765041876508D-06 , & - 0.3053121171581994D-09 , 0.2320753486043606D-12 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.3243311670290050D-02 , & - 0.3527408383883239D-04 , 0.1513411926995014D-06 , - 0.2984578637318656D-09 , & 0.2260733254493628D-12 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.3204052111268263D-02 , - 0.3472595387508738D-04 , & 0.1484713822449502D-06 , - 0.2917799525182349D-09 , 0.2202461296495493D-12 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.3165397372004704D-02 , - 0.3418814541041275D-04 , 0.1456654055480755D-06 , & - 0.2852732905937388D-09 , 0.2145881163289078D-12 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.3127336279689905D-02 , & - 0.3366043198108105D-04 , 0.1429216426183475D-06 , - 0.2789329472627580D-09 , & 0.2090938398910527D-12 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.3089857897189119D-02 , - 0.3314259272649980D-04 , & 0.1402385192849765D-06 , - 0.2727541484413076D-09 , 0.2037580464159864D-12 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.3052951517638745D-02 , - 0.3263441223764567D-04 , 0.1376145057833353D-06 , & - 0.2667322712564404D-09 , 0.1985756663730119D-12 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.3016606659160234D-02 , & - 0.3213568040971947D-04 , 0.1350481153873913D-06 , - 0.2608628388435949D-09 , & 0.1935418076284744D-12 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.2980813059681597D-02 , - 0.3164619229880635D-04 , & 0.1325379030861231D-06 , - 0.2551415153332717D-09 , 0.1886517487349585D-12 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.2945560671965090D-02 , - 0.3116574798371863D-04 , 0.1300824643086569D-06 , & - 0.2495641010331332D-09 , 0.1839009325007727D-12 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.2910839658597070D-02 , & - 0.3069415242979922D-04 , 0.1276804336816220D-06 , - 0.2441265277660448D-09 , & 0.1792849598019214D-12 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.2876640387244204D-02 , - 0.3023121535851476D-04 , & 0.1253304838363739D-06 , - 0.2388248543983764D-09 , 0.1747995836588805D-12 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.2842953425953067D-02 , - 0.2977675111988967D-04 , 0.1230313242509600D-06 , & - 0.2336552625223614D-09 , 0.1704407035435648D-12 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.2809769538591798D-02 , & - 0.2933057856897005D-04 , 0.1207817001317587D-06 , - 0.2286140522997028D-09 , & 0.1662043599173114D-12 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.2777079680284199D-02 , - 0.2889252094444597D-04 , & 0.1185803913256206D-06 , - 0.2236976384449197D-09 , 0.1620867289790137D-12 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.2744874993289442D-02 , - 0.2846240575449701D-04 , 0.1164262112826215D-06 , & - 0.2189025463802186D-09 , 0.1580841176373455D-12 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.2713146802462402D-02 , & - 0.2804006466033884D-04 , 0.1143180060314941D-06 , - 0.2142254084977531D-09 , & 0.1541929586686966D-12 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.2681886611267146D-02 , - 0.2762533336771436D-04 , & 0.1122546532049374D-06 , - 0.2096629605793747D-09 , 0.1504098060736472D-12 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.2651086097683685D-02 , - 0.2721805151941349D-04 , 0.1102350610893882D-06 , & - 0.2052120383367364D-09 , 0.1467313306157506D-12 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.2620737110229705D-02 , & - 0.2681806259096791D-04 , 0.1082581677055686D-06 , - 0.2008695740747038D-09 , & 0.1431543155342807D-12 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.2590831664174367D-02 , - 0.2642521379050689D-04 , & 0.1063229399242986D-06 , - 0.1966325934861088D-09 , 0.1396756524347268D-12 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.2561361937660615D-02 , - 0.2603935595919329D-04 , 0.1044283726002450D-06 , & - 0.1924982125393234D-09 , 0.1362923373234163D-12 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.2532320268091948D-02 , & - 0.2566034347660522D-04 , 0.1025734877434291D-06 , - 0.1884636344975990D-09 , & 0.1330014668134509D-12 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.2503699148524322D-02 , - 0.2528803416778390D-04 , & 0.1007573337126053D-06 , - 0.1845261470348213D-09 , 0.1298002344711246D-12 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.2475491224179283D-02 , - 0.2492228921333395D-04 , 0.9897898443643907D-07 , & - 0.1806831194578647D-09 , 0.1266859273077751D-12 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.2447689288949571D-02 , & - 0.2456297306094634D-04 , 0.9723753865445830D-07 , - 0.1769320000169875D-09 , & 0.1236559223998518D-12 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.2420286282159096D-02 , - 0.2420995334149694D-04 , & 0.9553211919178149D-07 , - 0.1732703133309870D-09 , 0.1207076836550212D-12 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.2393275285239226D-02 , - 0.2386310078553524D-04 , 0.9386187224788137D-07 , & - 0.1696956578847289D-09 , 0.1178387586890067D-12 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.2366649518560847D-02 , & - 0.2352228914304769D-04 , 0.9222596671220556D-07 , - 0.1662057036235395D-09 , & 0.1150467758295432D-12 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.2340402338327639D-02 , - 0.2318739510529227D-04 , & 0.9062359350066767D-07 , - 0.1627981896304366D-09 , 0.1123294412342424D-12 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.2314527233519688D-02 , - 0.2285829822853320D-04 , 0.8905396491182419D-07 , & - 0.1594709218821606D-09 , 0.1096845361170207D-12 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.2289017823021605D-02 , & - 0.2253488086124382D-04 , 0.8751631400940109D-07 , - 0.1562217710957900D-09 , & 0.1071099140897887D-12 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.2263867852609639D-02 , - 0.2221702807082604D-04 , & 0.8600989401292261D-07 , - 0.1530486706276651D-09 , 0.1046034985883381D-12 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.2239071192208494D-02 , - 0.2190462757474254D-04 , 0.8453397771818675D-07 , & - 0.1499496144669272D-09 , 0.1021632804124404D-12 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.2214621833119841D-02 , & - 0.2159756967244016D-04 , 0.8308785693084535D-07 , - 0.1469226552885231D-09 , & 0.9978731535162775D-13 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.2190513885357018D-02 , - 0.2129574717963989D-04 , & 0.8167084191984085D-07 , - 0.1439659025778878D-09 , 0.9747372190405424D-13 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.2166741574939068D-02 , - 0.2099905536321693D-04 , 0.8028226088243623D-07 , & - 0.1410775208095744D-09 , 0.9522067907343728D-13 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.2143299241444922D-02 , & - 0.2070739188019561D-04 , 0.7892145943619517D-07 , - 0.1382557277090213D-09 , & 0.9302642426414337D-13 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.2120181335440978D-02 , - 0.2042065671624572D-04 , & 0.7758780011705158D-07 , - 0.1354987925548622D-09 , 0.9088925124105483D-13 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.2097382416057377D-02 , - 0.2013875212690881D-04 , 0.7628066189754582D-07 , & - 0.1328050345485636D-09 , 0.8880750817266336D-13 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.2074897148605196D-02 , & - 0.1986158258024593D-04 , 0.7499943971910122D-07 , - 0.1301728212381182D-09 , & 0.8677959574602546D-13 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.2052720302223080D-02 , - 0.1958905470074596D-04 , & 0.7374354403737108D-07 , - 0.1276005669928622D-09 , 0.8480396535003986D-13 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.2030846747706401D-02 , - 0.1932107721624502D-04 , 0.7251240038803024D-07 , & - 0.1250867315427433D-09 , 0.8287911733543818D-13 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.2009271455149507D-02 , & - 0.1905756090353069D-04 , 0.7130544895382691D-07 , - 0.1226298185436719D-09 , & 0.8100359932210579D-13 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.1987989491868888D-02 , - 0.1879841853804729D-04 , & 0.7012214415633774D-07 , - 0.1202283742137036D-09 , 0.7917600458527292D-13 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.1966996020268739D-02 , - 0.1854356484373457D-04 , 0.6896195425481318D-07 , & - 0.1178809860047974D-09 , 0.7739497049356317D-13 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.1946286295802451D-02 , & - 0.1829291644475658D-04 , 0.6782436095954928D-07 , - 0.1155862813237475D-09 , & 0.7565917700771234D-13 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.1925855664864359D-02 , - 0.1804639181719335D-04 , & 0.6670885905123411D-07 , - 0.1133429262849946D-09 , 0.7396734522636913D-13 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.1905699562952825D-02 , - 0.1780391124458124D-04 , 0.6561495602279982D-07 , & - 0.1111496245262488D-09 , 0.7231823600025361D-13 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.1885813512667203D-02 , & - 0.1756539677226028D-04 , 0.6454217172182276D-07 , - 0.1090051160439656D-09 , & 0.7071064858266580D-13 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.1866193121851150D-02 , - 0.1733077216409159D-04 , & 0.6349003800864138D-07 , - 0.1069081760770847D-09 , 0.6914341933591337D-13 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.1846834081760685D-02 , - 0.1709996286012665D-04 , 0.6245809842387315D-07 , & - 0.1048576140261701D-09 , 0.6761542048345878D-13 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.1827732165244764D-02 , & - 0.1687289593507334D-04 , 0.6144590786450096D-07 , - 0.1028522724057284D-09 , & 0.6612555890535159D-13 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.1808883225110954D-02 , - 0.1664950005948280D-04 , & 0.6045303227649256D-07 , - 0.1008910258440604D-09 , 0.6467277498627933D-13 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.1790283192261259D-02 , - 0.1642970545895836D-04 , 0.5947904834386378D-07 , & - 0.9897278009208675D-10 , 0.6325604148807918D-13 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.1771928074124877D-02 , & - 0.1621344387730922D-04 , 0.5852354319912422D-07 , - 0.9709647108763152D-10 , & 0.6187436247892714D-13 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.1753813953007389D-02 , - 0.1600064853933607D-04 , & 0.5758611413664787D-07 , - 0.9526106403970315D-10 , 0.6052677229329409D-13 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.1735936984506261D-02 , - 0.1579125411490796D-04 , 0.5666636833578953D-07 , & - 0.9346555254499076D-10 , 0.5921233453056653D-13 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.1718293395970158D-02 , & - 0.1558519668415309D-04 , 0.5576392259323258D-07 , - 0.9170895773577723D-10 , & 0.5793014109158668D-13 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.1700879484896573D-02 , - 0.1538241370229168D-04 , & 0.5487840305708623D-07 , - 0.8999032744261515D-10 , 0.5667931123926785D-13 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.1683691617591257D-02 , - 0.1518284396815800D-04 , 0.5400944498146013D-07 , & - 0.8830873540976961D-10 , 0.5545899071179802D-13 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.1666726227626881D-02 , & - 0.1498642759078627D-04 , 0.5315669247591545D-07 , - 0.8666328051164826D-10 , & 0.5426835084906825D-13 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.1649979814452930D-02 , - 0.1479310595823848D-04 , & 0.5231979826829266D-07 , - 0.8505308600637617D-10 , 0.5310658775857563D-13 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.1633448941981141D-02 , - 0.1460282170661861D-04 , 0.5149842347183315D-07 , & - 0.8347729880848157D-10 , 0.5197292150716404D-13 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.1617130237362134D-02 , & - 0.1441551869163387D-04 , 0.5069223736624250D-07 , - 0.8193508879805289D-10 , & 0.5086659535010688D-13 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.1601020389491678D-02 , - 0.1423114195764033D-04 , & 0.4990091717176548D-07 , - 0.8042564812763240D-10 , 0.4978687497037987D-13 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.1585116147833614D-02 , - 0.1404963771058286D-04 , 0.4912414784251614D-07 , & - 0.7894819057451240D-10 , 0.4873304776043902D-13 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.1569414321135874D-02 , & - 0.1387095329017912D-04 , 0.4836162185982023D-07 , - 0.7750195090278985D-10 , & 0.4770442212149978D-13 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.1553911776201429D-02 , - 0.1369503714310717D-04 , & 0.4761303903270340D-07 , - 0.7608618424788635D-10 , 0.4670032678862368D-13 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.1538605436727894D-02 , - 0.1352183879732645D-04 , 0.4687810630592156D-07 , & - 0.7470016552384470D-10 , 0.4572011018136019D-13 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.1523492281983916D-02 , & - 0.1335130883502526D-04 , 0.4615653756529925D-07 , - 0.7334318883463233D-10 , & 0.4476313976683372D-13 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.1508569345873189D-02 , - 0.1318339887011206D-04 , & 0.4544805346420929D-07 , - 0.7201456693204548D-10 , 0.4382880146369985D-13 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.1493833715681692D-02 , - 0.1301806152265408D-04 , 0.4475238124036255D-07 , & - 0.7071363066433900D-10 , 0.4291649904876425D-13 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.1479282531013880D-02 , & - 0.1285525039570014D-04 , 0.4406925454482447D-07 , - 0.6943972845478365D-10 , & 0.4202565359244979D-13 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.1464912982685151D-02 , - 0.1269492005197584D-04 , & 0.4339841327302497D-07 , - 0.6819222579144632D-10 , 0.4115570291012043D-13 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.1450722311814196D-02 , - 0.1253702599303170D-04 , 0.4273960340798991D-07 , & - 0.6697050474611198D-10 , 0.4030610104090555D-13 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.1436707808606559D-02 , & - 0.1238152463543211D-04 , 0.4209257685411298D-07 , - 0.6577396348354080D-10 , & 0.3947631772779097D-13 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.1422866811477228D-02 , - 0.1222837329085824D-04 , & 0.4145709128883046D-07 , - 0.6460201580944438D-10 , 0.3866583793098356D-13 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.1409196706045106D-02 , - 0.1207753014515008D-04 , 0.4083291001225194D-07 , & - 0.6345409072144812D-10 , 0.3787416135037401D-13 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.1395694924178265D-02 , & - 0.1192895423818085D-04 , 0.4021980180223738D-07 , - 0.6232963197612263D-10 , & 0.3710080196555853D-13 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.1382358943105040D-02 , - 0.1178260544470640D-04 , & 0.3961754077538596D-07 , - 0.6122809767261854D-10 , 0.3634528759346433D-13 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.1369186284337017D-02 , - 0.1163844445352739D-04 , 0.3902590624341434D-07 , & - 0.6014895983427787D-10 , 0.3560715945107860D-13 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.1356174513008236D-02 , & - 0.1149643275127396D-04 , 0.3844468258964316D-07 , - 0.5909170403124038D-10 , & 0.3488597175129258D-13 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.1343321236858058D-02 , - 0.1135653260272423D-04 , & 0.3787365913373867D-07 , - 0.5805582898808906D-10 , 0.3418129129483101D-13 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.1330624105412905D-02 , - 0.1121870703345845D-04 , 0.3731263000745709D-07 , & - 0.5704084621615525D-10 , 0.3349269708408872D-13 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.1318080809111903D-02 , & - 0.1108291981217850D-04 , 0.3676139403085427D-07 , - 0.5604627965187567D-10 , & 0.3281977994643604D-13 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.1305689078642945D-02 , - 0.1094913543544021D-04 , & 0.3621975459957122D-07 , - 0.5507166531935857D-10 , 0.3216214217856865D-13 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.1293446683933355D-02 , - 0.1081731910905467D-04 , 0.3568751956086588D-07 , & - 0.5411655097841991D-10 , 0.3151939718656657D-13 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.1281351433503769D-02 , & - 0.1068743673346820D-04 , 0.3516450110669349D-07 , - 0.5318049580680162D-10 , & 0.3089116915306858D-13 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.1269401173674381D-02 , - 0.1055945488783766D-04 , & 0.3465051566327858D-07 , - 0.5226307008087821D-10 , 0.3027709270819976D-13 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.1257593787819527D-02 , - 0.1043334081481937D-04 , 0.3414538378496281D-07 , & - 0.5136385486814424D-10 , 0.2967681261269846D-13 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.1245927195686895D-02 , & - 0.1030906240622497D-04 , 0.3364893005284141D-07 , - 0.5048244173215475D-10 , & 0.2908998345346549D-13 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.1234399352505501D-02 , - 0.1018658818673547D-04 , & 0.3316098296741925D-07 , - 0.4961843243146302D-10 , 0.2851626933958113D-13 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.1223008248539781D-02 , - 0.1006588730234883D-04 , 0.3268137486073141D-07 , & - 0.4877143865567060D-10 , 0.2795534362615865D-13 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.1211751908249510D-02 , & - 0.9946929505010995D-05 , 0.3220994179521830D-07 , - 0.4794108174280764D-10 , & 0.2740688863023473D-13 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.1200628389659938D-02 , - 0.9829685139572526D-05 , & 0.3174652347278733D-07 , - 0.4712699241777906D-10 , 0.2687059536394149D-13 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.1189635783702053D-02 , - 0.9714125130641131D-05 , 0.3129096314479795D-07 , & - 0.4632881053609160D-10 , 0.2634616327479199D-13 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.1178772213552281D-02 , & - 0.9600220969502881D-05 , 0.3084310752314459D-07 , - 0.4554618483229072D-10 , & 0.2583329999211279D-13 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.1168035834148828D-02 , - 0.9487944703245467D-05 , & 0.3040280670180118D-07 , - 0.4477877269098931D-10 , 0.2533172109220487D-13 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.1157424831353834D-02 , - 0.9377268920154095D-05 , 0.2996991406417688D-07 , & - 0.4402623989519597D-10 , 0.2484114985114927D-13 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.1146937421506812D-02 , & - 0.9268166739452757D-05 , 0.2954428620893663D-07 , - 0.4328826041042906D-10 , & 0.2436131702439791D-13 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.1136571850802419D-02 , - 0.9160611799338247D-05 , & 0.2912578287007638D-07 , - 0.4256451616159078D-10 , 0.2389196062446379D-13 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.1126326394769949D-02 , - 0.9054578246197771D-05 , 0.2871426684254093D-07 , & - 0.4185469682215280D-10 , 0.2343282570937026D-13 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.1116199357519986D-02 , & - 0.8950040721675893D-05 , 0.2830960390088150D-07 , - 0.4115849959473214D-10 , & 0.2298366416866048D-13 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.1106189071467667D-02 , - 0.8846974354602399D-05 , & 0.2791166273697019D-07 , - 0.4047562902598701D-10 , 0.2254423453352530D-13 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.1096293896625624D-02 , - 0.8745354748804342D-05 , 0.2752031488337534D-07 , & - 0.3980579680047840D-10 , 0.2211430177654433D-13 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.1086512220119341D-02 , & - 0.8645157973258291D-05 , 0.2713543464637217D-07 , - 0.3914872155308701D-10 , & 0.2169363712555193D-13 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.1076842455673313D-02 , - 0.8546360552087758D-05 , & 0.2675689903927903D-07 , - 0.3850412868448140D-10 , 0.2128201788188884D-13 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.1067283043047038D-02 , - 0.8448939454204702D-05 , 0.2638458771538034D-07 , & - 0.3787175017838803D-10 , 0.2087922724220715D-13 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.1111111111111136D+00 , & - 0.5916273951791569D-02 , 0.1628953078428963D-03 , - 0.3062690170493752D-05 , & 0.4396654062277857D-07 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.1111111107666444D+00 , - 0.5916271969355871D-02 , & 0.1628908718938847D-03 , - 0.3057764698718864D-05 , 0.4148032893871452D-07 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.1111110974021157D+00 , - 0.5916238426783800D-02 , 0.1628586926999738D-03 , & - 0.3043744212317543D-05 , 0.3913620717339142D-07 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.1111110074030919D+00 , & - 0.5916097617816710D-02 , 0.1627754312254309D-03 , - 0.3021683671539898D-05 , & 0.3692598369143614D-07 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.1111106883778765D+00 , - 0.5915737091318884D-02 , & 0.1626220154067826D-03 , - 0.2992546387694710D-05 , 0.3484194256270572D-07 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.1111098734973098D+00 , - 0.5915017526361217D-02 , 0.1623831382015560D-03 , & - 0.2957211134641636D-05 , 0.3287681576609880D-07 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.1111081661278804D+00 , & - 0.5913781113772849D-02 , 0.1620468046872280D-03 , - 0.2916478740249508D-05 , & 0.3102375702617259D-07 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.1111050328059396D+00 , - 0.5911858621646676D-02 , & 0.1616039238874475D-03 , - 0.2871078194504652D-05 , 0.2927631718620877D-07 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.1110998028769584D+00 , - 0.5909075303893411D-02 , 0.1610479413593721D-03 , & - 0.2821672308426381D-05 , 0.2762842102708078D-07 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.1110916733668317D+00 , & - 0.5905255794291060D-02 , 0.1603745089045903D-03 , - 0.2768862955591081D-05 , & 0.2607434544664459D-07 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.1110797178657790D+00 , - 0.5900228113417087D-02 , & 0.1595811880687459D-03 , - 0.2713195925870443D-05 , 0.2460869891942598D-07 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.1110628983926049D+00 , - 0.5893826902237055D-02 , 0.1586671843736137D-03 , & - 0.2655165418942354D-05 , 0.2322640216112732D-07 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.1110400793708538D+00 , & - 0.5885895983826265D-02 , 0.1576331094818434D-03 , - 0.2595218203225140D-05 , & 0.2192266992694505D-07 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.1110100429913111D+00 , - 0.5876290343601011D-02 , & 0.1564807687305988D-03 , - 0.2533757464107644D-05 , 0.2069299387689281D-07 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.1109715053596902D+00 , - 0.5864877608424985D-02 , 0.1552129716874263D-03 , & - 0.2471146363690291D-05 , 0.1953312644527397D-07 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.1109231329362995D+00 , & - 0.5851539095934701D-02 , 0.1538333635813824D-03 , - 0.2407711332708263D-05 , & 0.1843906565517263D-07 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.1108635588678724D+00 , - 0.5836170497305082D-02 , & 0.1523462756460390D-03 , - 0.2343745113868605D-05 , 0.1740704082232224D-07 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.1107913988922534D+00 , - 0.5818682249369602D-02 , 0.1507565925797535D-03 , & - 0.2279509574492467D-05 , 0.1643349909600535D-07 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.1107052665657694D+00 , & - 0.5798999645443083D-02 , 0.1490696354836651D-03 , - 0.2215238305104444D-05 , & 0.1551509278773090D-07 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.1106037876222205D+00 , - 0.5777062728300471D-02 , & 0.1472910587803328D-03 , - 0.2151139019447225D-05 , 0.1464866744134641D-07 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.1104856133227070D+00 , - 0.5752826003478639D-02 , 0.1454267597467552D-03 , & - 0.2087395770315729D-05 , 0.1383125060098103D-07 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.1103494326980453D+00 , & - 0.5726258006333244D-02 , 0.1434827994156074D-03 , - 0.2024170994595110D-05 , & 0.1306004123579077D-07 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.1101939836212674D+00 , - 0.5697340752046439D-02 , & 0.1414653337087428D-03 , - 0.1961607399946579D-05 , 0.1233239978290047D-07 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.1100180626775105D+00 , - 0.5666069093996464D-02 , 0.1393805537681188D-03 , & - 0.1899829704709117D-05 , 0.1164583877221645D-07 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.1098205338232376D+00 , & - 0.5632450012522966D-02 , 0.1372346345420243D-03 , - 0.1838946241769558D-05 , & 0.1099801399892791D-07 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.1096003358468691D+00 , - 0.5596501853113413D-02 , & 0.1350336907694853D-03 , - 0.1779050436394035D-05 , 0.1038671621153235D-07 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.1093564886591416D+00 , - 0.5558253530359721D-02 , 0.1327837395836104D-03 , & - 0.1720222167306760D-05 , 0.9809863285118233D-08 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.1090880984543850D+00 , & - 0.5517743711657804D-02 , 0.1304906690259809D-03 , - 0.1662529019643760D-05 , & 0.9265492851422749D-08 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.1087943617938829D+00 , - 0.5475019992516610D-02 , & 0.1281602118295061D-03 , - 0.1606027437796470D-05 , 0.8751755358862771D-08 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.1084745686699778D+00 , - 0.5430138073479841D-02 , 0.1257979238869457D-03 , & - 0.1550763785589700D-05 , 0.8266907537316651D-08 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.1081281046149619D+00 , & - 0.5383160947019175D-02 , 0.1234091668769784D-03 , - 0.1496775320707648D-05 , & 0.7809306243921266D-08 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.1077544519223836D+00 , - 0.5334158101309570D-02 , & 0.1209990945696998D-03 , - 0.1444091089787648D-05 , 0.7377402667547272D-08 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.1073531900504800D+00 , - 0.5283204746525304D-02 , 0.1185726423791161D-03 , & - 0.1392732750141655D-05 , 0.6969736870931312D-08 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.1069239952782643D+00 , & - 0.5230381068181546D-02 , 0.1161345197719404D-03 , - 0.1342715323637792D-05 , & 0.6584932650681889D-08 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.1064666396845733D+00 , - 0.5175771511073611D-02 , & 0.1136892051800942D-03 , - 0.1294047887876427D-05 , 0.6221692696540433D-08 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.1059809895192999D+00 , - 0.5119464096520055D-02 , 0.1112409430990799D-03 , & - 0.1246734209425091D-05 , 0.5878794032374870D-08 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.1054670030342677D+00 , & - 0.5061549774882592D-02 , 0.1087937430860876D-03 , - 0.1200773323532375D-05 , & 0.5555083722414266D-08 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.1049247278388857D+00 , - 0.5002121814703190D-02 , & 0.1063513804005850D-03 , - 0.1156160064420764D-05 , 0.5249474827203135D-08 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.1043542978429773D+00 , - 0.4941275229255884D-02 , 0.1039173980564491D-03 , & - 0.1112885549960684D-05 , 0.4960942594666945D-08 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.1037559298461185D+00 , & - 0.4879106240847416D-02 , 0.1014951100786354D-03 , - 0.1070937624251271D-05 , & 0.4688520872539254D-08 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.1031299198295242D+00 , - 0.4815711782808205D-02 , & 0.9908760577916249D-04 , - 0.1030301261376065D-05 , 0.4431298729209099D-08 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.1024766390030781D+00 , - 0.4751189038784832D-02 , 0.9669775488696809D-04 , & - 0.9909589333626245D-06 , 0.4188417270807740D-08 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.1017965296565706D+00 , & - 0.4685635018670350D-02 , 0.9432821338417176D-04 , - 0.9528909451528132D-06 , & 0.3959066643069471D-08 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.1010901008606405D+00 , - 0.4619146170282308D-02 , & 0.9198142991757468D-04 , - 0.9160757391838970D-06 , 0.3742483207174577D-08 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.1003579240593668D+00 , - 0.4551818025714955D-02 , 0.8965965266901398D-04 , & - 0.8804901719887072D-06 , 0.3537946879416103D-08 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.9960062859294798D-01 , & - 0.4483744881145654D-02 , 0.8736493658156373D-04 , - 0.8461097650447250D-06 , & 0.3344778625128436D-08 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.9881889718548893D-01 , - 0.4415019508762736D-02 , & 0.8509915085070182D-04 , - 0.8129089319364483D-06 , 0.3162338097876724D-08 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.9801346142959283D-01 , - 0.4345732899396672D-02 , 0.8286398660049449D-04 , & - 0.7808611837414517D-06 , 0.2990021415434265D-08 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.9718509729626025D-01 , & - 0.4275974034376571D-02 , 0.8066096467474135D-04 , - 0.7499393144077789D-06 , & 0.2827259064571801D-08 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.9633462069554338D-01 , - 0.4205829685095175D-02 , & 0.7849144348193575D-04 , - 0.7201155677576747D-06 , 0.2673513927150366D-08 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.9546288311049375D-01 , - 0.4135384238745027D-02 , 0.7635662684092217D-04 , & - 0.6913617876295445D-06 , 0.2528279420449356D-08 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.9457076732419198D-01 , & - 0.4064719548683725D-02 , 0.7425757178135390D-04 , - 0.6636495525557835D-06 , & 0.2391077745075661D-08 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.9365918325705730D-01 , - 0.3993914807894495D-02 , & 0.7219519625953835D-04 , - 0.6369502962680728D-06 , 0.2261458234189484D-08 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.9272906392920824D-01 , - 0.3923046444028062D-02 , 0.7017028675607401D-04 , & - 0.6112354152233753D-06 , 0.2138995798149293D-08 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.9178136156038391D-01 , & - 0.3852188034540582D-02 , 0.6818350572688925D-04 , - 0.5864763642526046D-06 , & 0.2023289459023600D-08 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.9081704381783086D-01 , - 0.3781410240478927D-02 , & 0.6623539888394475D-04 , - 0.5626447413493006D-06 , 0.1913960969742185D-08 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.8983709022062246D-01 , - 0.3710780757507438D-02 , 0.6432640228601228D-04 , & - 0.5397123625371771D-06 , 0.1810653512965250D-08 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.8884248870708607D-01 , & - 0.3640364282817770D-02 , 0.6245684922363313D-04 , - 0.5176513276826366D-06 , & 0.1713030475036745D-08 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.8783423237038017D-01 , - 0.3570222496615072D-02 , & 0.6062697688563969D-04 , - 0.4964340780509208D-06 , 0.1620774290659136D-08 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.8681331636576756D-01 , - 0.3500414056927934D-02 , 0.5883693279752458D-04 , & - 0.4760334463420685D-06 , 0.1533585354181791D-08 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.8578073499177909D-01 , & - 0.3430994606545912D-02 , 0.5708678102450631D-04 , - 0.4564226998849559D-06 , & 0.1451180993635252D-08 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.8473747894623780D-01 , - 0.3362016790946016D-02 , & 0.5537650813439450D-04 , - 0.4375755776140618D-06 , 0.1373294503869526D-08 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.8368453275701873D-01 , - 0.3293530286127778D-02 , 0.5370602891733716D-04 , & - 0.4194663214039492D-06 , 0.1299674235367238D-08 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.8262287238643756D-01 , & - 0.3225581835334852D-02 , 0.5207519186125849D-04 , - 0.4020697022904643D-06 , & 0.1230082735502638D-08 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.8155346300729560D-01 , - 0.3158215293699103D-02 , & 0.5048378438329788D-04 , - 0.3853610420651055D-06 , 0.1164295939205853D-08 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.8047725694784474D-01 , - 0.3091471679900443D-02 , 0.4893153781885962D-04 , & - 0.3693162306896434D-06 , 0.1102102406169226D-08 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.7939519180226853D-01 , & - 0.3025389233991828D-02 , 0.4741813217099730D-04 , - 0.3539117399416326D-06 , & 0.1043302601899479D-08 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.7830818870270075D-01 , - 0.2960003480593793D-02 , & 0.4594320062380978D-04 , - 0.3391246336677806D-06 , 0.9877082200766522D-09 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.7721715074831169D-01 , - 0.2895347296716265D-02 , 0.4450633382433020D-04 , & - 0.3249325749909909D-06 , 0.9351415438287444D-09 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.7612296158657622D-01 , & - 0.2831450983517007D-02 , 0.4310708393806253D-04 , - 0.3113138307881065D-06 , & 0.8854348436702609D-09 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.7502648414149714D-01 , - 0.2768342341355984D-02 , & 0.4174496848387782D-04 , - 0.2982472737287948D-06 , 0.8384298099840295D-09 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.7392855948327898D-01 , - 0.2706046747552747D-02 , 0.4041947395443306D-04 , & - 0.2857123821414385D-06 , 0.7939770180490877D-09 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.7283000583372928D-01 , & - 0.2644587236299811D-02 , 0.3913005922863522D-04 , - 0.2736892379492193D-06 , & 0.7519354237336800D-09 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.7173161770150319D-01 , - 0.2583984580228917D-02 , & 0.3787615878295064D-04 , - 0.2621585228986539D-06 , 0.7121718880818475D-09 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.7063416514119300D-01 , - 0.2524257373168737D-02 , 0.3665718570856314D-04 , & - 0.2511015132835100D-06 , 0.6745607291250854D-09 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.6953839313019117D-01 , & - 0.2465422113672132D-02 , 0.3547253454152486D-04 , - 0.2405000733492323D-06 , & 0.6389832993475721D-09 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.6844502105723579D-01 , - 0.2407493288928937D-02 , & 0.3432158391312885D-04 , - 0.2303366475465760D-06 , 0.6053275873247901D-09 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.6735474231654272D-01 , - 0.2350483458715393D-02 , 0.3320369902776543D-04 , & - 0.2205942517880117D-06 , 0.5734878421413416D-09 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.6626822400147581D-01 , & - 0.2294403339065101D-02 , 0.3211823397551818D-04 , - 0.2112564638465315D-06 , & 0.5433642192747393D-09 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.6518610669176819D-01 , - 0.2239261885377718D-02 , & 0.3106453388670911D-04 , - 0.2023074130236443D-06 , 0.5148624467081775D-09 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.6410900432840108D-01 , - 0.2185066374711266D-02 , 0.3004193693552633D-04 , & - 0.1937317692015439D-06 , 0.4878935101070761D-09 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.6303750417035722D-01 , & - 0.2131822487031543D-02 , 0.2904977619976266D-04 , - 0.1855147313835655D-06 , & 0.4623733559617701D-09 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.6197216682759998D-01 , - 0.2079534385218121D-02 , & 0.2808738138356748D-04 , - 0.1776420158170707D-06 , 0.4382226116623970D-09 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.6091352636477153D-01 , - 0.2028204793650377D-02 , 0.2715408040996528D-04 , & - 0.1700998437837103D-06 , 0.4153663215319188D-09 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.5986209047026697D-01 , & - 0.1977835075219615D-02 , 0.2624920088973336D-04 , - 0.1628749291336083D-06 , & 0.3937336978996983D-09 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.5881834068551110D-01 , - 0.1928425306634114D-02 , & 0.2537207147305430D-04 , - 0.1559544656322704D-06 , 0.3732578863511775D-09 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.5778273268944217D-01 , - 0.1879974351903193D-02 , 0.2452202309017166D-04 , & - 0.1493261141819305D-06 , 0.3538757443392479D-09 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.5675569663339666D-01 , & - 0.1832479933904331D-02 , 0.2369839008708406D-04 , - 0.1429779899725631D-06 , & 0.3355276323900615D-09 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.5573763752177846D-01 , - 0.1785938703953744D-02 , & 0.2290051126211056D-04 , - 0.1368986496118300D-06 , 0.3181572171803951D-09 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.5472893563409224D-01 , - 0.1740346309315972D-02 , 0.2212773080895622D-04 , & - 0.1310770782777946D-06 , 0.3017112858055017D-09 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.5372994698411665D-01 , & - 0.1695697458601864D-02 , 0.2137939917169767D-04 , - 0.1255026769332550D-06 , & 0.2861395705957356D-09 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.5274100381219582D-01 , - 0.1651985985017164D-02 , & 0.2065487381690198D-04 , - 0.1201652496360122D-06 , 0.2713945838773535D-09 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.5176241510681947D-01 , - 0.1609204907435250D-02 , 0.1995351992787955D-04 , & - 0.1150549909752264D-06 , 0.2574314621077651D-09 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.5079446715186489D-01 , & - 0.1567346489278306D-02 , 0.1927471102586701D-04 , - 0.1101624736602461D-06 , & 0.2442078188484488D-09 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.4983742409606703D-01 , - 0.1526402295200660D-02 , & 0.1861782952272850D-04 , - 0.1054786362848462D-06 , 0.2316836060697040D-09 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.4889152854147301D-01 , - 0.1486363245576547D-02 , 0.1798226720955993D-04 , & - 0.1009947712866716D-06 , 0.2198209833105880D-09 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.4795700214783157D-01 , & - 0.1447219668802479D-02 , 0.1736742568538285D-04 , - 0.9670251311884838D-07 , & 0.2085841942448964D-09 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.4703404625004748D-01 , - 0.1408961351431159D-02 , & 0.1677271672991672D-04 , - 0.9259382664813052D-07 , 0.1979394502299083D-09 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.4612284248601480D-01 , - 0.1371577586160171D-02 , 0.1619756262422825D-04 , & - 0.8866099579161552D-07 , 0.1878548204390255D-09 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.4522355343231526D-01 , & - 0.1335057217704046D-02 , 0.1564139642286879D-04 , - 0.8489661240193884D-07 , & 0.1783001282023896D-09 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.4433632324544327D-01 , - 0.1299388686583301D-02 , & 0.1510366218093144D-04 , - 0.8129356540895574D-07 , 0.1692468532012290D-09 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.4346127830637622D-01 , - 0.1264560070868033D-02 , 0.1458381513928042D-04 , & - 0.7784503022417677D-07 , 0.1606680391820358D-09 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.4259852786647417D-01 , & - 0.1230559125917499D-02 , 0.1408132187103795D-04 , - 0.7454445841268733D-07 , & 0.1525382068759104D-09 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.4174816469284273D-01 , - 0.1197373322160169D-02 , & 0.1359566039224705D-04 , - 0.7138556763587829D-07 , 0.1448332718264828D-09 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.4091026571143989D-01 , - 0.1164989880961438D-02 , 0.1312632023947177D-04 , & - 0.6836233186707422D-07 , 0.1375304668468833D-09 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.4008489264634778D-01 , & - 0.1133395808628295D-02 , 0.1267280251694026D-04 , - 0.6546897188101534D-07 , & 0.1306082688422546D-09 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.3927209265376796D-01 , - 0.1102577928602306D-02 , & 0.1223461991569349D-04 , - 0.6269994601717857D-07 , 0.1240463297494826D-09 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.3847189894942298D-01 , - 0.1072522911893472D-02 , 0.1181129670705707D-04 , & - 0.6004994121601970D-07 , 0.1178254113600231D-09 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.3768433142817029D-01 , & - 0.1043217305808751D-02 , 0.1140236871262001D-04 , - 0.5751386432644635D-07 , & 0.1119273238051569D-09 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.3690939727475551D-01 , - 0.1014647561029948D-02 , & 0.1100738325277573D-04 , - 0.5508683368215156D-07 , 0.1063348674956659D-09 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.3614709156473293D-01 , - 0.9868000570959542D-03 , 0.1062589907575358D-04 , & - 0.5276417094381655D-07 , 0.1010317783198150D-09 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.3539739785469460D-01 , & - 0.9596611263448665D-03 , 0.1025748626895386D-04 , - 0.5054139320368377D-07 , & 0.9600267591479059D-10 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.3466028876104194D-01 , - 0.9332170763713939D-03 , & 0.9901726154284119D-05 , - 0.4841420534853404D-07 , 0.9123301483730856D-10 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.3393572652663142D-01 , - 0.9074542110549561D-03 , 0.9558211169088792D-05 , & - 0.4637849267671904D-07 , 0.8670903846909801D-10 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.3322366357470504D-01 , & - 0.8823588502132951D-03 , 0.9226544734158527D-05 , - 0.4443031376455160D-07 , & 0.8241773550233461D-10 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.3252404304961055D-01 , - 0.8579173479362966D-03 , & 0.8906341110212538D-05 , - 0.4256589357709768D-07 , 0.7834679885899922D-10 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.3183679934388207D-01 , - 0.8341161096537359D-03 , 0.8597225244150699D-05 , & - 0.4078161681815942D-07 , 0.7448458690644228D-10 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.3116185861133007D-01 , & - 0.8109416079900960D-03 , 0.8298832606286461D-05 , - 0.3907402151406060D-07 , & 0.7082008683932493D-10 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.3049913926585192D-01 , - 0.7883803974585741D-03 , & 0.8010809019686753D-05 , - 0.3743979282568576D-07 , 0.6734288010550314D-10 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.2984855246574624D-01 , - 0.7664191280457068D-03 , 0.7732810482669112D-05 , & - 0.3587575708312270D-07 , 0.6404310976043727D-10 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.2921000258335699D-01 , & - 0.7450445577365282D-03 , 0.7464502985426744D-05 , - 0.3437887603714907D-07 , & 0.6091144964124674D-10 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.2858338765994137D-01 , - 0.7242435640294785D-03 , & 0.7205562321686249D-05 , - 0.3294624132176964D-07 , 0.5793907525777991D-10 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.2796859984569709D-01 , - 0.7040031544888240D-03 , 0.6955673896233094D-05 , & - 0.3157506912196475D-07 , 0.5511763630388994D-10 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.2736552582493500D-01 , & - 0.6843104763812973D-03 , 0.6714532529079180D-05 , - 0.3026269504081207D-07 , & 0.5243923069764053D-10 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.2677404722641625D-01 , - 0.6651528254420540D-03 , & 0.6481842256983543D-05 , - 0.2900656916013521D-07 , 0.4989638006432659D-10 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.2619404101892654D-01 , - 0.6465176538142429D-03 , 0.6257316132987245D-05 , & - 0.2780425128889030D-07 , 0.4748200658114536D-10 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.2562537989218076D-01 , & - 0.6283925772046711D-03 , 0.6040676024565339D-05 , - 0.2665340639351888D-07 , & 0.4518941110692157D-10 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.2506793262318819D-01 , - 0.6107653812968794D-03 , & 0.5831652410951459D-05 , - 0.2555180020456394D-07 , 0.4301225252466145D-10 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.2452156442824511D-01 , - 0.5936240274617726D-03 , 0.5629984180146035D-05 , & - 0.2449729499392498D-07 , 0.4094452822882914D-10 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.2398613730073146D-01 , & - 0.5769566578041420D-03 , 0.5435418426070791D-05 , - 0.2348784551718630D-07 , & 0.3898055569306763D-10 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.2346151033492713D-01 , - 0.5607515995824890D-03 , & 0.5247710246295841D-05 , - 0.2252149511556363D-07 , 0.3711495505776996D-10 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.2294754003607479D-01 , - 0.5449973690379244D-03 , 0.5066622540724358D-05 , & - 0.2159637197209788D-07 , 0.3534263268032010D-10 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.2244408061694191D-01 , & - 0.5296826746667803D-03 , 0.4891925811586138D-05 , - 0.2071068551683774D-07 , & 0.3365876559408016D-10 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.2195098428113744D-01 , - 0.5147964199698704D-03 , & 0.4723397965053951D-05 , - 0.1986272297584571D-07 , 0.3205878682522710D-10 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.2146810149347322D-01 , - 0.5003277057105707D-03 , 0.4560824114770852D-05 , & - 0.1905084605900042D-07 , 0.3053837151946543D-10 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.2099528123765270D-01 , & - 0.4862658317120679D-03 , 0.4403996387541946D-05 , - 0.1827348778166143D-07 , & 0.2909342383331733D-10 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.2053237126159230D-01 , - 0.4726002982231746D-03 , & 0.4252713731420088D-05 , - 0.1752914941539709D-07 , 0.2772006454727719D-10 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.2007921831067930D-01 , - 0.4593208068806148D-03 , 0.4106781726387129D-05 , & - 0.1681639756308794D-07 , 0.2641461936051435D-10 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.1963566834929470D-01 , & - 0.4464172612948819D-03 , 0.3966012397812710D-05 , - 0.1613386135385910D-07 , & 0.2517360782911410D-10 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.1920156677090874D-01 , - 0.4338797672849379D-03 , & 0.3830224032844458D-05 , - 0.1548022975339263D-07 , 0.2399373291194883D-10 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.1877675859708574D-01 , - 0.4216986327864561D-03 , 0.3699240999868788D-05 , & - 0.1485424898532148D-07 , 0.2287187109033824D-10 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.1836108866572272D-01 , & - 0.4098643674568168D-03 , 0.3572893571159101D-05 , - 0.1425472005951573D-07 , & 0.2180506302954097D-10 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.1795440180885917D-01 , - 0.3983676819992194D-03 , & 0.3451017748813164D-05 , - 0.1368049640320735D-07 , 0.2079050475193816D-10 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.1755654302037643D-01 , - 0.3871994872267360D-03 , 0.3333455094060745D-05 , & - 0.1313048159100442D-07 , 0.1982553929343706D-10 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.1716735761393504D-01 , & - 0.3763508928868204D-03 , 0.3220052560014569D-05 , - 0.1260362716999704D-07 , & 0.1890764881627069D-10 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.1678669137146848D-01 , - 0.3658132062650858D-03 , & 0.3110662327917219D-05 , - 0.1209893057625107D-07 , 0.1803444715283543D-10 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.1641439068256757D-01 , - 0.3555779305866144D-03 , 0.3005141646927999D-05 , & - 0.1161543313912160D-07 , 0.1720367275665993D-10 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.1605030267507378D-01 , & - 0.3456367632318152D-03 , 0.2903352677479160D-05 , - 0.1115221816992432D-07 , & 0.1641318203792334D-10 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.1569427533721938D-01 , - 0.3359815937834782D-03 , & 0.2805162338225218D-05 , - 0.1070840913163852D-07 , 0.1566094306223988D-10 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.1534615763161346D-01 , - 0.3266045019199718D-03 , 0.2710442156591659D-05 , & - 0.1028316788639822D-07 , 0.1494502959257373D-10 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.1500579960140147D-01 , & - 0.3174977551694754D-03 , 0.2619068122927663D-05 , - 0.9875693017668371D-08 , & 0.1426361545532173D-10 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.1467305246890072D-01 , - 0.3086538065388485D-03 , & 0.2530920548254883D-05 , - 0.9485218224094125D-08 , 0.1361496921263736D-10 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.1434776872702369D-01 , - 0.3000652920303116D-03 , 0.2445883925600084D-05 , & - 0.9111010782130156D-08 , 0.1299744912409173D-10 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.1402980222376956D-01 , & - 0.2917250280577580D-03 , 0.2363846794887374D-05 , - 0.8752370074639235D-08 , & 0.1240949838168212D-10 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.1371900824009764D-01 , - 0.2836260087747307D-03 , & 0.2284701611367904D-05 , - 0.8408626182783453D-08 , 0.1184964060314067D-10 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.1341524356145254D-01 , - 0.2757614033245273D-03 , 0.2208344617551640D-05 , & - 0.8079138538598694D-08 , 0.1131647556929153D-10 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.1311836654322747D-01 , & - 0.2681245530227816D-03 , 0.2134675718605737D-05 , - 0.7763294635758001D-08 , & 0.1080867519202807D-10 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.1282823717042815D-01 , - 0.2607089684818480D-03 , & 0.2063598361176207D-05 , - 0.7460508796109371D-08 , 0.1032497970021249D-10 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.1254471711182247D-01 , - 0.2535083266863926D-03 , 0.1995019415591565D-05 , & - 0.7170220989686522D-08 , 0.9864194031540125D-11 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.1226766976880906D-01 , & - 0.2465164680279882D-03 , 0.1928849061394816D-05 , - 0.6891895705944855D-08 , & 0.9425184419028780D-11 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.1199696031927323D-01 , - 0.2397273933069452D-03 , & 0.1865000676155563D-05 , - 0.6625020874092635D-08 , 0.9006875161471083D-11 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.1173245575666580D-01 , - 0.2331352607084893D-03 , 0.1803390727506295D-05 , & - 0.6369106830450275D-08 , 0.8608245567753416D-11 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.1147402492455172D-01 , & - 0.2267343827603325D-03 , 0.1743938668348252D-05 , - 0.6123685330864313D-08 , & 0.8228327065525964D-11 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.1122153854683530D-01 , - 0.2205192232774704D-03 , & 0.1686566835164188D-05 , - 0.5888308606257038D-08 , 0.7866200465204987D-11 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.1097486925391218D-01 , - 0.2144843943007224D-03 , 0.1631200349383188D-05 , & - 0.5662548459503019D-08 , 0.7520993370838483D-11 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.1073389160494263D-01 , & - 0.2086246530340256D-03 , 0.1577767021732340D-05 , - 0.5445995401862366D-08 , & 0.7191877729789993D-11 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.1049848210646318D-01 , - 0.2029348987857492D-03 , & 0.1526197259514507D-05 , - 0.5238257827291215D-08 , 0.6878067513669692D-11 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.1026851922752491D-01 , - 0.1974101699184397D-03 , 0.1476423976746731D-05 , & - 0.5038961223003106D-08 , 0.6578816523342074D-11 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.1004388341157689D-01 , & - 0.1920456408118459D-03 , 0.1428382507099716D-05 , - 0.4847747414744016D-08 , & 0.6293416311269007D-11 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.9824457085249240D-02 , - 0.1868366188425022D-03 , & 0.1382010519568464D-05 , - 0.4664273845270264D-08 , 0.6021194214770955D-11 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.9610124664237659D-02 , - 0.1817785413839891D-03 , 0.1337247936813393D-05 , & - 0.4488212884613932D-08 , 0.5761511494190531D-11 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.9400772556451480D-02 , & - 0.1768669728309692D-03 , 0.1294036856105422D-05 , - 0.4319251170757689D-08 , & 0.5513761570246799D-11 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.9196289162604045D-02 , - 0.1720976016503106D-03 , & 0.1252321472812649D-05 , - 0.4157088979411857D-08 , 0.5277368355203496D-11 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.8996564874377288D-02 , - 0.1674662374614758D-03 , 0.1212048006359652D-05 , & - 0.4001439621616565D-08 , 0.5051784672739003D-11 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.8801492070348199D-02 , & - 0.1629688081494104D-03 , 0.1173164628601255D-05 , - 0.3852028867981131D-08 , & 0.4836490761736342D-11 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.8610965109799085D-02 , - 0.1586013570116659D-03 , & 0.1135621394543077D-05 , - 0.3708594398387685D-08 , 0.4630992859428825D-11 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.8424880324563941D-02 , - 0.1543600399420311D-03 , 0.1099370175347868D-05 , & - 0.3570885276056033D-08 , 0.4434821859616195D-11 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.8243136009031069D-02 , & - 0.1502411226521883D-03 , 0.1064364593563048D-05 , - 0.3438661444898418D-08 , & 0.4247532041882651D-11 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.8065632408460956D-02 , - 0.1462409779336193D-03 , & 0.1030559960512693D-05 , - 0.3311693249162145D-08 , 0.4068699868003324D-11 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.7892271705704355D-02 , - 0.1423560829604030D-03 , 0.9979132157871934D-06 , & - 0.3189760974363465D-08 , 0.3897922841887299D-11 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.7722958006465228D-02 , & - 0.1385830166346961D-03 , 0.9663828687750295D-06 , - 0.3072654408593283D-08 , & 0.3734818429651055D-11 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.7557597323207892D-02 , - 0.1349184569757125D-03 , & 0.9359289421757377D-06 , - 0.2960172423293103D-08 , 0.3579023036575502D-11 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.7396097557830871D-02 , - 0.1313591785534247D-03 , 0.9065129174384690D-06 , & - 0.2852122572652586D-08 , 0.3430191037896293D-11 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.7238368483176726D-02 , & - 0.1279020499671091D-03 , 0.8780976820643089D-06 , - 0.2748320710792168D-08 , & 0.3287993860513337D-11 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.7084321723516005D-02 , - 0.1245440313701914D-03 , & 0.8506474787227080D-06 , - 0.2648590625966881D-08 , 0.3152119112911578D-11 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.6933870734068311D-02 , - 0.1212821720413131D-03 , 0.8241278561228318D-06 , & - 0.2552763691025299D-08 , 0.3022269760688663D-11 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.6786930779662036D-02 , & - 0.1181136080022867D-03 , 0.7985056215882395D-06 , - 0.2460678529411785D-08 , & 0.2898163345254230D-11 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.6643418912599304D-02 , - 0.1150355596828912D-03 , & 0.7737487952799670D-06 , - 0.2372180696016365D-08 , 0.2779531243380165D-11 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.6503253949840233D-02 , - 0.1120453296333729D-03 , 0.7498265660216686D-06 , & - 0.2287122372230808D-08 , 0.2666117965437568D-11 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.6366356449537185D-02 , & - 0.1091403002838722D-03 , 0.7267092486702519D-06 , - 0.2205362074560518D-08 , & 0.2557680490228557D-11 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.6232648687021384D-02 , - 0.1063179317513902D-03 , & 0.7043682429874835D-06 , - 0.2126764376205086D-08 , 0.2453987634478045D-11 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.6102054630296956D-02 , - 0.1035757596939764D-03 , 0.6827759939629595D-06 , & - 0.2051199641025908D-08 , 0.2354819455131140D-11 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.5974499915104040D-02 , & - 0.1009113932119470D-03 , 0.6619059535414839D-06 , - 0.1978543769349365D-08 , & 0.2259966682708351D-11 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.5849911819632210D-02 , - 0.9832251279632344D-04 , & 0.6417325437122918D-06 , - 0.1908677955088408D-08 , 0.2169230184077968D-11 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.5728219238889821D-02 , - 0.9580686832322619D-04 , 0.6222311209087183D-06 , & - 0.1841488453656438D-08 , 0.2082420453055890D-11 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.5609352658846938D-02 , & - 0.9336227709511750D-04 , 0.6033779416839836D-06 , - 0.1776866360220463D-08 , & 0.1999357127389389D-11 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.5493244130355880D-02 , - 0.9098662192761576D-04 , & 0.5851501296146912D-06 , - 0.1714707397812840D-08 , 0.1919868530702299D-11 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.5379827242918167D-02 , - 0.8867784928185269D-04 , 0.5675256433940677D-06 , & - 0.1654911714870964D-08 , 0.1843791238090637D-11 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.5269037098315974D-02 , & - 0.8643396744140497D-04 , 0.5504832460717554D-06 , - 0.1597383691773602D-08 , & 0.1770969664105177D-11 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.5160810284204337D-02 , - 0.8425304473429061D-04 , & 0.5340024754085626D-06 , - 0.1542031755993915D-08 , 0.1701255671963687D-11 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.5055084847633720D-02 , - 0.8213320779819225D-04 , 0.5180636152996220D-06 , & - 0.1488768205456835D-08 , 0.1634508202840152D-11 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.4951800268588548D-02 , & - 0.8007263988923213D-04 , 0.5026476682358495D-06 , - 0.1437509039753471D-08 , & 0.1570592924195299D-11 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.4850897433552406D-02 , - 0.7806957923325594D-04 , & 0.4877363287652834D-06 , - 0.1388173798852272D-08 , 0.1509381896135239D-11 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.4752318609158823D-02 , - 0.7612231741948181D-04 , 0.4733119579233104D-06 , & - 0.1340685408981867D-08 , 0.1450753254861774D-11 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.4656007415899647D-02 , & - 0.7422919783481440D-04 , 0.4593575585913082D-06 , - 0.1294970035343383D-08 , & 0.1394590912291955D-11 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.4561908801990738D-02 , - 0.7238861413945775D-04 , & 0.4458567517603283D-06 , - 0.1250956941373371D-08 , 0.1340784271029150D-11 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.4469969017368635D-02 , - 0.7059900878219526D-04 , 0.4327937536620359D-06 , & - 0.1208578354245115D-08 , 0.1289227953859240D-11 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.4380135587865760D-02 , & - 0.6885887155506584D-04 , 0.4201533537394852D-06 , - 0.1167769336337776D-08 , & 0.1239821547021580D-11 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.4292357289557304D-02 , - 0.6716673818621144D-04 , & 0.4079208934248870D-06 , - 0.1128467662396136D-08 , 0.1192469356523234D-11 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.4206584123359440D-02 , - 0.6552118897122776D-04 , 0.3960822457029175D-06 , & - 0.1090613702146854D-08 , 0.1147080176838678D-11 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.4122767289821588D-02 , & - 0.6392084744094394D-04 , 0.3846237954229876D-06 , - 0.1054150308100703D-08 , & 0.1103567071319636D-11 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.4040859164183270D-02 , - 0.6236437906584784D-04 , & 0.3735324203401256D-06 , - 0.1019022708327014D-08 , 0.1061847163725785D-11 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.3960813271685645D-02 , - 0.6085048999596873D-04 , 0.3627954728556268D-06 , & - 0.9851784039690303D-09 , 0.1021841440288168D-11 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.3882584263181056D-02 , & - 0.5937792583598588D-04 , 0.3524007624357910D-06 , - 0.9525670712975183D-09 , & 0.9834745617686736D-12 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.3806127890991149D-02 , - 0.5794547045374393D-04 , & 0.3423365386775019D-06 , - 0.9211404680791318D-09 , 0.9466746849746106D-12 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.3731400984684343D-02 , - 0.5655194481499760D-04 , 0.3325914749517510D-06 , & - 0.8908523439230827D-09 , 0.9113732930701356D-12 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.3658361429252928D-02 , & - 0.5519620588970637D-04 , 0.3231546529244823D-06 , - 0.8616583554213349D-09 , & 0.8775050353849502D-12 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.3586968139372889D-02 , - 0.5387714551124306D-04 , & 0.3140155471089200D-06 , - 0.8335159833463338D-09 , 0.8450075732994961D-12 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.3517181038262642D-02 , - 0.5259368934644667D-04 , 0.3051640105377218D-06 , & - 0.8063844551854192D-09 , 0.8138214358080283D-12 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.3448961034702841D-02 , & - 0.5134479585553320D-04 , 0.2965902606931152D-06 , - 0.7802246702344204D-09 , & 0.7838898813144841D-12 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.3382270000880348D-02 , - 0.5012945529070156D-04 , & 0.2882848660218075D-06 , - 0.7549991281730345D-09 , 0.7551587665413591D-12 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.3317070750527970D-02 , - 0.4894668872285383D-04 , 0.2802387329472519D-06 , & - 0.7306718607646136D-09 , 0.7275764219549499D-12 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.3253327017437774D-02 , & - 0.4779554709701077D-04 , 0.2724430933692674D-06 , - 0.7072083665641087D-09 , & 0.7010935333974204D-12 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.3191003434316548D-02 , - 0.4667511031511935D-04 , & 0.2648894926293265D-06 , - 0.6845755484887972D-09 , 0.6756630295957964D-12 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.3130065512028553D-02 , - 0.4558448634626634D-04 , 0.2575697779287561D-06 , & - 0.6627416541359883D-09 , 0.6512399752596597D-12 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.3070479619138461D-02 , & - 0.4452281036213992D-04 , 0.2504760871740661D-06 , - 0.6416762186996253D-09 , & 0.6277814694551625D-12 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.3012212961868970D-02 , - 0.4348924389894061D-04 , & 0.2436008382451089D-06 , - 0.6213500104015382D-09 , 0.6052465490192033D-12 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.2955233564393344D-02 , - 0.4248297404374355D-04 , 0.2369367186622895D-06 , & - 0.6017349783024232D-09 , 0.5835960967329900D-12 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.2899510249500878D-02 , & - 0.4150321264528422D-04 , 0.2304766756418149D-06 , - 0.5828042023967504D-09 , & 0.5627927540234287D-12 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.2845012619591793D-02 , - 0.4054919554782388D-04 , & 0.2242139065203152D-06 , - 0.5645318458780224D-09 , 0.5428008379500191D-12 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.2791711038091843D-02 , - 0.3962018184894216D-04 , 0.2181418495440141D-06 , & - 0.5468931095018401D-09 , 0.5235862622844532D-12 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.2739576611170469D-02 , & - 0.3871545317877178D-04 , 0.2122541749976650D-06 , - 0.5298641879227367D-09 , & 0.5051164624440176D-12 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.2688581169843284D-02 , - 0.3783431300140664D-04 , & 0.2065447766685681D-06 , - 0.5134222279385395D-09 , 0.4873603241058471D-12 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.2638697252418662D-02 , - 0.3697608593726969D-04 , 0.2010077636294733D-06 , & - 0.4975452885473234D-09 , 0.4702881153056548D-12 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.2589898087330236D-02 , & - 0.3614011710656029D-04 , 0.1956374523326219D-06 , - 0.4822123027474519D-09 , & 0.4538714218562122D-12 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.2542157576260598D-02 , - 0.3532577149174525D-04 , & 0.1904283589946123D-06 , - 0.4674030409800222D-09 , 0.4380830858948851D-12 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.2495450277670064D-02 , - 0.3453243332039369D-04 , 0.1853751922721262D-06 , & - 0.4530980761698761D-09 , 0.4228971474319781D-12 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.2449751390643995D-02 , & - 0.3375950546648139D-04 , 0.1804728462098355D-06 , - 0.4392787502734480D-09 , & 0.4082887887281914D-12 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.2405036739087500D-02 , - 0.3300640887014114D-04 , & 0.1757163934532339D-06 , - 0.4259271422744372D-09 , 0.3942342813670664D-12 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.2361282756266082D-02 , - 0.3227258197538447D-04 , 0.1711010787167877D-06 , & - 0.4130260375640542D-09 , 0.3807109358882575D-12 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.2318466469641795D-02 , & - 0.3155748018451075D-04 , 0.1666223124931071D-06 , - 0.4005588986319604D-09 , & 0.3676970538411739D-12 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.2276565486115855D-02 , - 0.3086057533057402D-04 , & 0.1622756650051936D-06 , - 0.3885098370392882D-09 , 0.3551718821669395D-12 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.2235557977525040D-02 , - 0.3018135516502778D-04 , 0.1580568603785306D-06 , & - 0.3768635865798872D-09 , 0.3431155697560760D-12 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.2195422666495027D-02 , & - 0.2951932286179457D-04 , 0.1539617710347606D-06 , - 0.3656054776036317D-09 , & 0.3315091260993941D-12 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.2156138812595410D-02 , - 0.2887399653649146D-04 , & 0.1499864122939434D-06 , - 0.3547214124382935D-09 , 0.3203343819161048D-12 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.2117686198851777D-02 , - 0.2824490878127723D-04 , 0.1461269371827587D-06 , & - 0.3441978418749178D-09 , 0.3095739516739221D-12 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.2080045118484043D-02 , & - 0.2763160621295568D-04 , 0.1423796314299638D-06 , - 0.3340217426418744D-09 , & 0.2992111978804712D-12 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.2043196362026218D-02 , - 0.2703364903634569D-04 , & 0.1387409086557857D-06 , - 0.3241805958591791D-09 , 0.2892301970921668D-12 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.2007121204708395D-02 , - 0.2645061062075202D-04 , 0.1352073057381221D-06 , & - 0.3146623664048940D-09 , 0.2796157075315922D-12 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.1971801394149279D-02 , & - 0.2588207708993779D-04 , 0.1317754783533808D-06 , - 0.3054554831649762D-09 , & 0.2703531382450340D-12 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.1937219138294040D-02 , - 0.2532764692429705D-04 , & 0.1284421966802936D-06 , - 0.2965488201150307D-09 , 0.2614285197122547D-12 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.1903357093718698D-02 , - 0.2478693057672880D-04 , 0.1252043412710416D-06 , & - 0.2879316782238019D-09 , 0.2528284758619830D-12 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.1870198354136059D-02 , & - 0.2425955009943922D-04 , 0.1220588990701001D-06 , - 0.2795937681090915D-09 , & 0.2445401973926799D-12 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.1837726439212642D-02 , - 0.2374513878302060D-04 , & 0.1190029595846383D-06 , - 0.2715251934367797D-09 , 0.2365514163569210D-12 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.1805925283638388D-02 , - 0.2324334080665570D-04 , 0.1160337111963808D-06 , & - 0.2637164350195331D-09 , 0.2288503819373143D-12 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.1774779226504154D-02 , & - 0.2275381089998443D-04 , 0.1131484376144187D-06 , - 0.2561583355965683D-09 , & 0.2214258373668569D-12 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.1744273000856269D-02 , - 0.2227621401444777D-04 , & 0.1103445144535360D-06 , - 0.2488420852398493D-09 , 0.2142669979148526D-12 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.1714391723582537D-02 , - 0.2181022500612518D-04 , 0.1076194059460252D-06 , & - 0.2417592073907265D-09 , 0.2073635299155628D-12 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.1685120885510583D-02 , & - 0.2135552832806755D-04 , 0.1049706617728642D-06 , - 0.2349015454772118D-09 , & 0.2007055307682145D-12 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.1656446341757204D-02 , - 0.2091181773245799D-04 , & 0.1023959140131799D-06 , - 0.2282612500950848D-09 , 0.1942835098690851D-12 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.1628354302329247D-02 , - 0.2047879598237558D-04 , 0.9989287420793108D-07 , & - 0.2218307667292817D-09 , 0.1880883704313710D-12 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.1600831322900554D-02 , & - 0.2005617457185522D-04 , 0.9745933052802921D-07 , - 0.2156028239789425D-09 , & 0.1821113921379748D-12 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.1573864295927266D-02 , - 0.1964367345636433D-04 , & 0.9509314505579160D-07 , - 0.2095704222952368D-09 , 0.1763442146151031D-12 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.1547440441884461D-02 , - 0.1924102079036627D-04 , 0.9279225115920279D-07 , & - 0.2037268231706278D-09 , 0.1707788216516457D-12 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.1521547300771237D-02 , & - 0.1884795267389010D-04 , 0.9055465096702354D-07 , - 0.1980655387878623D-09 , & 0.1654075261536951D-12 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.1496172723809030D-02 , - 0.1846421290683499D-04 , & 0.8837841293560248D-07 , - 0.1925803220960199D-09 , 0.1602229557873457D-12 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.1471304865407402D-02 , - 0.1808955275187433D-04 , 0.8626166950981181D-07 , & - 0.1872651573091592D-09 , 0.1552180392892663D-12 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.1446932175227456D-02 , & - 0.1772373070337948D-04 , 0.8420261486228127D-07 , - 0.1821142507802935D-09 , & 0.1503859933872177D-12 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.1423043390547988D-02 , - 0.1736651226509106D-04 , & 0.8219950272344763D-07 , - 0.1771220222711701D-09 , 0.1457203103340274D-12 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.1399627528779659D-02 , - 0.1701766973418170D-04 , 0.8025064428795170D-07 , & - 0.1722830965747157D-09 , 0.1412147460025192D-12 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.1376673880149008D-02 , & - 0.1667698199198734D-04 , 0.7835440619778932D-07 , - 0.1675922954847633D-09 , & 0.1368633085253307D-12 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.1354172000731215D-02 , - 0.1634423430300986D-04 , & 0.7650920860439172D-07 , - 0.1630446300982618D-09 , 0.1326602474422500D-12 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.1332111705334047D-02 , - 0.1601921811694457D-04 , 0.7471352329159723D-07 , & - 0.1586352934298899D-09 , 0.1286000433547665D-12 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.1310483060901014D-02 , & - 0.1570173088043925D-04 , 0.7296587187809592D-07 , - 0.1543596533353551D-09 , & 0.1246773980338188D-12 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.1289276379915072D-02 , - 0.1539157585306677D-04 , & 0.7126482408013667D-07 , - 0.1502132457216593D-09 , 0.1208872249806950D-12 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.1268482214008328D-02 , - 0.1508856192949849D-04 , 0.6960899603890193D-07 , & - 0.1461917680359461D-09 , 0.1172246404115757D-12 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.1248091347722361D-02 , & - 0.1479250346710634D-04 , 0.6799704870786733D-07 , - 0.1422910730178278D-09 , & 0.1136849546449211D-12 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.1228094792504836D-02 , - 0.1450322012003333D-04 , & 0.6642768630408765D-07 , - 0.1385071627181196D-09 , 0.1102636638849027D-12 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.1208483780725566D-02 , - 0.1422053667665956D-04 , 0.6489965480634942D-07 , & - 0.1348361827392524D-09 , 0.1069564423536695D-12 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.1189249759978666D-02 , & - 0.1394428290397838D-04 , 0.6341174051693909D-07 , - 0.1312744167301497D-09 , & 0.1037591347922954D-12 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.1170384387473142D-02 , - 0.1367429339607702D-04 , & 0.6196276867143320D-07 , - 0.1278182810947042D-09 , 0.1006677492874047D-12 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.1151879524597971D-02 , - 0.1341040742778215D-04 , 0.6055160210077468D-07 , & - 0.1244643199186021D-09 , 0.9767845042007570D-13 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.1133727231558369D-02 , & - 0.1315246881198065D-04 , 0.5917713993700033D-07 , - 0.1212092000902833D-09 , & 0.9478755270936777D-13 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.1115919762288055D-02 , - 0.1290032576325486D-04 , & 0.5783831637484230D-07 , - 0.1180497066389146D-09 , 0.9199151436298004D-13 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.1098449559369230D-02 , - 0.1265383076414265D-04 , 0.5653409946958359D-07 , & - 0.1149827382409612D-09 , 0.8928693128770578D-13 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.1081309249146670D-02 , & - 0.1241284043642496D-04 , 0.5526348998230335D-07 , - 0.1120053029162548D-09 , & 0.8667053137125099D-13 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.1064491636944703D-02 , - 0.1217721541613219D-04 , & 0.5402552026499085D-07 , - 0.1091145138927624D-09 , 0.8413916901210359D-13 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.1047989702481079D-02 , - 0.1194682023342066D-04 , 0.5281925319033441D-07 , & - 0.1063075856468916D-09 , 0.8168981989757869D-13 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.1031796595271183D-02 , & - 0.1172152319451537D-04 , 0.5164378111142523D-07 , - 0.1035818300831245D-09 , & 0.7931957599470217D-13 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.1015905630277843D-02 , - 0.1150119626900006D-04 , & 0.5049822486680661D-07 , - 0.1009346528836272D-09 , 0.7702564077439753D-13 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.1000310283618398D-02 , - 0.1128571497989375D-04 , 0.4938173281737325D-07 , & - 0.9836354999473150D-10 , 0.7480532463673280D-13 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.9850041883970231D-03 , & - 0.1107495829733486D-04 , 0.4829347991843258D-07 , - 0.9586610425449410D-10 , & 0.7265604053624876D-13 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.9699811306674397D-03 , - 0.1086880853586209D-04 , & 0.4723266682611726D-07 , - 0.9343998215651493D-10 , 0.7057529979906844D-13 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.9552350454127985D-03 , - 0.1066715125376003D-04 , 0.4619851903000224D-07 , & - 0.9108293072950202D-10 , 0.6856070811098380D-13 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.9407600128020618D-03 , & - 0.1046987515775042D-04 , 0.4519028602718580D-07 , - 0.8879277456287751D-10 , & 0.6660996169727720D-13 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.9265502543868312D-03 , - 0.1027687200862097D-04 , & 0.4420724051575976D-07 , - 0.8656741292799180D-10 , 0.6472084364950746D-13 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.9126001294750081D-03 , - 0.1008803653078456D-04 , 0.4324867762160099D-07 , & - 0.8440481702265443D-10 , 0.6289122041833779D-13 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.8989041315681471D-03 , & - 0.9903266324249189D-05 , 0.4231391415051833D-07 , - 0.8230302731938852D-10 , & 0.6111903845315316D-13 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.8854568849816000D-03 , - 0.9722461780455989D-05 , & 0.4140228787215755D-07 , - 0.8026015102878375D-10 , 0.5940232099439253D-13 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.8722531413907257D-03 , - 0.9545525998664778D-05 , 0.4051315681923669D-07 , & - 0.7827435964076169D-10 , 0.5773916498576829D-13 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.8592877766240444D-03 , & - 0.9372364706913630D-05 , 0.3964589862084385D-07 , - 0.7634388658160609D-10 , & 0.5612773813382525D-13 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.8465557874690143D-03 , - 0.9202886184517875D-05 , & 0.3879990985476804D-07 , - 0.7446702495272142D-10 , 0.5456627608481557D-13 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.8340522885771063D-03 , - 0.9037001187160696D-05 , 0.3797460542341610D-07 , & - 0.7264212535894800D-10 , 0.5305307972257800D-13 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.8217725094753610D-03 , & - 0.8874622874614656D-05 , 0.3716941795301381D-07 , - 0.7086759382392567D-10 , & 0.5158651258290072D-13 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.8097117915467015D-03 , - 0.8715666739319331D-05 , & 0.3638379720730252D-07 , - 0.6914188977239455D-10 , 0.5016499836618355D-13 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.7978655852997836D-03 , - 0.8560050539787732D-05 , 0.3561720953396332D-07 , & - 0.6746352411588265D-10 , 0.4878701857477880D-13 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.7862294475149440D-03 , & - 0.8407694233620052D-05 , 0.3486913731881834D-07 , - 0.6583105738800300D-10 , & 0.4745111023057816D-13 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.7747990385596020D-03 , - 0.8258519913755604D-05 , & 0.3413907846448053D-07 , - 0.6424309796273584D-10 , 0.4615586369706285D-13 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.7635701197345646D-03 , - 0.8112451746192929D-05 , 0.3342654588477465D-07 , & - 0.6269830033613774D-10 , 0.4489992058853013D-13 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.7525385507991405D-03 , & - 0.7969415910958789D-05 , 0.3273106702280279D-07 , - 0.6119536348631564D-10 , & 0.4368197177612853D-13 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.7417002873599962D-03 , - 0.7829340542416715D-05 , & 0.3205218337424010D-07 , - 0.5973302927242801D-10 , 0.4250075545856571D-13 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.7310513785204335D-03 , - 0.7692155673754364D-05 , 0.3138945003789158D-07 , & - 0.5831008091681681D-10 , 0.4135505532994419D-13 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.7205879645022340D-03 , & - 0.7557793182074086D-05 , 0.3074243527665064D-07 , - 0.5692534153431970D-10 , & 0.4024369881528175D-13 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.7103062743703680D-03 , - 0.7426186735650686D-05 , & 0.3011072009576314D-07 , - 0.5557767272179536D-10 , 0.3916555538226105D-13 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.7002026237145398D-03 , - 0.7297271741553176D-05 , 0.2949389782987751D-07 , & - 0.5426597318944347D-10 , 0.3811953491368242D-13 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.6902734125873863D-03 , & - 0.7170985297226745D-05 , 0.2889157375495612D-07 , - 0.5298917746544078D-10 , & 0.3710458616323943D-13 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.6805151233139774D-03 , - 0.7047266141338248D-05 , & 0.2830336470338940D-07 , - 0.5174625462894347D-10 , 0.3611969525902381D-13 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.6709243184465288D-03 , - 0.6926054607173493D-05 , 0.2772889869702437D-07 , & - 0.5053620710033853D-10 , 0.3516388427552739D-13 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.6614976387570575D-03 , & - 0.6807292577257744D-05 , 0.2716781459180045D-07 , - 0.4935806947501350D-10 , & 0.3423620986246821D-13 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.6522318012553226D-03 , - 0.6690923439025471D-05 , & 0.2661976173298743D-07 , - 0.4821090739778241D-10 , 0.3333576192716621D-13 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.6431235973905054D-03 , - 0.6576892043395036D-05 , 0.2608439962907777D-07 , & - 0.4709381649312983D-10 , 0.3246166238070012D-13 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.6341698910546591D-03 , & - 0.6465144661681607D-05 , 0.2556139762369548D-07 , - 0.4600592130936116D-10 , & 0.3161306391543327D-13 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.6253676168710876D-03 , - 0.6355628946569975D-05 , & 0.2505043459088917D-07 , - 0.4494637432640797D-10 , 0.3078914885015252D-13 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.6167137784183511D-03 , - 0.6248293892966863D-05 , 0.2455119863489854D-07 , & - 0.4391435498885358D-10 , 0.2998912801308425D-13 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.6082054465490884D-03 , & - 0.6143089800599114D-05 , 0.2406338680252357D-07 , - 0.4290906877962428D-10 , & 0.2921223967342307D-13 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.5998397576277997D-03 , - 0.6039968236271927D-05 , & 0.2358670479870122D-07 , - 0.4192974631519387D-10 , 0.2845774850635690D-13 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.5916139120509475D-03 , - 0.5938882000022216D-05 , 0.2312086672375471D-07 , & - 0.4097564249786430D-10 , 0.2772494461697396D-13 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.5835251725838648D-03 , & - 0.5839785089690032D-05 , 0.2266559480800361D-07 , - 0.4004603567677236D-10 , & 0.2701314258659841D-13 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.5755708628467917D-03 , - 0.5742632667784656D-05 , & 0.2222061916065187D-07 , - 0.3914022685023865D-10 , 0.2632168056487009D-13 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.5677483658207988D-03 , - 0.5647381029110464D-05 , 0.2178567752602153D-07 , & - 0.3825753889526531D-10 , 0.2564991939637571D-13 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.5600551223597153D-03 , & - 0.5553987568975371D-05 , 0.2136051504622202D-07 , - 0.3739731582191054D-10 , & 0.2499724177952142D-13 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.5524886298976090D-03 , - 0.5462410754155034D-05 , & 0.2094488403951687D-07 , - 0.3655892206984956D-10 , 0.2436305146951611D-13 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.5450464408960332D-03 , - 0.5372610091330376D-05 , 0.2053854377135238D-07 , & - 0.3574174180220121D-10 , 0.2374677249229401D-13 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.5377261616098413D-03 , & - 0.5284546099666056D-05 , 0.2014126024680414D-07 , - 0.3494517825159501D-10 , & 0.2314784840862023D-13 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.5305254507537718D-03 , - 0.5198180282688432D-05 , & 0.1975280600331708D-07 , - 0.3416865307725021D-10 , 0.2256574159791463D-13 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.5234420182610987D-03 , - 0.5113475101650050D-05 , 0.1937295991306591D-07 , & - 0.3341160575057445D-10 , 0.2199993257391454D-13 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.5164736239248124D-03 , & - 0.5030393947982711D-05 , 0.1900150698456150D-07 , - 0.3267349294910306D-10 , & 0.2144991931721813D-13 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.5096180763560311D-03 , - 0.4948901119759121D-05 , & 0.1863823818437463D-07 , - 0.3195378799802882D-10 , 0.2091521665223313D-13 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.5028732317037426D-03 , - 0.4868961795835247D-05 , 0.1828295025184761D-07 , & - 0.3125198030734395D-10 , 0.2039535563091970D-13 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.4962369925338270D-03 , & - 0.4790542012181377D-05 , 0.1793544552593414D-07 , - 0.3056757484062409D-10 , & 0.1988988294862344D-13 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.4897073066827563D-03 , - 0.4713608638295987D-05 , & 0.1759553177508721D-07 , - 0.2990009159785876D-10 , 0.1939836037901680D-13 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.4832821662838695D-03 , - 0.4638129355908213D-05 , 0.1726302203938496D-07 , & - 0.2924906512922389D-10 , 0.1892036423964260D-13 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.4769596065506180D-03 , & - 0.4564072635304097D-05 , 0.1693773446516807D-07 , - 0.2861404404249777D-10 , & 0.1845548486140050D-13 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.4707377048446016D-03 , - 0.4491407715176038D-05 , & 0.1661949215692488D-07 , - 0.2799459055017045D-10 , 0.1800332609403010D-13 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.4646145796477786D-03 , - 0.4420104581719407D-05 , 0.1630812302832511D-07 , & - 0.2739028002199560D-10 , 0.1756350482309230D-13 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.4585883895840307D-03 , & - 0.4350133948592472D-05 , 0.1600345965912198D-07 , - 0.2680070055529865D-10 , & 0.1713565050678296D-13 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.4526573325012708D-03 , - 0.4281467237860580D-05 , & 0.1570533915835557D-07 , - 0.2622545256355099D-10 , 0.1671940473256532D-13 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.4468196444132508D-03 , - 0.4214076559621031D-05 , 0.1541360302400062D-07 , & - 0.2566414836453808D-10 , 0.1631442078037904D-13 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.4410735987752865D-03 , & - 0.4147934695728096D-05 , 0.1512809702202437D-07 , - 0.2511641181079305D-10 , & 0.1592036322166126D-13 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.4354175054904658D-03 , - 0.4083015080682487D-05 , & 0.1484867105523418D-07 , - 0.2458187790661282D-10 , 0.1553690751531937D-13 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.4298497100772074D-03 , - 0.4019291784634122D-05 , 0.1457517904296335D-07 , & - 0.2406019245085950D-10 , 0.1516373962754130D-13 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.4243685927964909D-03 , & - 0.3956739496187734D-05 , 0.1430747880172640D-07 , - 0.2355101168690519D-10 , & 0.1480055566228775D-13 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.4189725679694126D-03 , - 0.3895333507525230D-05 , & 0.1404543193709252D-07 , - 0.2305400197819632D-10 , 0.1444706151484460D-13 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.4136600829962361D-03 , - 0.3835049696526508D-05 , 0.1378890372500269D-07 , & - 0.2256883946964342D-10 , 0.1410297252101567D-13 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.4084296176988347D-03 , & - 0.3775864512638864D-05 , 0.1353776301003278D-07 , - 0.2209520978464599D-10 , & 0.1376801313574963D-13 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.4032796835384527D-03 , - 0.3717754961615750D-05 , & 0.1329188210060773D-07 , - 0.2163280772118004D-10 , 0.1344191661598152D-13 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.3982088228802270D-03 , - 0.3660698590981825D-05 , 0.1305113666869754D-07 , & - 0.2118133696046624D-10 , 0.1312442471671768D-13 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.3932156083206616D-03 , & - 0.3604673476384165D-05 , 0.1281540565455615D-07 , - 0.2074050978899596D-10 , & 0.1281528740064837D-13 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.3882986418250497D-03 , - 0.3549658206119403D-05 , & 0.1258457116556797D-07 , - 0.2031004681419234D-10 , 0.1251426254784517D-13 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.3834565542762964D-03 , - 0.3495631870258896D-05 , 0.1235851839494395D-07 , & - 0.1988967671957759D-10 , 0.1222111569617187D-13 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.3786880046670379D-03 , & - 0.3442574046151161D-05 , 0.1213713552718214D-07 , - 0.1947913600008626D-10 , & 0.1193561977232839D-13 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.3739916794866307D-03 , - 0.3390464786195973D-05 , & 0.1192031365393932D-07 , - 0.1907816871969880D-10 , 0.1165755484171410D-13 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.3693662920485116D-03 , - 0.3339284605167129D-05 , 0.1170794668934381D-07 , & - 0.1868652627165255D-10 , 0.1138670786369714D-13 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.3648105820301688D-03 , & - 0.3289014469953767D-05 , 0.1149993129609546D-07 , - 0.1830396716114055D-10 , & 0.1112287246534914D-13 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.3603233146563347D-03 , - 0.3239635785707755D-05 , & 0.1129616679847699D-07 , - 0.1793025676822287D-10 , 0.1086584870546563D-13 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.3559032802506617D-03 , - 0.3191130386045857D-05 , 0.1109655511256529D-07 , & - 0.1756516714429793D-10 , 0.1061544286410832D-13 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.3515492936335498D-03 , & - 0.3143480521786366D-05 , 0.1090100067170247D-07 , - 0.1720847680325294D-10 , & 0.1037146723173167D-13 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.3472601935663739D-03 , - 0.3096668850329950D-05 , & 0.1070941035556006D-07 , - 0.1685997052189768D-10 , 0.1013373990745379D-13 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.3430348422607992D-03 , - 0.3050678425867286D-05 , 0.1052169342344525D-07 , & - 0.1651943915064580D-10 , 0.9902084606940907D-14 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.3388721246604432D-03 , & - 0.3005492687369659D-05 , 0.1033776143994103D-07 , - 0.1618667941365232D-10 , & 0.9676330466219995D-14 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.3347709481918480D-03 , - 0.2961095451596269D-05 , & 0.1015752822107146D-07 , - 0.1586149374727594D-10 , 0.9456311873190406D-14 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.3307302420947881D-03 , - 0.2917470901866430D-05 , 0.9980909764840899D-08 , & - 0.1554369011392777D-10 , 0.9241868285631407D-14 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.3267489569715783D-03 , & - 0.2874603579241143D-05 , 0.9807824192063145D-08 , - 0.1523308183626875D-10 , & 0.9032844064962392D-14 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.3228260642606884D-03 , - 0.2832478373052969D-05 , & 0.9638191685519361D-08 , - 0.1492948743090465D-10 , 0.8829088312061101D-14 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.3189605559492416D-03 , - 0.2791080514009968D-05 , 0.9471934439857858D-08 , & - 0.1463273046280477D-10 , 0.8630454718732356D-14 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.3151514438671411D-03 , & - 0.2750395563130429D-05 , 0.9308976596229694D-08 , - 0.1434263937575394D-10 , & 0.8436801405942749D-14 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.3113977594007504D-03 , - 0.2710409405099882D-05 , & 0.9149244194742111D-08 , - 0.1405904735551306D-10 , 0.8247990785252930D-14 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.3076985530227344D-03 , - 0.2671108239854593D-05 , 0.8992665120815346D-08 , & - 0.1378179218455800D-10 , 0.8063889416842853D-14 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.3040528938696930D-03 , & - 0.2632478574765690D-05 , 0.8839169054572885D-08 , - 0.1351071610399472D-10 , & 0.7884367874104976D-14 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.3004598693888778D-03 , - 0.2594507217628567D-05 , & 0.8688687423988925D-08 , - 0.1324566568374956D-10 , 0.7709300615390231D-14 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.2969185847181838D-03 , - 0.2557181267063830D-05 , 0.8541153348898829D-08 , & - 0.1298649167919292D-10 , 0.7538565848979190D-14 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.2934281625998156D-03 , & - 0.2520488108410676D-05 , 0.8396501606507042D-08 , - 0.1273304892586648D-10 , & 0.7372045423980178D-14 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.2899877428054887D-03 , - 0.2484415404781438D-05 , & 0.8254668579156531D-08 , - 0.1248519620594825D-10 , 0.7209624704964480D-14 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.2865964818083306D-03 , - 0.2448951090705243D-05 , 0.8115592212541544D-08 , & - 0.1224279613402710D-10 , 0.7051192460471725D-14 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.2832535523631604D-03 , & - 0.2414083364944980D-05 , 0.7979211971398533D-08 , - 0.1200571504025196D-10 , & 0.6896640751420476D-14 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.5882352941176740D-01 , - 0.3674594258332413D-02 , & 0.1160584316218424D-03 , - 0.2466255535984919D-05 , 0.3960258533179974D-07 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.5882352906907068D-01 , - 0.3674592285767449D-02 , 0.1160540163386424D-03 , & - 0.2461349796222630D-05 , 0.3712387468702784D-07 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.5882351584207977D-01 , & - 0.3674559079905824D-02 , 0.1160221509421550D-03 , - 0.2447461647916082D-05 , & 0.3480111417149284D-07 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.5882342727701079D-01 , - 0.3674420489422762D-02 , & 0.1159401857783360D-03 , - 0.2425740337744038D-05 , 0.3262444761920842D-07 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.5882311519709546D-01 , - 0.3674067764041422D-02 , 0.1157900688207347D-03 , & - 0.2397225580671648D-05 , 0.3058464425559275D-07 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.5882232286410885D-01 , & - 0.3673368034223511D-02 , 0.1155577511038904D-03 , - 0.2362856850267697D-05 , & 0.2867305887588299D-07 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.5882067283847340D-01 , - 0.3672173041777799D-02 , & 0.1152326557314313D-03 , - 0.2323481928494386D-05 , 0.2688159456710806D-07 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.5881766328410366D-01 , - 0.3670326349230444D-02 , 0.1148072043475508D-03 , & - 0.2279864771782565D-05 , 0.2520266781069726D-07 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.5881267081459669D-01 , & - 0.3667669230022967D-02 , 0.1142763955093158D-03 , - 0.2232692745957081D-05 , & 0.2362917581326423D-07 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.5880495828190776D-01 , - 0.3664045418486463D-02 , & 0.1136374298990410D-03 , - 0.2182583278640673D-05 , 0.2215446592289477D-07 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.5879368617265483D-01 , - 0.3659304877826516D-02 , 0.1128893777746194D-03 , & - 0.2130089974117836D-05 , 0.2077230699742519D-07 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.5877792650546119D-01 , & - 0.3653306725808799D-02 , 0.1120328844748242D-03 , - 0.2075708232261458D-05 , & 0.1947686259976768D-07 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.5875667831954802D-01 , - 0.3645921441248447D-02 , & 0.1110699101794657D-03 , - 0.2019880409995357D-05 , 0.1826266590335899D-07 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.5872888401392884D-01 , - 0.3637032459584421D-02 , 0.1100035004739201D-03 , & - 0.1963000560866630D-05 , 0.1712459619830498D-07 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.5869344594142255D-01 , & - 0.3626537252589168D-02 , 0.1088375845867360D-03 , - 0.1905418785617250D-05 , & 0.1605785689582387D-07 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.5864924278529182D-01 , - 0.3614347975465470D-02 , & 0.1075767984602953D-03 , - 0.1847445224157449D-05 , 0.1505795493514912D-07 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.5859514535130574D-01 , - 0.3600391754073588D-02 , 0.1062263300802265D-03 , & - 0.1789353717041238D-05 , 0.1412068150320506D-07 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.5853003149677777D-01 , & - 0.3584610675682660D-02 , 0.1047917847315767D-03 , - 0.1731385162412506D-05 , & 0.1324209398311751D-07 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.5845279999274522D-01 , - 0.3566961538333602D-02 , & 0.1032790680706236D-03 , - 0.1673750592416466D-05 , 0.1241849905300318D-07 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.5836238317778492D-01 , - 0.3547415406530205D-02 , 0.1016942851024722D-03 , & - 0.1616633991244169D-05 , 0.1164643686151702D-07 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.5825775831364171D-01 , & - 0.3525957014444647D-02 , 0.1000436533378892D-03 , - 0.1560194875286664D-05 , & 0.1092266621134902D-07 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.5813795759532546D-01 , - 0.3502584052046499D-02 , & 0.9833342856971618D-04 , - 0.1504570654310183D-05 , 0.1024415068627057D-07 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.5800207680288505D-01 , - 0.3477306364461979D-02 , 0.9656984186107417D-04 , & - 0.1449878791115295D-05 , 0.9608045661457055D-08 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.5784928260981081D-01 , & - 0.3450145090372038D-02 , 0.9475904647570981D-04 , - 0.1396218775802724D-05 , & 0.9011686140673845D-08 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.5767881858493742D-01 , - 0.3421131761299794D-02 , & 0.9290707360642363D-04 , - 0.1343673929528505D-05 , 0.8452575367526214D-08 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.5749000994167762D-01 , - 0.3390307380162335D-02 , 0.9101979587164116D-04 , & - 0.1292313051484027D-05 , 0.7928374161354446D-08 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.5728226710116927D-01 , & - 0.3357721494417098D-02 , 0.8910289765383641D-04 , - 0.1242191921775493D-05 , & 0.7436890931519657D-08 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.5705508814512274D-01 , - 0.3323431276472005D-02 , & 0.8716185144759869D-04 , - 0.1193354671895915D-05 , 0.6976072326786525D-08 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.5680806024038772D-01 , - 0.3287500621709310D-02 , 0.8520189947048659D-04 , & - 0.1145835033575351D-05 , 0.6543994479280080D-08 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.5654086012101520D-01 , & - 0.3249999272457737D-02 , 0.8322803986719957D-04 , - 0.1099657475955952D-05 , & 0.6138854805086817D-08 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.5625325371530843D-01 , - 0.3211001974502027D-02 , & 0.8124501690771649D-04 , - 0.1054838240262673D-05 , 0.5758964325996996D-08 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.5594509500540481D-01 , - 0.3170587671212780D-02 , 0.7925731464354568D-04 , & - 0.1011386280423441D-05 , 0.5402740479156103D-08 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.5561632420563706D-01 , & - 0.3128838739085122D-02 , 0.7726915354368701D-04 , - 0.9693041174298152D-06 , & 0.5068700383518838D-08 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.5526696534355897D-01 , - 0.3085840267367642D-02 , & 0.7528448968386062D-04 , - 0.9285886146167250D-06 , 0.4755454533988031D-08 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.5489712332432814D-01 , - 0.3041679383521166D-02 , 0.7330701610950229D-04 , & - 0.8892316804740157D-06 , 0.4461700895982484D-08 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.5450698055531550D-01 , & - 0.2996444625450587D-02 , 0.7134016603540945D-04 , - 0.8512209050797186D-06 , & 0.4186219374919996D-08 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.5409679320353181D-01 , - 0.2950225360784472D-02 , & 0.6938711758315725D-04 , - 0.8145401357621080D-06 , 0.3927866636732305D-08 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.5366688715386579D-01 , - 0.2903111252920774D-02 , 0.6745079979186599D-04 , & - 0.7791699971516373D-06 , 0.3685571257054837D-08 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.5321765373134133D-01 , & - 0.2855191773098735D-02 , 0.6553389966893353D-04 , - 0.7450883603720665D-06 , & 0.3458329178162388D-08 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.5274954524571922D-01 , - 0.2806555757384214D-02 , & 0.6363887007526183D-04 , - 0.7122707657399158D-06 , 0.3245199454058681D-08 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.5226307041187794D-01 , - 0.2757291007157553D-02 , 0.6176793826459836D-04 , & - 0.6806908029904930D-06 , 0.3045300265378912D-08 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.5175878969456682D-01 , & - 0.2707483931458687D-02 , 0.5992311491912053D-04 , - 0.6503204527247826D-06 , & 0.2857805186935423D-08 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.5123731062140661D-01 , - 0.2657219229366855D-02 , & 0.5810620354360221D-04 , - 0.6211303924728197D-06 , 0.2681939691832725D-08 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.5069928310343084D-01 , - 0.2606579610461211D-02 , 0.5631881009856310D-04 , & - 0.5930902704933244D-06 , 0.2516977877104010D-08 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.5014539479807630D-01 , & - 0.2555645551319795D-02 , 0.5456235276898117D-04 , - 0.5661689501751810D-06 , & 0.2362239396781469D-08 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.4957636654535148D-01 , - 0.2504495085959824D-02 , & 0.5283807177958383D-04 , - 0.5403347276718339D-06 , 0.2217086589211584D-08 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.4899294790395934D-01 , - 0.2453203628097415D-02 , 0.5114703918060675D-04 , & - 0.5155555251834829D-06 , 0.2080921786267794D-08 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.4839591281043723D-01 , & - 0.2401843823104845D-02 , 0.4949016853936725D-04 , - 0.4917990621026694D-06 , & 0.1953184792900415D-08 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.4778605538090876D-01 , - 0.2350485427564004D-02 , & 0.4786822448317978D-04 , - 0.4690330060552057D-06 , 0.1833350526200775D-08 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.4716418587182103D-01 , - 0.2299195214352385D-02 , 0.4628183204816766D-04 , & - 0.4472251056991817D-06 , 0.1720926803846486D-08 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.4653112681306667D-01 , & - 0.2248036901249363D-02 , 0.4473148579651336D-04 , - 0.4263433069889275D-06 , & 0.1615452272440633D-08 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.4588770932415749D-01 , - 0.2197071101113068D-02 , & 0.4321755867173936D-04 , - 0.4063558544672690D-06 , 0.1516494466862176D-08 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.4523476962162228D-01 , - 0.2146355291749343D-02 , 0.4174031056782026D-04 , & - 0.3872313790172692D-06 , 0.1423647992310818D-08 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.4457314572353405D-01 , & - 0.2095943803672101D-02 , 0.4029989659337642D-04 , - 0.3689389733830165D-06 , & 0.1336532821259327D-08 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.4390367435502603D-01 , - 0.2045887824036933D-02 , & 0.3889637501696942D-04 , - 0.3514482566570932D-06 , 0.1254792698022201D-08 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.4322718805681841D-01 , - 0.1996235415115702D-02 , 0.3752971488367813D-04 , & - 0.3347294288294019D-06 , 0.1178093644113800D-08 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.4254451249714009D-01 , & - 0.1947031545767695D-02 , 0.3619980329674794D-04 , - 0.3187533163973473D-06 , & 0.1106122558003663D-08 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.4185646398597829D-01 , - 0.1898318134451478D-02 , & 0.3490645236122710D-04 , - 0.3034914099503055D-06 , 0.1038585903283517D-08 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.4116384718931537D-01 , - 0.1850134102410260D-02 , 0.3364940578919283D-04 , & - 0.2889158945613341D-06 , 0.9752084796413962D-09 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.4046745303990103D-01 , & - 0.1802515435751181D-02 , 0.3242834516846397D-04 , - 0.2749996737455451D-06 , & 0.9157322713947948D-09 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.3976805684015045D-01 , - 0.1755495255225127D-02 , & 0.3124289589864796D-04 , - 0.2617163876770700D-06 , 0.8599153686685777D-09 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.3906641655194412D-01 , - 0.1709103892597863D-02 , 0.3009263280001055D-04 , & - 0.2490404262945626D-06 , 0.8075309566158934D-09 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.3836327126741725D-01 , & - 0.1663368972584807D-02 , 0.2897708540202298D-04 , - 0.2369469378682856D-06 , & 0.7583663683728530D-09 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.3765933985426238D-01 , - 0.1618315499400746D-02 , & 0.2789574291956733D-04 , - 0.2254118335496562D-06 , 0.7122221977116669D-09 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.3695531976860986D-01 , - 0.1573965947051505D-02 , 0.2684805892569115D-04 , & - 0.2144117883762547D-06 , 0.6689114676133719D-09 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.3625188602819408D-01 , & - 0.1530340352567154D-02 , 0.2583345573052428D-04 , - 0.2039242391614278D-06 , & 0.6282588512213204D-09 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.3554969033824684D-01 , - 0.1487456411445579D-02 , & 0.2485132847652955D-04 , - 0.1939273796574286D-06 , 0.5900999418614513D-09 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.3484936036236418D-01 , - 0.1445329574640718D-02 , 0.2390104896066739D-04 , & - 0.1844001533442107D-06 , 0.5542805690257637D-09 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.3415149913049239D-01 , & - 0.1403973146492386D-02 , 0.2298196919434412D-04 , - 0.1753222441622960D-06 , & 0.5206561574124761D-09 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.3345668457611394D-01 , - 0.1363398383052934D-02 , & 0.2209342471218549D-04 , - 0.1666740654773047D-06 , 0.4890911263008788D-09 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.3276546919472988D-01 , - 0.1323614590321466D-02 , 0.2123473764075891D-04 , & - 0.1584367475355292D-06 , 0.4594583267115712D-09 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.3207837981578987D-01 , & - 0.1284629221948106D-02 , 0.2040521953836624D-04 , - 0.1505921236441718D-06 , & 0.4316385139645715D-09 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.3139591748032207D-01 , - 0.1246447976019340D-02 , & 0.1960417401695771D-04 , - 0.1431227152863218D-06 , 0.4055198533992158D-09 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.3071855741665371D-01 , - 0.1209074890580585D-02 , 0.1883089915708508D-04 , & - 0.1360117163592514D-06 , 0.3809974571615441D-09 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.3004674910678642D-01 , & - 0.1172512437594378D-02 , 0.1808468972663356D-04 , - 0.1292429767050204D-06 , & 0.3579729500977037D-09 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.2938091643618751D-01 , - 0.1136761615071479D-02 , & 0.1736483921384685D-04 , - 0.1228009850844914D-06 , 0.3363540629161892D-09 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.2872145791998134D-01 , - 0.1101822037148360D-02 , 0.1667064168490333D-04 , & - 0.1166708517295794D-06 , 0.3160542508981759D-09 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.2806874699876771D-01 , & - 0.1067692021917959D-02 , 0.1600139347601747D-04 , - 0.1108382905937474D-06 , & 0.2969923365442521D-09 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.2742313239754624D-01 , - 0.1034368676851059D-02 , & 0.1535639472973076D-04 , - 0.1052896014072551D-06 , 0.2790921746478904D-09 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.2678493854149723D-01 , - 0.1001847981673990D-02 , 0.1473495078473457D-04 , & - 0.1000116516314360D-06 , 0.2622823383816462D-09 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.2615446602264478D-01 , & - 0.9701248685939948D-03 , 0.1413637342822979D-04 , - 0.9499185839514105D-07 , & 0.2464958250715784D-09 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.2553199211170737D-01 , - 0.9391932997869919D-03 , & 0.1355998201948082D-04 , - 0.9021817048638969D-07 , 0.2316697804191971D-09 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.2491777130973194D-01 , - 0.9090463420840087D-03 , 0.1300510449287343D-04 , & - 0.8567905046313655D-07 , 0.2177452400088034D-09 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.2431203593438913D-01 , & - 0.8796762388116702D-03 , 0.1247107824842953D-04 , - 0.8136345693876865D-07 , & 0.2046668870115603D-09 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.2371499673609565D-01 , - 0.8510744787596591D-03 , & 0.1195725093737966D-04 , - 0.7726082709046550D-07 , 0.1923828250665054D-09 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.2312684353941535D-01 , - 0.8232318622638089D-03 , 0.1146298115004334D-04 , & - 0.7336105943180373D-07 , 0.1808443653832212D-09 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.2254774590546569D-01 , & - 0.7961385644073436D-03 , 0.1098763901291800D-04 , - 0.6965449688487303D-07 , & 0.1700058271712196D-09 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.2197785381133559D-01 , - 0.7697841953554438D-03 , & 0.1053060670153713D-04 , - 0.6613191018169724D-07 , 0.1598243505577005D-09 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.2141729834278804D-01 , - 0.7441578578493366D-03 , 0.1009127887532325D-04 , & - 0.6278448161981318D-07 , 0.1502597212082998D-09 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.2086619239677932D-01 , & - 0.7192482018957587D-03 , 0.9669063040332120D-05 , - 0.5960378919242028D-07 , & 0.1412742059150259D-09 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.2032463139058698D-01 , - 0.6950434766963898D-03 , & 0.9263379845469729D-05 , - 0.5658179110956509D-07 , 0.1328323984621008D-09 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.1979269397457646D-01 , - 0.6715315798690306D-03 , 0.8873663317451548D-05 , & - 0.5371081072325781D-07 , 0.1249010751238880D-09 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.1927044274587886D-01 , & - 0.6487001040188183D-03 , 0.8499361039476552D-05 , - 0.5098352186626394D-07 , & 0.1174490591898836D-09 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.1875792496047608D-01 , - 0.6265363807231178D-03 , & 0.8139934278299078D-05 , - 0.4839293461149119D-07 , 0.1104470939498985D-09 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.1825517324140863D-01 , - 0.6050275219983323D-03 , 0.7794858064105367D-05 , & - 0.4593238145640506D-07 , 0.1038677236083589D-09 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.1776220628102802D-01 , & - 0.5841604593205184D-03 , 0.7463621227332106D-05 , - 0.4359550393467554D-07 , & 0.9768518163008756D-10 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.1727902953541458D-01 , - 0.5639219802748138D-03 , & 0.7145726396310886D-05 , - 0.4137623965532668D-07 , 0.9187528605135160D-10 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.1680563590927146D-01 , - 0.5442987629110553D-03 , 0.6840689959376891D-05 , & - 0.3926880976794438D-07 , 0.8641534131933667D-10 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.1634200642977723D-01 , & - 0.5252774078845328D-03 , 0.6548041994843817D-05 , - 0.3726770685098706D-07 , & 0.8128404625070160D-10 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.1588811090805824D-01 , - 0.5068444684623786D-03 , & 0.6267326172027997D-05 , - 0.3536768321896786D-07 , 0.7646140772571333D-10 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.1544390858709194D-01 , - 0.4889864784765317D-03 , 0.5998099626288122D-05 , & - 0.3356373964312695D-07 , 0.7192865975856094D-10 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.1500934877500435D-01 , & - 0.4716899783046181D-03 , 0.5739932810846141D-05 , - 0.3185111447925396D-07 , & 0.6766818760709470D-10 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.1458437146287044D-01 , - 0.4549415389601590D-03 , & 0.5492409327964799D-05 , - 0.3022527319550716D-07 , 0.6366345660645426D-10 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.1416890792624695D-01 , - 0.4387277843727677D-03 , 0.5255125741871169D-05 , & - 0.2868189829235777D-07 , 0.5989894543085606D-10 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.1376288130979977D-01 , & - 0.4230354119385741D-03 , 0.5027691375647091D-05 , - 0.2721687960623148D-07 , & 0.5636008350646053D-10 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.1336620719449552D-01 , - 0.4078512114199136D-03 , & 0.4809728094141844D-05 , - 0.2582630498792968D-07 , 0.5303319231563481D-10 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.1297879414693811D-01 , - 0.3931620822722544D-03 , 0.4600870074810522D-05 , & - 0.2450645134654312D-07 , 0.4990543034927696D-10 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.1260054425051967D-01 , & - 0.3789550494745810D-03 , 0.4400763568232383D-05 , - 0.2325377604925034D-07 , & 0.4696474147911759D-10 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.1223135361815979D-01 , - 0.3652172779383191D-03 , & 0.4209066649932432D-05 , - 0.2206490866720149D-07 , 0.4419980653631133D-10 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.1187111288647757D-01 , - 0.3519360855676958D-03 , 0.4025448964995328D-05 , & - 0.2093664305750031D-07 , 0.4159999789599341D-10 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.1151970769132142D-01 , & - 0.3390989550426959D-03 , 0.3849591466841497D-05 , - 0.1986592977120830D-07 , & 0.3915533688007789D-10 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.1117701912465797D-01 , - 0.3266935443940038D-03 , & 0.3681186151424045D-05 , - 0.1884986877725966D-07 , 0.3685645380238261D-10 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.1084292417287165D-01 , - 0.3147076964368123D-03 , 0.3519935787993206D-05 , & - 0.1788570249214610D-07 , 0.3469455049115225D-10 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.1051729613659682D-01 , & - 0.3031294471286796D-03 , 0.3365553647480197D-05 , - 0.1697080910529512D-07 , & 0.3266136513444916D-10 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.1020000503224879D-01 , - 0.2919470329141804D-03 , & 0.3217763229455734D-05 , - 0.1610269619012189D-07 , 0.3074913930354210D-10 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.9890917975472330D-02 , - 0.2811488971170844D-03 , 0.3076297988533527D-05 , & - 0.1527899459085136D-07 , 0.2895058701853062D-10 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.9589899546757860D-02 , & - 0.2707236954382152D-03 , 0.2940901061003058D-05 , - 0.1449745257531305D-07 , & 0.2725886572890657D-10 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.9296812139528999D-02 , - 0.2606603006154599D-03 , & 0.2811324992406657D-05 , - 0.1375593024410002D-07 , 0.2566754908979981D-10 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.9011516291022488D-02 , - 0.2509478062996567D-03 , 0.2687331466698786D-05 , & - 0.1305239418662126D-07 , 0.2417060142206153D-10 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.8733870996315160D-02 , & - 0.2415755301980460D-03 , 0.2568691037561805D-05 , - 0.1238491237477752D-07 , & 0.2276235375136604D-10 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.8463734005886733D-02 , - 0.2325330165350380D-03 , & 0.2455182862394038D-05 , - 0.1175164928520530D-07 , 0.2143748132809842D-10 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.8200962107109428D-02 , - 0.2238100378773175D-03 , 0.2346594439423017D-05 , & - 0.1115086124121571D-07 , 0.2019098253588659D-10 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.7945411390091679D-02 , & - 0.2153965963687142D-03 , 0.2242721348350031D-05 , - 0.1058089196580544D-07 , & 0.1901815910245418D-10 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.7696937498307168D-02 , - 0.2072829244178355D-03 , & 0.2143366994879685D-05 , - 0.1004016833732721D-07 , 0.1791459753183624D-10 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.7455395864459835D-02 , - 0.1994594848796509D-03 , 0.2048342359445954D-05 , & - 0.9527196339654385D-08 , 0.1687615168208614D-10 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.7220641932031320D-02 , & - 0.1919169707697666D-03 , 0.1957465750399437D-05 , - 0.9040557198885089D-08 , & 0.1589892641729746D-10 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.6992531362986212D-02 , - 0.1846463045488657D-03 , & 0.1870562561890135D-05 , - 0.8578903698910422D-08 , 0.1497926226728136D-10 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.6770920232094536D-02 , - 0.1776386370122433D-03 , 0.1787465036637480D-05 , & - 0.8140956668374378D-08 , 0.1411372103233905D-10 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.6555665208340470D-02 , & - 0.1708853458177508D-03 , 0.1708012033749628D-05 , - 0.7725501631807264D-08 , & 0.1329907227449830D-10 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.6346623723899249D-02 , - 0.1643780336839867D-03 , & 0.1632048801727517D-05 , - 0.7331385617967941D-08 , 0.1253228064026776D-10 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.6143654131138667D-02 , - 0.1581085262881716D-03 , 0.1559426756754978D-05 , & - 0.6957514118634594D-08 , 0.1181049396333411D-10 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.5946615848123139D-02 , & - 0.1520688698921259D-03 , 0.1490003266358152D-05 , - 0.6602848191350392D-08 , & 0.1113103209889815D-10 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.5755369493079834D-02 , - 0.1462513287227524D-03 , & 0.1423641438490601D-05 , - 0.6266401699842188D-08 , 0.1049137644432390D-10 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.5569777008293579D-02 , - 0.1406483821322047D-03 , 0.1360209916083194D-05 , & - 0.5947238686073481D-08 , 0.9889160103624990D-11 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.5389701773868699D-02 , & - 0.1352527215608308D-03 , 0.1299582677073196D-05 , - 0.5644470868089487D-08 , & 0.9322158655913628D-11 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.5215008711823402D-02 , - 0.1300572473254640D-03 , & 0.1241638839919165D-05 , - 0.5357255258072744D-08 , 0.8788281490488998D-11 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.5045564380942954D-02 , - 0.1250550652534278D-03 , 0.1186262474584658D-05 , & - 0.5084791895204131D-08 , 0.8285563673503055D-11 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.4881237062820976D-02 , & - 0.1202394831816189D-03 , 0.1133342418963165D-05 , - 0.4826321688148222D-08 , & 0.7812158313347277D-11 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.4721896839522524D-02 , - 0.1156040073391260D-03 , & 0.1082772100707799D-05 , - 0.4581124362200620D-08 , 0.7366329393971888D-11 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.4567415663262974D-02 , - 0.1111423386298724D-03 , 0.1034449364410692D-05 , & - 0.4348516506300345D-08 , 0.6946445047209644D-11 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.4417667418515524D-02 , & - 0.1068483688313757D-03 , 0.9882763040746968D-06 , - 0.4127849715335970D-08 , & 0.6550971237026659D-11 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.4272527976931500D-02 , - 0.1027161767241675D-03 , & 0.9441591008068174D-06 , - 0.3918508823341789D-08 , 0.6178465830273421D-11 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.4131875245461123D-02 , - 0.9874002416574091D-04 , 0.9020078656587292D-06 , & - 0.3719910223377208D-08 , 0.5827573030112507D-11 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.3995589208024615D-02 , & - 0.9491435212124788D-04 , 0.8617364875268283D-06 , - 0.3531500270031890D-08 , & 0.5497018149736219D-11 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.3863551961112762D-02 , - 0.9123377666324377D-04 , & 0.8232624860281768D-06 , - 0.3352753760710710D-08 , 0.5185602705441257D-11 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.3735647743645987D-02 , - 0.8769308495092870D-04 , 0.7865068692546482D-06 , & - 0.3183172491978324D-08 , 0.4892199809365540D-11 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.3611762961433191D-02 , & - 0.8428723119908692D-04 , 0.7513939963090588D-06 , - 0.3022283887426313D-08 , & 0.4615749843450633D-11 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.3491786206541154D-02 , - 0.8101133264566679D-04 , & 0.7178514445192996D-06 , - 0.2869639693661485D-08 , 0.4355256397308625D-11 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.3375608271907859D-02 , - 0.7786066552702524D-04 , 0.6858098812313211D-06 , & - 0.2724814741193739D-08 , 0.4109782453794053D-11 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.3263122161469210D-02 , & - 0.7483066106787520D-04 , 0.6552029400678246D-06 , - 0.2587405767096150D-08 , & 0.3878446807011328D-11 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.3154223096105129D-02 , - 0.7191690149347531D-04 , & 0.6259671015485930D-06 , - 0.2457030296492081D-08 , 0.3660420698500930D-11 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.3048808515681639D-02 , - 0.6911511607052425D-04 , 0.5980415779629545D-06 , & - 0.2333325580038870D-08 , 0.3454924658203928D-11 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.2946778077434166D-02 , & - 0.6642117718215527D-04 , 0.5713682023798755D-06 , - 0.2215947584688191D-08 , & 0.3261225537608523D-11 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.2848033650970881D-02 , - 0.6383109644292716D-04 , & 0.5458913216902640D-06 , - 0.2104570035163741D-08 , 0.3078633723318115D-11 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.2752479310120443D-02 , - 0.6134102085814833D-04 , 0.5215576935666792D-06 , & - 0.1998883503676767D-08 , 0.2906500519952177D-11 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.2660021321864737D-02 , & - 0.5894722903201521D-04 , 0.4983163872316179D-06 , - 0.1898594545535650D-08 , & 0.2744215692009992D-11 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.2570568132565718D-02 , - 0.5664612742809602D-04 , & 0.4761186879217537D-06 , - 0.1803424878396848D-08 , 0.2591205154942962D-11 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.2484030351723207D-02 , - 0.5443424668613394D-04 , 0.4549180049439450D-06 , & - 0.1713110603038070D-08 , 0.2446928806326739D-11 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.2400320733432425D-02 , & - 0.5230823799740073D-04 , 0.4346697832081424D-06 , - 0.1627401463588188D-08 , & 0.2310878488520660D-11 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.2319354155755488D-02 , - 0.5026486954172799D-04 , & 0.4153314181346706D-06 , - 0.1546060145287173D-08 , 0.2182576074795421D-11 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.2241047598177627D-02 , - 0.4830102298820862D-04 , 0.3968621738279278D-06 , & - 0.1468861607913849D-08 , 0.2061571671366443D-11 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.2165320117335987D-02 , & - 0.4641369006183038D-04 , 0.3792231044152124D-06 , - 0.1395592453126199D-08 , & 0.1947441928264338D-11 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.2092092821152724D-02 , - 0.4459996917693788D-04 , & 0.3623769784420723D-06 , - 0.1326050324008258D-08 , 0.1839788452360934D-11 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.2021288841567853D-02 , - 0.4285706213976358D-04 , 0.3462882062311850D-06 , & - 0.1260043335250040D-08 , 0.1738236316354218D-11 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.1952833305992351D-02 , & - 0.4118227092050809D-04 , 0.3309227701009476D-06 , - 0.1197389532414814D-08 , & 0.1642432657829551D-11 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.1886653307619345D-02 , - 0.3957299449578714D-04 , & 0.3162481573469376D-06 , - 0.1137916378840346D-08 , 0.1552045362902797D-11 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.1822677874750272D-02 , - 0.3802672576262212D-04 , 0.3022332958962535D-06 , & - 0.1081460268808053D-08 , 0.1466761829313070D-11 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.1760837939225054D-02 , & - 0.3654104852361968D-04 , 0.2888484925358682D-06 , - 0.1027866065639779D-08 , & 0.1386287804092357D-11 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.1701066304097097D-02 , - 0.3511363454409398D-04 , & 0.2760653736290859D-06 , - 0.9769866634857804D-09 , 0.1310346291293051D-11 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.1643297610650689D-02 , - 0.3374224068091438D-04 , 0.2638568282297854D-06 , & - 0.9286825716036678D-09 , 0.1238676525498767D-11 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.1587468304879443D-02 , & - 0.3242470608330222D-04 , 0.2521969535112702D-06 , - 0.8828215200040305D-09 , & 0.1171033007130328D-11 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.1533516603488456D-02 , - 0.3115894946459368D-04 , & 0.2410610024202071D-06 , - 0.8392780853627662D-09 , 0.1107184595761783D-11 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.1481382459552759D-02 , - 0.2994296644548057D-04 , 0.2304253334815615D-06 , & - 0.7979333362005920D-09 , 0.1046913657956753D-11 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.1431007527886470D-02 , & - 0.2877482696757296D-04 , 0.2202673626701604D-06 , - 0.7586744963351894D-09 , & 0.9900152662894250D-12 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.1382335130215954D-02 , - 0.2765267277697013D-04 , & 0.2105655172744651D-06 , - 0.7213946256873028D-09 , 0.9362964464552693D-12 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.1335310220211191D-02 , - 0.2657471497671821D-04 , 0.2012991916747204D-06 , & - 0.6859923175477321D-09 , 0.8855754695396882D-12 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.1289879348484534D-02 , & - 0.2553923164819788D-04 , 0.1924487049697489D-06 , - 0.6523714114906150D-09 , & 0.8376811867376259D-12 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.1245990627569024D-02 , - 0.2454456553948584D-04 , & 0.1839952603737301D-06 , - 0.6204407211066146D-09 , 0.7924524039137088D-12 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.1203593696971447D-02 , - 0.2358912182049391D-04 , 0.1759209063209048D-06 , & - 0.5901137758201131D-09 , 0.7497372936173746D-12 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.1162639688336998D-02 , & - 0.2267136590350338D-04 , 0.1682084992094517D-06 , - 0.5613085760610639D-09 , & 0.7093928422735046D-12 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.1123081190798806D-02 , - 0.2178982132849354D-04 , & 0.1608416677243711D-06 , - 0.5339473611205421D-09 , 0.6712843304369070D-12 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.1084872216509551D-02 , - 0.2094306771115024D-04 , 0.1538047786700414D-06 , & - 0.5079563890145656D-09 , 0.6352848440787844D-12 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.1047968165994606D-02 , & - 0.2012973874343839D-04 , 0.1470829041782728D-06 , - 0.4832657274643708D-09 , & 0.6012748146486304D-12 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.1012325796126580D-02 , - 0.1934852030635265D-04 , & 0.1406617907363108D-06 , - 0.4598090572497999D-09 , 0.5691415886845994D-12 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.9779031837212130D-03 , - 0.1859814853868921D-04 , 0.1345278286996714D-06 , & - 0.4375234826840363D-09 , 0.5387790188560061D-12 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.9446596942284392D-03 , & - 0.1787740806871503D-04 , 0.1286680239563200D-06 , - 0.4163493550009115D-09 , & 0.5100870835893575D-12 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.9125559484581843D-03 , - 0.1718513025096617D-04 , & 0.1230699703949070D-06 , - 0.3962301033883983D-09 , 0.4829715272470681D-12 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.8815537901718378D-03 , - 0.1652019146898049D-04 , 0.1177218236421554D-06 , & - 0.3771120750913242D-09 , 0.4573435221134869D-12 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.8516162541284116D-03 , & - 0.1588151149296760D-04 , 0.1126122759399375D-06 , - 0.3589443838299133D-09 , & 0.4331193504823090D-12 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.8227075346073859D-03 , - 0.1526805189113181D-04 , & 0.1077305321155342D-06 , - 0.3416787661049503D-09 , 0.4102201056362678D-12 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.7947929543814279D-03 , - 0.1467881449246852D-04 , 0.1030662865937871D-06 , & - 0.3252694449611813D-09 , 0.3885714105577853D-12 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.7678389342164628D-03 , & - 0.1411283990092661D-04 , 0.9860970141671637D-07 , - 0.3096730008512055D-09 , & 0.3681031533399083D-12 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.7418129628699391D-03 , - 0.1356920605879773D-04 , & 0.9435138522281845D-07 , - 0.2948482492126717D-09 , 0.3487492382706899D-12 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.7166835676203961D-03 , - 0.1304702685844852D-04 , 0.9028237314898859D-07 , & - 0.2807561244204209D-09 , 0.3304473516621536D-12 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.6924202853118777D-03 , & - 0.1254545080060450D-04 , 0.8639410761289621D-07 , - 0.2673595697715622D-09 , & 0.3131387415258316D-12 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.6689936339788000D-03 , - 0.1206365969899834D-04 , & 0.8267841994653403D-07 , - 0.2546234332150051D-09 , 0.2967680102946569D-12 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.6463750849866583D-03 , - 0.1160086742876242D-04 , 0.7912751283554949D-07 , & - 0.2425143684968464D-09 , 0.2812829197733921D-12 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.6245370357450520D-03 , & - 0.1115631871829207D-04 , 0.7573394353707949D-07 , - 0.2310007414619374D-09 , & 0.2666342076118409D-12 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.6034527829727443D-03 , - 0.1072928798288948D-04 , & 0.7249060783987837D-07 , - 0.2200525412335738D-09 , 0.2527754145997174D-12 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.5830964965488291D-03 , - 0.1031907819955901D-04 , 0.6939072473919849D-07 , & - 0.2096412960303449D-09 , 0.2396627221514466D-12 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.5634431938853902D-03 , & - 0.9925019820531820D-05 , 0.6642782178744041D-07 , - 0.1997399933525156D-09 , & 0.2272547993413844D-12 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.5444687149055163D-03 , - 0.9546469725895702D-05 , & 0.6359572110226128D-07 , - 0.1903230043436662D-09 , 0.2155126589585035D-12 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.5261496975667897D-03 , - 0.9182810213074055D-05 , 0.6088852599640105D-07 , & - 0.1813660120868539D-09 , 0.2043995220153166D-12 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.5084635539570933D-03 , & - 0.8833448022546329D-05 , 0.5830060820600604D-07 , - 0.1728459436414036D-09 , & 0.1938806902202071D-12 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.4913884469242239D-03 , - 0.8497813398042778D-05 , & 0.5582659568714920D-07 , - 0.1647409056118338D-09 , 0.1839234259233777D-12 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.4749032673125215D-03 , - 0.8175359181512084D-05 , 0.5346136096528906D-07 , & - 0.1570301230933205D-09 , 0.1744968391245183D-12 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.4589876117062344D-03 , & - 0.7865559940046149D-05 , 0.5120001000193604D-07 , - 0.1496938817819544D-09 , & 0.1655717810813850D-12 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.4436217607435082D-03 , - 0.7567911124964699D-05 , & 0.4903787156429153D-07 , - 0.1427134731099396D-09 , 0.1571207441560827D-12 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.4287866579630026D-03 , - 0.7281928261447561D-05 , 0.4697048707198105D-07 , & - 0.1360711422360242D-09 , 0.1491177675151813D-12 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.4144638892187044D-03 , & - 0.7007146168454491D-05 , 0.4499360090488294D-07 , - 0.1297500387567297D-09 , & 0.1415383483528319D-12 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.4006356625689913D-03 , - 0.6743118206404097D-05 , & 0.4310315114157245D-07 , - 0.1237341699657784D-09 , 0.1343593582751834D-12 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.3872847887436216D-03 , - 0.6489415553625583D-05 , 0.4129526072229901D-07 , & - 0.1180083565669337D-09 , 0.1275589645833550D-12 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.3743946621028193D-03 , & - 0.6245626509259776D-05 , 0.3956622900869825D-07 , - 0.1125581906850560D-09 , & 0.1211165561346853D-12 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.3619492421184048D-03 , - 0.6011355822371613D-05 , & 0.3791252372701724D-07 , - 0.1073699960680518D-09 , 0.1150126735257225D-12 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.3499330353219475D-03 , - 0.5786224045575291D-05 , 0.3633077327256089D-07 , & - 0.1024307903496915D-09 , 0.1092289433244438D-12 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.3383310777497743D-03 , & - 0.5569866913189017D-05 , 0.3481775936651245D-07 , - 0.9772824929198434D-10 , & 0.1037480161484116D-12 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.3271289181238959D-03 , - 0.5361934746112351D-05 , & 0.3337041005954440D-07 , - 0.9325067290013374D-10 , 0.9855350831711719D-13 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.3163126009099689D-03 , - 0.5162091871042827D-05 , 0.3198579301642391D-07 , & - 0.8898695324773149D-10 , 0.9362994689950073D-13 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.3058686504630511D-03 , & - 0.4970016070158945D-05 , 0.3066110914486294D-07 , - 0.8492654403375389D-10 , & 0.8896271794181530D-13 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.2957840553520472D-03 , - 0.4785398048070151D-05 , & 0.2939368649859369D-07 , - 0.8105943170387817D-10 , 0.8453801770643514D-13 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.2860462531251101D-03 , - 0.4607940918753883D-05 , 0.2818097445446998D-07 , & - 0.7737610805715038D-10 , 0.8034280670735029D-13 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.2766431155848397D-03 , & - 0.4437359713282053D-05 , 0.2702053816247912D-07 , - 0.7386754429747354D-10 , & 0.7636476642459698D-13 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.2675629344625789D-03 , - 0.4273380905909996D-05 , & 0.2591005324564928D-07 , - 0.7052516642369575D-10 , 0.7259225850738494D-13 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.2587944075305861D-03 , - 0.4115741958669481D-05 , 0.2484730074369338D-07 , & - 0.6734083190272347D-10 , 0.6901428633533087D-13 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.2503266250835322D-03 , & - 0.3964190882810890D-05 , 0.2383016228318565D-07 , - 0.6430680754113526D-10 , & 0.6562045878117630D-13 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.2421490569057510D-03 , - 0.3818485818570312D-05 , & 0.2285661547713540D-07 , - 0.6141574852919272D-10 , 0.6240095608451860D-13 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.2342515395559091D-03 , - 0.3678394629977375D-05 , 0.2192472952719040D-07 , & - 0.5866067855012922D-10 , 0.5934649766482010D-13 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.2266242640715435D-03 , & - 0.3543694515989344D-05 , 0.2103266103083658D-07 , - 0.5603497093134922D-10 , & 0.5644831179442593D-13 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.2192577640431490D-03 , - 0.3414171636632722D-05 , & 0.2017864997949125D-07 , - 0.5353233076876402D-10 , 0.5369810700700471D-13 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.2121429040770704D-03 , - 0.3289620754215300D-05 , 0.1936101594358130D-07 , & - 0.5114677798908748D-10 , 0.5108804515909145D-13 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.2052708685606547D-03 , & - 0.3169844887545166D-05 , 0.1857815442529822D-07 , - 0.4887263126706722D-10 , & 0.4861071600871051D-13 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.1986331508355445D-03 , - 0.3054654980770807D-05 , & 0.1782853338583830D-07 , - 0.4670449279682371D-10 , 0.4625911327239146D-13 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.1922215426896593D-03 , - 0.2943869584861952D-05 , 0.1711068992945047D-07 , & - 0.4463723384341279D-10 , 0.4402661204164650D-13 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.1860281241461607D-03 , & - 0.2837314551099053D-05 , 0.1642322713655238D-07 , - 0.4266598103326971D-10 , & 0.4190694748032208D-13 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.1800452536498920D-03 , - 0.2734822737845296D-05 , & 0.1576481104947716D-07 , - 0.4078610337270696D-10 , 0.3989419475638518D-13 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.1742655584972809D-03 , - 0.2636233727807246D-05 , 0.1513416779005809D-07 , & - 0.3899319991922771D-10 , 0.3798275009874998D-13 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.1686819256049794D-03 , & - 0.2541393557013349D-05 , 0.1453008081282862D-07 , - 0.3728308809795389D-10 , & 0.3616731294061359D-13 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.1632874925597235D-03 , - 0.2450154454297419D-05 , & 0.1395138828302928D-07 , - 0.3565179261715494D-10 , 0.3444286907388017D-13 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.1580756390016941D-03 , - 0.2362374591831807D-05 , 0.1339698057931404D-07 , & - 0.3409553496645486D-10 , 0.3280467477091201D-13 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.1530399782055187D-03 , & - 0.2277917844300961D-05 , 0.1286579790368867D-07 , - 0.3261072343628555D-10 , & 0.3124824178681129D-13 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.1481743490125434D-03 , - 0.2196653558881002D-05 , & 0.1235682800853209D-07 , - 0.3119394367038693D-10 , 0.2976932323007669D-13 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.1434728079913506D-03 , - 0.2118456333838977D-05 , 0.1186910402486596D-07 , & - 0.2984194969596446D-10 , 0.2836390022409188D-13 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.1389296218735127D-03 , & - 0.2043205806255172D-05 , 0.1140170239214537D-07 , - 0.2855165541954938D-10 , & 0.2702816932663197D-13 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.1345392601902856D-03 , - 0.1970786447491777D-05 , & 0.1095374087895237D-07 , - 0.2732012654885195D-10 , 0.2575853064862554D-13 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.1302963882441307D-03 , - 0.1901087368260625D-05 , 0.1052437670291136D-07 , & - 0.2614457295079384D-10 , 0.2455157666346348D-13 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.1261958602293583D-03 , & - 0.1834002130210752D-05 , 0.1011280472956622D-07 , - 0.2502234138238574D-10 , & 0.2340408162756550D-13 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.1222327126223194D-03 , - 0.1769428565701566D-05 , & 0.9718255757716268D-08 , - 0.2395090860385577D-10 , 0.2231299160514054D-13 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.1184021577739731D-03 , - 0.1707268604536657D-05 , 0.9339994882003417D-08 , & - 0.2292787484067918D-10 , 0.2127541504940078D-13 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.1146995777716464D-03 , & - 0.1647428108490787D-05 , 0.8977319935499706D-08 , - 0.2195095759243387D-10 , & 0.2028861392371315D-13 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.1111205184026066D-03 , - 0.1589816710956511D-05 , & 0.8629559995288605D-08 , - 0.2101798573685086D-10 , 0.1934999529964029D-13 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.1076606834429502D-03 , - 0.1534347664696969D-05 , 0.8296073965298025D-08 , & - 0.2012689395595655D-10 , 0.1845710344494068D-13 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.1043159290410721D-03 , & - 0.1480937694643845D-05 , 0.7976249219688875D-08 , - 0.1927571743765559D-10 , & 0.1760761234493368D-13 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.1010822583691088D-03 , - 0.1429506857410293D-05 , & 0.7669500311329228D-08 , - 0.1846258685246305D-10 , 0.1679931864581190D-13 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.9795581637041042D-04 , - 0.1379978405394649D-05 , 0.7375267734351643D-08 , & - 0.1768572357449344D-10 , 0.1603013498021306D-13 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.9493288480176733D-04 , & - 0.1332278658058050D-05 , 0.7093016752791553D-08 , - 0.1694343516884945D-10 , & 0.1529808368591658D-13 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.9200987734379080D-04 , - 0.1286336876906103D-05 , & 0.6822236274620316D-08 , - 0.1623411108788269D-10 , 0.1460129085428889D-13 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.8918333492764736D-04 , - 0.1242085146255928D-05 , 0.6562437781522619D-08 , & - 0.1555621859652627D-10 , 0.1393798071880463D-13 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.8644992120019322D-04 , & - 0.1199458258508712D-05 , 0.6313154306004863D-08 , - 0.1490829890035765D-10 , & 0.1330647035079959D-13 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.8380641821013028D-04 , - 0.1158393605019887D-05 , & 0.6073939460643492D-08 , - 0.1428896348307076D-10 , 0.1270516466086192D-13 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.8124972212469018D-04 , - 0.1118831069669795D-05 , 0.5844366502390325D-08 , & - 0.1369689060662099D-10 , 0.1213255165547785D-13 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.7877683920666239D-04 , & - 0.1080712928389318D-05 , 0.5624027448763510D-08 , - 0.1313082201078992D-10 , & 0.1158719797604407D-13 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.7638488187928374D-04 , - 0.1043983752013885D-05 , & 0.5412532230431799D-08 , - 0.1258955976985049D-10 , 0.1106774467481284D-13 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.7407106495351363D-04 , - 0.1008590313454966D-05 , 0.5209507884644803D-08 , & - 0.1207196331318601D-10 , 0.1057290322810498D-13 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.7183270191777468D-04 , & - 0.9744814976578833D-06 , 0.5014597780287607D-08 , - 0.1157694658375119D-10 , & 0.1010145175740971D-13 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.6966720148719659D-04 , - 0.9416082170852746D-06 , & 0.4827460888470710D-08 , - 0.1110347536423263D-10 , 0.9652231480071727D-14 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.6757206415305199D-04 , - 0.9099233289147326D-06 , 0.4647771077210796D-08 , & - 0.1065056471580329D-10 , 0.9224143334639857D-14 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.6554487891053012D-04 , & - 0.8793815564297200D-06 , 0.4475216442814933D-08 , - 0.1021727655665696D-10 , & 0.8816144800858870D-14 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.6358332007485253D-04 , - 0.8499394132362989D-06 , & 0.4309498669841072D-08 , - 0.9802717357746546D-11 , 0.8427246889517427D-14 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.6168514428510452D-04 , - 0.8215551316344686D-06 , 0.4150332425972834D-08 , & - 0.9406035967830365D-11 , 0.8056511308753484D-14 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.5984818747404679D-04 , & - 0.7941885919438675D-06 , 0.3997444774134835D-08 , - 0.9026421523266381D-11 , & 0.7703047763256539D-14 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.5807036207633595D-04 , - 0.7678012565610669D-06 , & 0.3850574621256523D-08 , - 0.8663101485910850D-11 , 0.7366011421285540D-14 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.5634965427424280D-04 , - 0.7423561058454390D-06 , 0.3709472187642756D-08 , & - 0.8315339768695846D-11 , 0.7044600510070389D-14 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.5468412137046121D-04 , & - 0.7178175770323110D-06 , 0.3573898502713283D-08 , - 0.7982434960189992D-11 , & 0.6738054046403772D-14 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.5307188917331695D-04 , - 0.6941515045204780D-06 , & 0.3443624917913711D-08 , - 0.7663718624527807D-11 , 0.6445649678670733D-14 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.5151114962616147D-04 , - 0.6713250646906164D-06 , 0.3318432652728044D-08 , & - 0.7358553711664032D-11 , 0.6166701667976021D-14 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.5000015838004112D-04 , & - 0.6493067210249445D-06 , 0.3198112351213792D-08 , - 0.7066333023482322D-11 , & 0.5900558958031566D-14 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.4853723251954841D-04 , - 0.6280661723897396D-06 , & 0.3082463663523244D-08 , - 0.6786477767580767D-11 , 0.5646603359116137D-14 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.4712074833862174D-04 , - 0.6075743030025233D-06 , 0.2971294844263169D-08 , & - 0.6518436178097135D-11 , 0.5404247825727855D-14 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.4574913928313971D-04 , & - 0.5878031356311147D-06 , 0.2864422375201478D-08 , - 0.6261682219094888D-11 , & 0.5172934839010844D-14 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.4442089380502899D-04 , - 0.5687257844986547D-06 , & 0.2761670593828998D-08 , - 0.6015714326689458D-11 , 0.4952134854182835D-14 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.4313455344530776D-04 , - 0.5503164121805278D-06 , 0.2662871349371718D-08 , & - 0.5780054237810048D-11 , 0.4741344852130460D-14 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.4188871091455480D-04 , & - 0.5325501872921948D-06 , 0.2567863669452816D-08 , - 0.5554245865778110D-11 , & 0.4540086959063122D-14 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.4068200827608391D-04 , - 0.5154032443602749D-06 , & 0.2476493444175709D-08 , - 0.5337854236828780D-11 , 0.4347907144576116D-14 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.3951313510121178D-04 , - 0.4988526440849924D-06 , 0.2388613118241915D-08 , & - 0.5130464465197714D-11 , 0.4164373977515554D-14 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.3838082686476667D-04 , & - 0.4828763375521401D-06 , 0.2304081408720776D-08 , - 0.4931680805162422D-11 , & 0.3989077470484586D-14 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.3728386323566779D-04 , - 0.4674531297298302D-06 , & 0.2222763024636403D-08 , - 0.4741125725345367D-11 , 0.3821627965301714D-14 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.3622106650539117D-04 , - 0.4525626454788745D-06 , 0.2144528404385478D-08 , & - 0.4558439040239326D-11 , 0.3661655087581408D-14 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.3519130003891518D-04 , & - 0.4381852964803418D-06 , 0.2069253462643011D-08 , - 0.4383277079254887D-11 , & 0.3508806752531036D-14 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.3419346687770855D-04 , - 0.4243022508122918D-06 , & 0.1996819355186700D-08 , - 0.4215311910991730D-11 , 0.3362748235442642D-14 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.3322650821114777D-04 , - 0.4108954013374928D-06 , 0.1927112242234319D-08 , & - 0.4054230578959144D-11 , 0.3223161269358192D-14 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.3228940207531695D-04 , & - 0.3979473376625807D-06 , 0.1860023073769909D-08 , - 0.3899734399793595D-11 , & 0.3089743211227693D-14 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.3138116201744105D-04 , - 0.3854413181659485D-06 , & 0.1795447379210543D-08 , - 0.3751538284142464D-11 , 0.2962206242421882D-14 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.3050083584703739D-04 , - 0.3733612436660448D-06 , 0.1733285068985074D-08 , & - 0.3609370096153946D-11 , 0.2840276615844313D-14 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.2964750432631616D-04 , & - 0.3616916307895618D-06 , 0.1673440238339730D-08 , - 0.3472970029766634D-11 , & 0.2723693930877295D-14 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.2882028010558941D-04 , - 0.3504175889833885D-06 , & 0.1615820992416349D-08 , - 0.3342090042510016D-11 , 0.2612210468548069D-14 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.2801830651212688D-04 , - 0.3395247960650218D-06 , 0.1560339267500242D-08 , & - 0.3216493291581783D-11 , 0.2505590540957108D-14 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.2724075647005681D-04 , & - 0.3289994758957649D-06 , 0.1506910665767516D-08 , - 0.3095953609299682D-11 , & 0.2403609884540361D-14 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.2648683141866701D-04 , - 0.3188283764389732D-06 , & 0.1455454294905668D-08 , - 0.2980254998641107D-11 , 0.2306055080720860D-14 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.2575576038241075D-04 , - 0.3089987501443033D-06 , 0.1405892621780237D-08 , & - 0.2869191167967235D-11 , 0.2212723018634383D-14 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.2504679886493467D-04 , & - 0.2994983324551385D-06 , 0.1358151319819926D-08 , - 0.2762565060937548D-11 , & 0.2123420363922377D-14 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.2435922797983250D-04 , - 0.2903153236942786D-06 , & 0.1312159135219103D-08 , - 0.2660188434832063D-11 , 0.2037963075781255D-14 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.2369235352039857D-04 , - 0.2814383705055010D-06 , 0.1267847753453442D-08 , & - 0.2561881447204678D-11 , 0.1956175939455107D-14 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.2304550510634917D-04 , & - 0.2728565485932162D-06 , 0.1225151674327891D-08 , - 0.2467472267975714D-11 , & 0.1877892127360741D-14 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.2241803524249234D-04 , - 0.2645593446674501D-06 , & 0.1184008085529396D-08 , - 0.2376796695404761D-11 , 0.1802952771251885D-14 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.2180931863358797D-04 , - 0.2565366419065540D-06 , 0.1144356754945012D-08 , & - 0.2289697818195832D-11 , 0.1731206578361869D-14 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.2121875131589301D-04 , & - 0.2487787033959722D-06 , 0.1106139915433119D-08 , - 0.2206025667944848D-11 , & 0.1662509446917008D-14 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.2064574991825671D-04 , - 0.2412761574663261D-06 , & 0.1069302160500069D-08 , - 0.2125636900458190D-11 , 0.1596724111103423D-14 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.2008975090437373D-04 , - 0.2340199830562545D-06 , 0.1033790341940344D-08 , & - 0.2048394486820841D-11 , 0.1533719799988082D-14 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.1955020996815892D-04 , & - 0.2270014972190577D-06 , 0.9995534792169165D-09 , - 0.1974167434184789D-11 , & 0.1473371925585177D-14 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.1902660121665307D-04 , - 0.2202123402363646D-06 , & 0.9665426593826390D-09 , - 0.1902830492043426D-11 , 0.1415561765261247D-14 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.1851841660242252D-04 , - 0.2136444640483382D-06 , 0.9347109540333602D-09 , & - 0.1834263898633018D-11 , 0.1360176180711448D-14 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.1802516527300374D-04 , & - 0.2072901198709401D-06 , 0.9040133339791495D-09 , - 0.1768353127128639D-11 , & 0.1307107341750534D-14 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.1754637299206113D-04 , - 0.2011418469007669D-06 , & 0.8744065903812564D-09 , - 0.1704988649475106D-11 , 0.1256252468486265D-14 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.1708158144926572D-04 , - 0.1951924598638294D-06 , 0.8458492519849518D-09 , & - 0.1644065696415630D-11 , 0.1207513575125535D-14 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.1663034784205899D-04 , & - 0.1894350400696281D-06 , 0.8183015197341632D-09 , - 0.1585484056924994D-11 , & 0.1160797248271859D-14 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.1619224424095819D-04 , - 0.1838629240056016D-06 , & 0.7917251913558802D-09 , - 0.1529147860860474D-11 , 0.1116014416355298D-14 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.1576685708695001D-04 , - 0.1784696937162820D-06 , 0.7660835953156627D-09 , & - 0.1474965384255535D-11 , 0.1073080140215376D-14 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.1535378668578167D-04 , & - 0.1732491673129855D-06 , 0.7413415265064054D-09 , - 0.1422848861466617D-11 , & 0.1031913412488736D-14 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.1495264668468862D-04 , - 0.1681953894104300D-06 , & 0.7174651826356846D-09 , - 0.1372714301878396D-11 , 0.9924369638977152D-15 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.1456306374296516D-04 , - 0.1633026240970651D-06 , 0.6944221132350154D-09 , & - 0.1324481335128755D-11 , 0.9545770942652151D-15 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.1418467688231717D-04 , & - 0.1585653441359173D-06 , 0.6721811524473013D-09 , - 0.1278073026451035D-11 , & 0.9182634840915419D-15 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.1381713717500758D-04 , - 0.1539782244126680D-06 , & 0.6507123720613552D-09 , - 0.1233415735527220D-11 , 0.8834290417996622D-15 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.1346010729439725D-04 , - 0.1495361338422976D-06 , 0.6299870284164455D-09 , & - 0.1190438965533304D-11 , 0.8500097462960800D-15 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.1311326115169045D-04 , & - 0.1452341284312207D-06 , 0.6099775153307352D-09 , - 0.1149075226635474D-11 , & 0.8179445029209431D-15 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.1277628335224570D-04 , - 0.1410674423344361D-06 , & 0.5906573089662685D-09 , - 0.1109259885935237D-11 , 0.7871749918327763D-15 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.1244886903306818D-04 , - 0.1370314835285374D-06 , 0.5720009339423039D-09 , & - 0.1070931061606397D-11 , 0.7576455515133800D-15 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.1213072336664512D-04 , & - 0.1331218256569396D-06 , 0.5539839132039758D-09 , - 0.1034029487040411D-11 , & 0.7293030422036727D-15 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.1182156124277184D-04 , - 0.1293342020831922D-06 , & 0.5365827283939103D-09 , - 0.9984983977442489D-12 , 0.7020967283021001D-15 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.1152110688779969D-04 , - 0.1256644993171815D-06 , 0.5197747781429093D-09 , & - 0.9642834160784029D-12 , 0.6759781611562802D-15 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.1122909369987476D-04 , & - 0.1221087530486415D-06 , 0.5035383483966596D-09 , - 0.9313324612351205D-12 , & 0.6509010821876711D-15 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.1094526371227626D-04 , - 0.1186631399510534D-06 , & 0.4878525648739278D-09 , - 0.8995956261750852D-12 , 0.6268213036412119D-15 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.1066936743078117D-04 , - 0.1153239739274105D-06 , 0.4726973655312067D-09 , & - 0.8690250951548329D-12 , 0.6036966207017170D-15 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.1040116350959386D-04 , & - 0.1120877005623688D-06 , 0.4580534657351854D-09 , - 0.8395750485945694D-12 , & 0.5814867159227894D-15 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.1014041851593009D-04 , - 0.1089508926795572D-06 , & 0.4439023287589332D-09 , - 0.8112015797073168D-12 , 0.5601530736971550D-15 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.9886906492411596D-05 , - 0.1059102436622579D-06 , 0.4302261271629789D-09 , & - 0.7838625950807508D-12 , 0.5396588846189908D-15 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.9640408928834584D-05 , & - 0.1029625655431835D-06 , 0.4170077252073619D-09 , - 0.7575177569456387D-12 , & 0.5199689812453925D-15 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.9400714365092418D-05 , - 0.1001047829360209D-06 , & 0.4042306438041303D-09 , - 0.7321283932102043D-12 , 0.5010497519021456D-15 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.9167618182713930D-05 , - 0.9733392920051160D-07 , 0.3918790355398908D-09 , & - 0.7076574280333663D-12 , 0.4828690705116748D-15 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.8940922323643781D-05 , & - 0.9464714184722641D-07 , 0.3799376568741170D-09 , - 0.6840693081849675D-12 , & 0.4653962245712175D-15 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.8720435238065426D-05 , - 0.9204166059395591D-07 , & 0.3683918519986259D-09 , - 0.6613299525537584D-12 , 0.4486018606722104D-15 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.8505971424540388D-05 , - 0.8951482087540052D-07 , 0.3572275177739014D-09 , & - 0.6394066669230474D-12 , 0.4324579063944318D-15 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.8297351371329590D-05 , & - 0.8706405194832627D-07 , 0.3464310885593549D-09 , - 0.6182680973785393D-12 , & 0.4169375206402067D-15 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.8094401318264093D-05 , - 0.8468687302215876D-07 , & 0.3359895129978272D-09 , - 0.5978841694266092D-12 , 0.4020150347364139D-15 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.7896953110384875D-05 , - 0.8238089047228784D-07 , 0.3258902356970683D-09 , & - 0.5782260372025814D-12 , 0.3876659015375127D-15 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.7704843829467639D-05 , & - 0.8014379263108883D-07 , 0.3161211690965183D-09 , - 0.5592660152582186D-12 , & 0.3738666331885573D-15 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.7517915863767644D-05 , - 0.7797334951313005D-07 , & 0.3066706863048566D-09 , - 0.5409775502715884D-12 , 0.3605947676521263D-15 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.7336016575688469D-05 , - 0.7586740810358321D-07 , 0.2975275956386532D-09 , & - 0.5233351593965135D-12 , 0.3478288126166716D-15 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.7158998169753011D-05 , & - 0.7382388992657340D-07 , 0.2886811249955628D-09 , - 0.5063143877025780D-12 , & 0.3355482035029539D-15 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.6986717478846942D-05 , - 0.7184078775357685D-07 , & 0.2801209029227634D-09 , - 0.4898917602113560D-12 , 0.3237332584034301D-15 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.6819035993461892D-05 , - 0.6991616502384730D-07 , 0.2718369511376643D-09 , & - 0.4740447556589703D-12 , 0.3123651486761316D-15 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.6655819449357352D-05 , & - 0.6804815045013698D-07 , 0.2638196574062440D-09 , - 0.4587517447818742D-12 , & 0.3014258456555711D-15 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.6496937843905278D-05 , - 0.6623493737815568D-07 , & 0.2560597682988689D-09 , - 0.4439919657833755D-12 , 0.2908980936422247D-15 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.6342265256386746D-05 , - 0.6447478102509115D-07 , 0.2485483733980302D-09 , & - 0.4297454846426698D-12 , 0.2807653729646736D-15 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.6191679764007334D-05 , & - 0.6276599679745238D-07 , 0.2412768941420882D-09 , - 0.4159931644378059D-12 , & 0.2710118697496803D-15 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.6045063117390941D-05 , - 0.6110695603587335D-07 , & 0.2342370623965412D-09 , - 0.4027166165800772D-12 , 0.2616224338848606D-15 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.5902300883094216D-05 , - 0.5949608685774940D-07 , 0.2274209199916031D-09 , & - 0.3898981905849496D-12 , 0.2525825637150077D-15 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.5763282152648896D-05 , & - 0.5793187032708606D-07 , 0.2208207993960037D-09 , - 0.3775209300867115D-12 , & 0.2438783681820300D-15 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.5627899464038989D-05 , - 0.5641283896023783D-07 , & 0.2144293140938581D-09 , - 0.3655685469241299D-12 , 0.2354965417154741D-15 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.5496048633541327D-05 , - 0.5493757429578466D-07 , 0.2082393453485555D-09 , & - 0.3540253891608909D-12 , 0.2274243354343713D-15 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.4000000000000289D-01 , - 0.2723579674818180D-02 , 0.9323515690125071D-04 , & - 0.2138115234912704D-05 , 0.3692465124516921D-07 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.3999999965861972D-01 , & - 0.2723577709569633D-02 , 0.9323075693891723D-04 , - 0.2133224127814659D-05 , & 0.3445150531475582D-07 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.3999998653307547D-01 , - 0.2723544752111465D-02 , & 0.9319912309497638D-04 , - 0.2119433657504785D-05 , 0.3214451582036760D-07 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.3999989902020370D-01 , - 0.2723407789743436D-02 , 0.9311810943184775D-04 , & - 0.2097961387574837D-05 , 0.2999248885922570D-07 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.3999959200900610D-01 , & - 0.2723060758341065D-02 , 0.9297040058664796D-04 , - 0.2069901121881744D-05 , & 0.2798498653560954D-07 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.3999881604059793D-01 , - 0.2722375425856280D-02 , & 0.9274284454147186D-04 , - 0.2036234080681377D-05 , 0.2611227578683662D-07 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.3999720740181607D-01 , - 0.2721210330059975D-02 , 0.9242586140940619D-04 , & - 0.1997839129567439D-05 , 0.2436528068032906D-07 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.3999428667269870D-01 , & - 0.2719418040943633D-02 , 0.9201292046328515D-04 , - 0.1955502138393925D-05 , & 0.2273553794588316D-07 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.3998946366027236D-01 , - 0.2716850985627548D-02 , & 0.9150007837573948D-04 , - 0.1909924541236237D-05 , 0.2121515552331614D-07 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.3998204700575579D-01 , - 0.2713366044626715D-02 , 0.9088557231322511D-04 , & - 0.1861731162799261D-05 , 0.1979677392062675D-07 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.3997125705658065D-01 , & - 0.2708828102535189D-02 , 0.9016946213935890D-04 , - 0.1811477371474071D-05 , & 0.1847353019174862D-07 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.3995624085487905D-01 , - 0.2703112713274572D-02 , & 0.8935331653944632D-04 , - 0.1759655614444614D-05 , 0.1723902435597054D-07 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.3993608831591148D-01 , - 0.2696108019713549D-02 , 0.8843993838349763D-04 , & - 0.1706701385820042D-05 , 0.1608728809319540D-07 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.3990984885825913D-01 , & - 0.2687716049434000D-02 , 0.8743312510383810D-04 , - 0.1652998674689710D-05 , & 0.1501275556050610D-07 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.3987654790685858D-01 , - 0.2677853492452593D-02 , & 0.8633746027972639D-04 , - 0.1598884936237643D-05 , 0.1401023618600445D-07 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.3983520282396553D-01 , - 0.2666452052586476D-02 , 0.8515813299901206D-04 , & - 0.1544655625588791D-05 , 0.1307488930569449D-07 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.3978483793529294D-01 , & - 0.2653458451681282D-02 , 0.8390078190922056D-04 , - 0.1490568330866628D-05 , & 0.1220220051830782D-07 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.3972449841185999D-01 , - 0.2638834154922173D-02 , & 0.8257136118071180D-04 , - 0.1436846539000039D-05 , 0.1138795964147593D-07 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.3965326284512942D-01 , - 0.2622554875765102D-02 , 0.8117602588559927D-04 , & - 0.1383683065107587D-05 , 0.1062824016058207D-07 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.3957025441610022D-01 , & - 0.2604609910513026D-02 , 0.7972103455056490D-04 , - 0.1331243173791064D-05 , & 0.9919380069013247D-08 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.3947465061016632D-01 , - 0.2585001345092043D-02 , & 0.7821266687196691D-04 , - 0.1279667418371232D-05 , 0.9257964005417161D-08 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.3936569147050975D-01 , - 0.2563743170040269D-02 , 0.7665715478990219D-04 , & - 0.1229074221981594D-05 , 0.8640806599985063D-08 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.3924268641509779D-01 , & - 0.2540860334004213D-02 , 0.7506062530615300D-04 , - 0.1179562222486627D-05 , & 0.8064936947760248D-08 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.3910501966733181D-01 , - 0.2516387761051092D-02 , & 0.7342905360104159D-04 , - 0.1131212401396306D-05 , 0.7527584132544109D-08 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.3895215436921190D-01 , - 0.2490369352767702D-02 , 0.7176822515780535D-04 , & - 0.1084090015296717D-05 , 0.7026163730164228D-08 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.3878363545953706D-01 , & - 0.2462856992353070D-02 , 0.7008370574169871D-04 , - 0.1038246346796136D-05 , & 0.6558265224708370D-08 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.3859909140902761D-01 , - 0.2433909564656561D-02 , & 0.6838081820601766D-04 , - 0.9937202905867453D-06 , 0.6121640275838146D-08 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.3839823491008230D-01 , - 0.2403592003306154D-02 , 0.6666462520988257D-04 , & - 0.9505397889348034D-06 , 0.5714191779499268D-08 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.3818086262181306D-01 , & - 0.2371974373660082D-02 , 0.6493991703405736D-04 , - 0.9087231297277288D-06 , & 0.5333963668262345D-08 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.3794685407158700D-01 , - 0.2339130998251701D-02 , & 0.6321120377237219D-04 , - 0.8682801191172196D-06 , 0.4979131401178934D-08 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.3769616981302226D-01 , - 0.2305139629640136D-02 , 0.6148271125840611D-04 , & - 0.8292131397956913D-06 , 0.4647993096439798D-08 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.3742884893763166D-01 , & - 0.2270080674090278D-02 , 0.5975838016084262D-04 , - 0.7915181050221318D-06 , & 0.4338961263293308D-08 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.3714500603342838D-01 , - 0.2234036468251786D-02 , & 0.5804186774712217D-04 , - 0.7551853176665998D-06 , 0.4050555092637197D-08 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.3684482767908664D-01 , - 0.2197090609958045D-02 , 0.5633655187440339D-04 , & - 0.7202002427641627D-06 , 0.3781393268451236D-08 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.3652856855693060D-01 , & - 0.2159327343396203D-02 , 0.5464553682005531D-04 , - 0.6865442013536922D-06 , & 0.3530187264805481D-08 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.3619654726230474D-01 , - 0.2120830998185131D-02 , & 0.5297166061153732D-04 , - 0.6541949927196359D-06 , 0.3295735095571328D-08 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.3584914188092705D-01 , - 0.2081685481318523D-02 , 0.5131750355811331D-04 , & - 0.6231274515510315D-06 , 0.3076915486192579D-08 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.3548678539977905D-01 , & - 0.2041973820467447D-02 , 0.4968539772489323D-04 , - 0.5933139459774901D-06 , & 0.2872682438952088D-08 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.3510996101104457D-01 , - 0.2001777756773249D-02 , & 0.4807743712361466D-04 , - 0.5647248219324480D-06 , 0.2682060165106771D-08 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.3471919736268635D-01 , - 0.1961177384985758D-02 , 0.4649548842483586D-04 , & - 0.5373287988266921D-06 , 0.2504138359069287D-08 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.3431506380347528D-01 , & - 0.1920250838597333D-02 , 0.4494120202308229D-04 , - 0.5110933210857558D-06 , & 0.2338067791497562D-08 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.3389816566475556D-01 , - 0.1879074017482811D-02 , & 0.4341602331039877D-04 , - 0.4859848697111307D-06 , 0.2183056199721952D-08 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.3346913961595232D-01 , - 0.1837720355466778D-02 , 0.4192120403494457D-04 , & - 0.4619692376638762D-06 , 0.2038364455401818D-08 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.3302864912584710D-01 , & - 0.1796260625195433D-02 , 0.4045781364003228D-04 , - 0.4390117725378291D-06 , & 0.1903302990666057D-08 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.3257738005697713D-01 , - 0.1754762777682942D-02 , & 0.3902675049559128D-04 , - 0.4170775896857304D-06 , 0.1777228465262365D-08 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.3211603641616642D-01 , - 0.1713291813925050D-02 , 0.3762875294865797D-04 , & - 0.3961317586829950D-06 , 0.1659540658423928D-08 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.3164533628017795D-01 , & - 0.1671909686020495D-02 , 0.3626441013236229D-04 , - 0.3761394657585348D-06 , & 0.1549679570265913D-08 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.3116600791178098D-01 , - 0.1630675225308218D-02 , & 0.3493417248417229D-04 , - 0.3570661545880915D-06 , 0.1447122718552734D-08 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.3067878607815710D-01 , - 0.1589644095111725D-02 , 0.3363836193404649D-04 , & - 0.3388776476312643D-06 , 0.1351382617636044D-08 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.3018440858050785D-01 , & - 0.1548868765777162D-02 , 0.3237718173177196D-04 , - 0.3215402499971842D-06 , & 0.1262004427257147D-08 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.2968361300096932D-01 , - 0.1508398509796026D-02 , & 0.3115072589027268D-04 , - 0.3050208376441596D-06 , 0.1178563759740710D-08 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.2917713367047092D-01 , - 0.1468279414914096D-02 , 0.2995898822817886D-04 , & - 0.2892869315542483D-06 , 0.1100664634883340D-08 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.2866569885897930D-01 , & - 0.1428554413242827D-02 , 0.2880187100056169D-04 , - 0.2743067593733091D-06 , & 0.1027937572564485D-08 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.2815002818763353D-01 , - 0.1389263324506557D-02 , & 0.2767919311156121D-04 , - 0.2600493058695886D-06 , 0.9600378137820711D-09 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.2763083026058270D-01 , - 0.1350442911676350D-02 , 0.2659069790675312D-04 , & - 0.2464843534381546D-06 , 0.8966436614443100D-09 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.2710880051287072D-01 , & - 0.1312126947358390D-02 , 0.2553606054659784D-04 , - 0.2335825137636224D-06 , & 0.8374549328356275D-09 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.2658461926945450D-01 , - 0.1274346289419924D-02 , & 0.2451489496525881D-04 , - 0.2213152516486612D-06 , 0.7821915162213117D-09 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.2605895000937692D-01 , - 0.1237128964448419D-02 , 0.2352676042153594D-04 , & - 0.2096549019199456D-06 , 0.7305920245651175D-09 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.2553243782823093D-01 , & - 0.1200500257748877D-02 , 0.2257116765069076D-04 , - 0.1985746802357662D-06 , & 0.6824125398092000D-09 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.2500570809132388D-01 , - 0.1164482808689609D-02 , & 0.2164758462759179D-04 , - 0.1880486885397080D-06 , 0.6374254416085813D-09 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.2447936526937606D-01 , - 0.1129096710308008D-02 , 0.2075544195293348D-04 , & - 0.1780519158320598D-06 , 0.5954183148253045D-09 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.2395399194814197D-01 , & - 0.1094359612184384D-02 , 0.1989413787531643D-04 , - 0.1685602348643000D-06 , & 0.5561929304723283D-09 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.2343014800302044D-01 , - 0.1060286825683798D-02 , & 0.1906304296276053D-04 , - 0.1595503953015848D-06 , 0.5195642951560366D-09 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.2290836992949589D-01 , - 0.1026891430752541D-02 , 0.1826150443778806D-04 , & - 0.1510000138431796D-06 , 0.4853597644008326D-09 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.2238917032014227D-01 , & - 0.9941843835382152D-03 , 0.1748885019059273D-04 , - 0.1428875617407043D-06 , & 0.4534182155511222D-09 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.2187303747887119D-01 , - 0.9621746241789904D-03 , & 0.1674439248502451D-04 , - 0.1351923501085628D-06 , 0.4235892762368116D-09 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.2136043516314749D-01 , - 0.9308691841798922D-03 , 0.1602743137219678D-04 , & - 0.1278945133795404D-06 , 0.3957326046594811D-09 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.2085180244499332D-01 , & - 0.9002732928612050D-03 , 0.1533725782648183D-04 , - 0.1209749912209887D-06 , & 0.3697172182091832D-09 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.2034755368175619D-01 , - 0.8703904824266177D-03 , & 0.1467315661851920D-04 , - 0.1144155091929088D-06 , 0.3454208671574203D-09 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.1984807858781704D-01 , - 0.8412226912567051D-03 , 0.1403440893963624D-04 , & - 0.1081985583983003D-06 , 0.3227294503915390D-09 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.1935374239865732D-01 , & - 0.8127703650870149D-03 , 0.1342029479178827D-04 , - 0.1023073743481232D-06 , & 0.3015364703606367D-09 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.1886488611897612D-01 , - 0.7850325557793307D-03 , & 0.1283009515677439D-04 , - 0.9672591523781869D-07 , 0.2817425245940138D-09 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.1838182684684910D-01 , - 0.7580070174400389D-03 , 0.1226309395808945D-04 , & - 0.9143883980936345D-07 , 0.2632548313312624D-09 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.1790485816624472D-01 , & - 0.7316902996811184D-03 , 0.1171857982834329D-04 , - 0.8643148495208065D-07 , & 0.2459867869691274D-09 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.1743425060054748D-01 , - 0.7060778378569886D-03 , & 0.1119584769471684D-04 , - 0.8168984317665554D-07 , 0.2298575531850054D-09 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.1697025212009050D-01 , - 0.6811640401450211D-03 , 0.1069420019444859D-04 , & - 0.7720054007990495D-07 , 0.2147916717413222D-09 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.1651308869705630D-01 , & - 0.6569423713686654D-03 , 0.1021294893185218D-04 , - 0.7295081190259794D-07 , & 0.2007187051095772D-09 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.1606296490146376D-01 , - 0.6334054334902059D-03 , & 0.9751415587863561D-05 , - 0.6892848326889249D-07 , 0.1875729011782896D-09 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.1562006453232611D-01 , - 0.6105450427256437D-03 , 0.9308932892615901D-05 , & - 0.6512194518363847D-07 , 0.1752928804261312D-09 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.1518455127842219D-01 , & - 0.5883523032566830D-03 , 0.8884845471033904D-05 , - 0.6152013335270514D-07 , & 0.1638213440505679D-09 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.1475656940348111D-01 , - 0.5668176775350147D-03 , & 0.8478510570941065D-05 , - 0.5811250688157021D-07 , 0.1531048016440646D-09 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.1433624445093486D-01 , - 0.5459310531920777D-03 , 0.8089298682682364D-05 , & - 0.5488902739853741D-07 , 0.1430933171047951D-09 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.1392368396373141D-01 , & - 0.5256818065830112D-03 , 0.7716594058778468D-05 , - 0.5184013864099040D-07 , & 0.1337402715571732D-09 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.1351897821504143D-01 , - 0.5060588630074893D-03 , & 0.7359795141658118D-05 , - 0.4895674653603500D-07 , 0.1250021421400561D-09 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.1312220094601188D-01 , - 0.4870507536620237D-03 , 0.7018314907055289D-05 , & - 0.4623019980058008D-07 , 0.1168382955973540D-09 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.1273341010703471D-01 , & - 0.4686456693885530D-03 , 0.6691581130210247D-05 , - 0.4365227108030430D-07 , & 0.1092107956774637D-09 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.1235264859930177D-01 , - 0.4508315112931141D-03 , & 0.6379036581586829D-05 , - 0.4121513864203024D-07 , 0.1020842234148804D-09 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.1197994501370264D-01 , - 0.4335959383155971D-03 , 0.6080139158400150D-05 , & - 0.3891136862963413D-07 , 0.9542550942964582D-10 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.1161531436439942D-01 , & - 0.4169264118377700D-03 , 0.5794361957851346D-05 , - 0.3673389788977751D-07 , & 0.8920377743846210D-10 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.1125875881467826D-01 , - 0.4008102374218713D-03 , & 0.5521193297585815D-05 , - 0.3467601737038422D-07 , 0.8339019822556621D-10 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.1091026839292024D-01 , - 0.3852346037757364D-03 , 0.5260136688522150D-05 , & - 0.3273135609181081D-07 , 0.7795785337196714D-10 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.1056982169677599D-01 , & - 0.3701866190436615D-03 , 0.5010710764853812D-05 , - 0.3089386568811565D-07 , & 0.7288160808887215D-10 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.1023738658384992D-01 , - 0.3556533445242850D-03 , & 0.4772449175692417D-05 , - 0.2915780551360408D-07 , 0.6813799254509135D-10 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.9912920847404270D-02 , - 0.3416218259180029D-03 , 0.4544900442503853D-05 , & - 0.2751772830790462D-07 , 0.6370509111919962D-10 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.9596372875798393D-02 , & - 0.3280791222074557D-03 , 0.4327627786193062D-05 , - 0.2596846641122538D-07 , & 0.5956243904555033D-10 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.9287682294554424D-02 , - 0.3150123322744569D-03 , & 0.4120208927405962D-05 , - 0.2450511852003496D-07 , 0.5569092595885507D-10 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.8986780590114186D-02 , - 0.3024086193564153D-03 , 0.3922235863350005D-05 , & - 0.2312303697226218D-07 , 0.5207270587533607D-10 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.8693591714515690D-02 , & - 0.2902552334445722D-03 , 0.3733314624183720D-05 , - 0.2181781555016292D-07 , & 0.4869111317951754D-10 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.8408032670356181D-02 , - 0.2785395317247791D-03 , & 0.3553065011782756D-05 , - 0.2058527778819660D-07 , 0.4553058421460479D-10 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.8130014075553334D-02 , - 0.2672489971601991D-03 , 0.3381120323469302D-05 , & - 0.1942146577265735D-07 , 0.4257658410144961D-10 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.7859440707537687D-02 , & - 0.2563712553132191D-03 , 0.3217127063078355D-05 , - 0.1832262941930884D-07 , & 0.3981553843624006D-10 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.7596212026624484D-02 , - 0.2458940895017223D-03 , & 0.3060744641537454D-05 , - 0.1728521621492522D-07 , 0.3723476954056422D-10 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.7340222678418384D-02 , - 0.2358054543823477D-03 , 0.2911645068948353D-05 , & - 0.1630586140837352D-07 , 0.3482243695934006D-10 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.7091362975203385D-02 , & - 0.2260934880510038D-03 , 0.2769512639989474D-05 , - 0.1538137863675400D-07 , & 0.3256748192261785D-10 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.6849519356353029D-02 , - 0.2167465227479303D-03 , & 0.2634043614291439D-05 , - 0.1450875097201931D-07 , 0.3045957550623454D-10 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.6614574827874175D-02 , - 0.2077530942517908D-03 , 0.2504945893287307D-05 , & - 0.1368512237351112D-07 , 0.2848907024409858D-10 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.6386409381277542D-02 , & - 0.1991019500446386D-03 , 0.2381938694901233D-05 , - 0.1290778953194323D-07 , & 0.2664695496149620D-10 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.6164900392014875D-02 , - 0.1907820563260668D-03 , & 0.2264752227300995D-05 , - 0.1217419409045167D-07 , 0.2492481261419276D-10 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.5949922997793506D-02 , - 0.1827826039523078D-03 , 0.2153127362823544D-05 , & - 0.1148191522854241D-07 , 0.2331478093259777D-10 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.5741350457123815D-02 , & - 0.1750930133728342D-03 , 0.2046815313067009D-05 , - 0.1082866259497211D-07 , & 0.2180951568368837D-10 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.5539054488489747D-02 , - 0.1677029386336913D-03 , & 0.1945577306034147D-05 , - 0.1021226957583197D-07 , 0.2040215637590079D-10 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.5342905590587189D-02 , - 0.1606022705142854D-03 , 0.1849184266121062D-05 , & - 0.9630686884419901D-08 , 0.1908629424397657D-10 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.5152773344091390D-02 , & - 0.1537811388608381D-03 , 0.1757416497648892D-05 , - 0.9081976459757927D-08 , & 0.1785594236160184D-10 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.4968526695446833D-02 , - 0.1472299141769049D-03 , & 0.1670063372554863D-05 , - 0.8564305660946356D-08 , 0.1670550773988772D-10 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.4790034223204244D-02 , - 0.1409392085286816D-03 , 0.1586923022785379D-05 , & - 0.8075941744900841D-08 , 0.1562976527927198D-10 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.4617164387430108D-02 , & - 0.1348998758194156D-03 , 0.1507802037856855D-05 , - 0.7615246615336354D-08 , & 0.1462383345122013D-10 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.4449785762745393D-02 , - 0.1291030114849410D-03 , & 0.1432515167991120D-05 , - 0.7180671831253375D-08 , 0.1368315159443619D-10 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.4287767255551076D-02 , - 0.1235399516593067D-03 , 0.1360885033168908D-05 , & - 0.6770753863527545D-08 , 0.1280345871796798D-10 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.4130978306012929D-02 , & - 0.1182022718570496D-03 , 0.1292741838393517D-05 , - 0.6384109588589672D-08 , & 0.1198077371082001D-10 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.3979289075368785D-02 , - 0.1130817852156068D-03 , & 0.1227923095400963D-05 , - 0.6019432008522640D-08 , 0.1121137686434084D-10 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.3832570619145875D-02 , - 0.1081705403396010D-03 , 0.1166273351016523D-05 , & - 0.5675486187319314D-08 , 0.1049179262000589D-10 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.3690695046854405D-02 , & - 0.1034608187856349D-03 , 0.1107643922307879D-05 , - 0.5351105393370650D-08 , & 0.9818773460976806D-11 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.3553535668727200D-02 , - 0.9894513222412173D-04 , & 0.1051892638650379D-05 , - 0.5045187438633592D-08 , 0.9189284871300206D-11 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.3420967130084422D-02 , - 0.9461621931282723D-04 , 0.9988835907898951D-06 , & - 0.4756691205308145D-08 , 0.8600491291730868D-11 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.3292865533868493D-02 , & - 0.9046704231385240D-04 , 0.9484868869494026D-06 , - 0.4484633351165459D-08 , & 0.8049743005830707D-11 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.3169108551911853D-02 , - 0.8649078348445718D-04 , & 0.9005784160056698D-06 , - 0.4228085185056424D-08 , 0.7534563894496081D-11 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.3049575525482211D-02 , - 0.8268084126989256D-04 , 0.8550396177346731D-06 , & - 0.3986169704456838D-08 , 0.7052640001169165D-11 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.2934147555626418D-02 , & - 0.7903082632416107D-04 , 0.8117572600982867D-06 , - 0.3758058787220713D-08 , & 0.6601808853811649D-11 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.2822707583849700D-02 , - 0.7553455738357935D-04 , & 0.7706232235329340D-06 , - 0.3542970530076458D-08 , 0.6180049493384223D-11 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.2715140463628359D-02 , - 0.7218605701556611D-04 , 0.7315342921754248D-06 , & - 0.3340166726679635D-08 , 0.5785473161863041D-11 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.2611333023257195D-02 , & - 0.6897954726389882D-04 , 0.6943919519504337D-06 , - 0.3148950478366324D-08 , & 0.5416314605996703D-11 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.2511174120505111D-02 , - 0.6590944520974408D-04 , & 0.6591021954263452D-06 , - 0.2968663931030508D-08 , 0.5070923955895336D-11 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.2414554689564850D-02 , - 0.6297035846701940D-04 , 0.6255753333416789D-06 , & - 0.2798686131872094D-08 , 0.4747759140329206D-11 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.2321367780727142D-02 , & - 0.6015708062813420D-04 , 0.5937258126825065D-06 , - 0.2638430999988898D-08 , & 0.4445378803065772D-11 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.2231508593231916D-02 , - 0.5746458667585025D-04 , & 0.5634720411927860D-06 , - 0.2487345405104062D-08 , 0.4162435687031700D-11 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.2144874501721017D-02 , - 0.5488802837539049D-04 , 0.5347362181881640D-06 , & - 0.2344907348963055D-08 , 0.3897670455269254D-11 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.2061365076683246D-02 , & - 0.5242272965926834D-04 , 0.5074441715327423D-06 , - 0.2210624244164731D-08 , & 0.3649905919688226D-11 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.1980882099305868D-02 , - 0.5006418201721691D-04 , & 0.4815252006432380D-06 , - 0.2084031285478505D-08 , 0.3418041650620579D-11 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.1903329571095287D-02 , - 0.4780803990159563D-04 , 0.4569119253711814D-06 , & - 0.1964689908889371D-08 , 0.3201048941911424D-11 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.1828613718626879D-02 , & - 0.4565011615800764D-04 , 0.4335401406139604D-06 , - 0.1852186333852183D-08 , & 0.2997966107986967D-11 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.1756642993786429D-02 , - 0.4358637749038112D-04 , & 0.4113486765073293D-06 , - 0.1746130184469900D-08 , 0.2807894090937378D-11 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.1687328069813371D-02 , - 0.4161293996794593D-04 , 0.3902792640409817D-06 , & - 0.1646153185476145D-08 , 0.2629992357048097D-11 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.1620581833477313D-02 , & - 0.3972606458165047D-04 , 0.3702764059467866D-06 , - 0.1551907929139697D-08 , & 0.2463475063643470D-11 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.1556319373682362D-02 , - 0.3792215285622918D-04 , & 0.3512872527032602D-06 , - 0.1463066709373635D-08 , 0.2307607478340191D-11 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.1494457966798269D-02 , - 0.3619774252389306D-04 , 0.3332614835044762D-06 , & - 0.1379320419532668D-08 , 0.2161702634028126D-11 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.1434917058968172D-02 , & - 0.3454950326407467D-04 , 0.3161511920339229D-06 , - 0.1300377510520709D-08 , & 0.2025118203949499D-11 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.1377618245683066D-02 , - 0.3297423251438736D-04 , & 0.2999107768975612D-06 , - 0.1225963006050721D-08 , 0.1897253582369020D-11 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.1322485248850548D-02 , - 0.3146885135615401D-04 , 0.2844968365601223D-06 , & - 0.1155817572008266D-08 , 0.1777547157214917D-11 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.1269443891590049D-02 , & - 0.3003040047777536D-04 , 0.2698680686347542D-06 , - 0.1089696637040499D-08 , & 0.1665473762003185D-11 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.1218422070997357D-02 , - 0.2865603621926910D-04 , & 0.2559851733832397D-06 , - 0.1027369561657830D-08 , 0.1560542295230988D-11 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.1169349729059475D-02 , - 0.2734302669964953D-04 , 0.2428107612752430D-06 , & - 0.9686188532280218D-09 , 0.1462293496139745D-11 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.1122158821937280D-02 , & - 0.2608874802956700D-04 , 0.2303092644683896D-06 , - 0.9132394244190516D-09 , & 0.1370297866551654D-11 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.1076783287792154D-02 , - 0.2489068061051108D-04 , & 0.2184468520670431D-06 , - 0.8610378927453654D-09 , 0.1284153729125209D-11 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.1033159013346410D-02 , - 0.2374640552210924D-04 , 0.2071913490258379D-06 , & - 0.8118319190134847D-09 , 0.1203485413047199D-11 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.9912237993109859D-03 , & - 0.2265360099764211D-04 , 0.1965121585573861D-06 , - 0.7654495825384472D-09 , & 0.1127941558716604D-11 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.9509173248738213D-03 , - 0.2161003898925139D-04 , & 0.1863801879215350D-06 , - 0.7217287911707136D-09 , 0.1057193533622516D-11 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.9121811113684409D-03 , - 0.2061358182252143D-04 , 0.1767677774631726D-06 , & - 0.6805167242221455D-09 , 0.9909339520552510D-12 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.8749584852561312D-03 , & - 0.1966217894042314D-04 , 0.1676486327739649D-06 , - 0.6416693064989667D-09 , & 0.9288752918069698D-12 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.8391945405753982D-03 , - 0.1875386373704784D-04 , & 0.1589977598625155D-06 , - 0.6050507117656569D-09 , 0.8707486015035527D-12 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.8048361009404974D-03 , - 0.1788675047988927D-04 , 0.1507914032080580D-06 , & - 0.5705328940030001D-09 , 0.8163022925586813D-12 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.7718316812242393D-03 , & - 0.1705903132066880D-04 , 0.1430069865886375D-06 , - 0.5379951449570670D-09 , & 0.7653010102079581D-12 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.7401314490143024D-03 , - 0.1626897339364930D-04 , & 0.1356230565704615D-06 , - 0.5073236765264415D-09 , 0.7175245784050949D-12 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.7096871859556973D-03 , - 0.1551491600093228D-04 , 0.1286192285544989D-06 , & - 0.4784112266346619D-09 , 0.6727670137397728D-12 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.6804522490278728D-03 , & - 0.1479526788281531D-04 , 0.1219761352688989D-06 , - 0.4511566872661359D-09 , & 0.6308356037985444D-12 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.6523815318857152D-03 , - 0.1410850457313305D-04 , & 0.1156753776158507D-06 , - 0.4254647534763634D-09 , 0.5915500457811894D-12 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.6254314258177012D-03 , - 0.1345316582573046D-04 , 0.1096994776616177D-06 , & - 0.4012455917585987D-09 , 0.5547416407206105D-12 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.5995597833435532D-03 , & - 0.1282785318239780D-04 , 0.1040318343281930D-06 , - 0.3784145293094803D-09 , & 0.5202525436124299D-12 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.5747258771041813D-03 , - 0.1223122750076454D-04 , & 0.9865668005512784D-07 , - 0.3568917565124851D-09 , 0.4879350559138081D-12 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.5508903640510732D-03 , - 0.1166200668266307D-04 , 0.9355904055135798D-07 , & - 0.3366020506053510D-09 , 0.4576509707866615D-12 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.5280152474686486D-03 , & - 0.1111896341832656D-04 , 0.8872469588117466D-07 , - 0.3174745128216178D-09 , & 0.4292709577556140D-12 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.5060638399027743D-03 , - 0.1060092301856454D-04 , & 0.8414014347713837D-07 , - 0.2994423208671456D-09 , 0.4026739881393617D-12 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.4850007265491436D-03 , - 0.1010676132126446D-04 , 0.7979256289132479D-07 , & - 0.2824424954518784D-09 , 0.3777467979404591D-12 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.4647917290926917D-03 , & - 0.9635402669515627D-05 , 0.7566978220120036D-07 , - 0.2664156800622869D-09 , & 0.3543833856987891D-12 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.4454038700908289D-03 , - 0.9185817960889167D-05 , & 0.7176024600757578D-07 , - 0.2513059332690183D-09 , 0.3324845430660750D-12 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.4268053378900525D-03 , - 0.8757022765253993D-05 , 0.6805298494753529D-07 , & - 0.2370605328420201D-09 , 0.3119574159237996D-12 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.4089654521164628D-03 , & - 0.8348075509705868D-05 , 0.6453758665804552D-07 , - 0.2236297910215624D-09 , & 0.2927150940608377D-12 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.3918546297545877D-03 , - 0.7958075728561548D-05 , & 0.6120416812254690D-07 , - 0.2109668803046401D-09 , 0.2746762275195123D-12 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.3754443518628862D-03 , - 0.7586162377410678D-05 , 0.5804334934574294D-07 , & - 0.1990276691849372D-09 , 0.2577646679108970D-12 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.3597071308994663D-03 , & - 0.7231512208386811D-05 , 0.5504622828713745D-07 , - 0.1877705672471839D-09 , & 0.2419091330090675D-12 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.3446164787028574D-03 , - 0.6893338205642875D-05 , & 0.5220435700276104D-07 , - 0.1771563791135509D-09 , 0.2270428931393440D-12 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.3301468751493041D-03 , - 0.6570888079445140D-05 , 0.4950971894107513D-07 , & - 0.1671481667443771D-09 , 0.2131034779373432D-12 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.3162737374435862D-03 , & - 0.6263442816092109D-05 , 0.4695470733224163D-07 , - 0.1577111195933779D-09 , & 0.2000324021123383D-12 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.3029733901196985D-03 , - 0.5970315283362068D-05 , & 0.4453210463121258D-07 , - 0.1488124322093636D-09 , 0.1877749090210022D-12 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.2902230357079550D-03 , - 0.5690848888804627D-05 , 0.4223506295859197D-07 , & - 0.1404211888370305D-09 , 0.1762797308556115D-12 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.2780007260959689D-03 , & - 0.5424416289701698D-05 , 0.4005708549672197D-07 , - 0.1325082546323623D-09 , & 0.1654988643784027D-12 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.2662853345522701D-03 , - 0.5170418152402247D-05 , & 0.3799200879169775D-07 , - 0.1250461731007564D-09 , 0.1553873611670895D-12 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.2550565284831763D-03 , - 0.4928281960826228D-05 , 0.3603398592944345D-07 , & - 0.1180090694392146D-09 , 0.1459031314693104D-12 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.2442947428332705D-03 , & - 0.4697460870794308D-05 , 0.3417747053196378D-07 , - 0.1113725594035527D-09 , & 0.1370067607242355D-12 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.2339811541847536D-03 , - 0.4477432609792013D-05 , & 0.3241720154366640D-07 , - 0.1051136634144988D-09 , 0.1286613379617455D-12 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.2240976555548222D-03 , - 0.4267698420698216D-05 , 0.3074818877087338D-07 , & - 0.9921072560538812D-10 , 0.1208322953067225D-12 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.2146268318272060D-03 , & - 0.4067782046842112D-05 , 0.2916569913052275D-07 , - 0.9364333750238978D-10 , & 0.1134872578316315D-12 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.2055519358906183D-03 , - 0.3877228758477316D-05 , & 0.2766524358547994D-07 , - 0.8839226610943556D-10 , 0.1065959031290858D-12 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.1968568653502555D-03 , - 0.3695604417049768D-05 , 0.2624256472014003D-07 , & - 0.8343938611071693D-10 , 0.1001298299404647D-12 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.1885261402622154D-03 , & - 0.3522494583135847D-05 , 0.2489362496429784D-07 , - 0.7876761602821835D-10 , & 0.9406243526695008D-13 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.1805448807606526D-03 , - 0.3357503649016494D-05 , & 0.2361459534199453D-07 , - 0.7436085794082865D-10 , 0.8836879939201241D-13 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.1728987861057983D-03 , - 0.3200254018924915D-05 , 0.2240184484720902D-07 , & - 0.7020394079726489D-10 , 0.8302557834289052D-13 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.1655741139410023D-03 , & - 0.3050385316499875D-05 , 0.2125193031535242D-07 , - 0.6628256692287296D-10 , & 0.7801090325634031D-13 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.1585576602637268D-03 , - 0.2907553626528559D-05 , & 0.2016158681104556D-07 , - 0.6258326162813466D-10 , 0.7330428623693248D-13 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.1518367399925579D-03 , - 0.2771430767959406D-05 , 0.1912771849679526D-07 , & - 0.5909332571652224D-10 , 0.6888653226932907D-13 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.1453991681600855D-03 , & - 0.2641703597827031D-05 , 0.1814738996511353D-07 , - 0.5580079074440671D-10 , & 0.6473965681441560D-13 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.1392332416305660D-03 , - 0.2518073343189603D-05 , & 0.1721781799891294D-07 , - 0.5269437683506576D-10 , 0.6084680867364500D-13 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.1333277214458984D-03 , - 0.2400254962210774D-05 , 0.1633636375500760D-07 , & - 0.4976345295009783D-10 , 0.5719219783918607D-13 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.1276718157118356D-03 , & - 0.2287976531836363D-05 , 0.1550052533969620D-07 , - 0.4699799944444861D-10 , & 0.5376102796849776D-13 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.1222551630069850D-03 , - 0.2180978660959042D-05 , & 0.1470793075673525D-07 , - 0.4438857277277338D-10 , 0.5053943318306609D-13 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.1170678163843920D-03 , - 0.2079013929564138D-05 , 0.1395633121954233D-07 , & - 0.4192627225463353D-10 , 0.4751441894763773D-13 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.1121002278438769D-03 , & - 0.1981846350875541D-05 , 0.1324359479613693D-07 , - 0.3960270873851812D-10 , & 0.4467380671795841D-13 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.1073432333405371D-03 , - 0.1889250856988292D-05 , & 0.1256770037991270D-07 , - 0.3740997508469672D-10 , 0.4200618214732029D-13 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.1027880382792195D-03 , - 0.1801012806388476D-05 , 0.1192673196551090D-07 , & - 0.3534061834815024D-10 , 0.3950084660585071D-13 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.9842620353308356D-04 , & - 0.1716927513388388D-05 , 0.1131887322070680D-07 , - 0.3338761358189200D-10 , & 0.3714777181931588D-13 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.9424963186623804D-04 , - 0.1636799796699351D-05 , & 0.1074240232679011D-07 , - 0.3154433912883794D-10 , 0.3493755738255394D-13 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.9025055488350793D-04 , - 0.1560443548750620D-05 , 0.1019568709004624D-07 , & - 0.2980455336443662D-10 , 0.3286139101642061D-13 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.8642152040053388D-04 , & - 0.1487681323258912D-05 , 0.9677180299621521D-08 , - 0.2816237277267278D-10 , & 0.3091101135303582D-13 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.8275538025654769D-04 , - 0.1418343940957748D-05 , & 0.9185415324159359D-08 , - 0.2661225129365991D-10 , 0.2907867310459288D-13 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.7924527853204922D-04 , - 0.1352270112142481D-05 , 0.8719001930232109D-08 , & - 0.2514896085159468D-10 , 0.2735711443893817D-13 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.7588464023089241D-04 , & - 0.1289306076834049D-05 , 0.8276622322975366D-08 , - 0.2376757303394459D-10 , & 0.2573952646870391D-13 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.7266716030931690D-04 , - 0.1229305259763412D-05 , & 0.7857027382428038D-08 , - 0.2246344180532250D-10 , 0.2421952465694019D-13 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.6958679311340136D-04 , - 0.1172127940961713D-05 , 0.7459033095945571D-08 , & - 0.2123218722935661D-10 , 0.2279112205595232D-13 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.6663774222203488D-04 , & - 0.1117640941465365D-05 , 0.7081517177719244D-08 , - 0.2006968014226268D-10 , & 0.2144870426225999D-13 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.6381445061962390D-04 , - 0.1065717322063741D-05 , & 0.6723415854968028D-08 , - 0.1897202768883065D-10 , 0.2018700594030563D-13 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.6111159121873057D-04 , - 0.1016236095950231D-05 , 0.6383720825773907D-08 , & - 0.1793555971653909D-10 , 0.1900108886370409D-13 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.5852405777127593D-04 , & - 0.9690819543442782D-06 , 0.6061476371889261D-08 , - 0.1695681594602861D-10 , & 0.1788632134167895D-13 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.5604695609197316D-04 , - 0.9241450043286664D-06 , & 0.5755776621607724D-08 , - 0.1603253388837399D-10 , 0.1683835895840826D-13 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.5367559556455711D-04 , - 0.8813205177033910D-06 , 0.5465762949072298D-08 , & - 0.1515963744625194D-10 , 0.1585312652006748D-13 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.5140548105201789D-04 , & - 0.8405086926326974D-06 , 0.5190621517595334D-08 , - 0.1433522620095708D-10 , & 0.1492680117636891D-13 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.4923230502520920D-04 , - 0.8016144246378223D-06 , & 0.4929580941290086D-08 , - 0.1355656529367655D-10 , 0.1405579658612873D-13 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.4715194002455074D-04 , - 0.7645470885798904D-06 , 0.4681910071938129D-08 , & - 0.1282107590327660D-10 , 0.1323674809900191D-13 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.4516043138740846D-04 , & - 0.7292203301943467D-06 , 0.4446915898531008D-08 , - 0.1212632626862104D-10 , & 0.1246649886988194D-13 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.4325399030322500D-04 , - 0.6955518679944135D-06 , & 0.4223941561636089D-08 , - 0.1147002324623084D-10 , 0.1174208686964753D-13 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.4142898703175620D-04 , - 0.6634633024605163D-06 , 0.4012364459941180D-08 , & - 0.1085000432526486D-10 , 0.1106073268594404D-13 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.3968194447473497D-04 , & - 0.6328799355209891D-06 , 0.3811594465284673D-08 , - 0.1026423013217101D-10 , & 0.1041982812483502D-13 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.3800953195996509D-04 , - 0.6037305976914865D-06 , & 0.3621072226805495D-08 , - 0.9710777358082358D-11 , 0.9816925521968053D-14 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.3640855922272478D-04 , - 0.5759474824404350D-06 , 0.3440267559199704D-08 , & - 0.9187832083640167D-11 , 0.9249727717367705D-14 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.3487597071228588D-04 , & - 0.5494659896407456D-06 , 0.3268677924035943D-08 , - 0.8693683514365489D-11 , & 0.8716078688550320D-14 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.3340884003286435D-04 , - 0.5242245748015790D-06 , & 0.3105826981602770D-08 , - 0.8226718054499248D-11 , 0.8213954750490777D-14 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.3200436464124055D-04 , - 0.5001646058789481D-06 , 0.2951263222184449D-08 , & - 0.7785413733830707D-11 , 0.7741456321295975D-14 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.3065986073081857D-04 , & - 0.4772302263433202D-06 , 0.2804558666680029D-08 , - 0.7368334950844383D-11 , & 0.7296800201017990D-14 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.2937275837614051D-04 , - 0.4553682255107168D-06 , & 0.2665307640692189D-08 , - 0.6974127534495396D-11 , 0.6878312351729931D-14 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.2814059675763916D-04 , - 0.4345279130967848D-06 , 0.2533125602023391D-08 , & - 0.6601514062724452D-11 , 0.6484421103349348D-14 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.2696101967799576D-04 , & - 0.4146610012083104D-06 , 0.2407648039180462D-08 , - 0.6249289477211629D-11 , & 0.6113650812765263D-14 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.2583177120785152D-04 , - 0.3957214910315959D-06 , & 0.2288529422814389D-08 , - 0.5916316938800563D-11 , 0.5764615908910709D-14 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.2475069152854098D-04 , - 0.3776655651576863D-06 , 0.2175442214220896D-08 , & - 0.5601523927910184D-11 , 0.5436015317536938D-14 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.2371571287241231D-04 , & - 0.3604514838086110D-06 , 0.2068075919135347D-08 , - 0.5303898552642779D-11 , & 0.5126627218800657D-14 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.2272485575107096D-04 , - 0.3440394879156361D-06 , & 0.1966136203050133D-08 , - 0.5022486101214445D-11 , 0.4835304164489345D-14 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.2177622521840302D-04 , - 0.3283917048239559D-06 , 0.1869344041586718D-08 , & - 0.4756385763648570D-11 , 0.4560968472117475D-14 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.2086800732494686D-04 , & - 0.3134720590687660D-06 , 0.1777434919374899D-08 , - 0.4504747552944468D-11 , & 0.4302607917794041D-14 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.1999846576599255D-04 , - 0.2992461880853213D-06 , & 0.1690158075283588D-08 , - 0.4266769414898549D-11 , 0.4059271709431192D-14 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.1916593855265465D-04 , - 0.2856813601270155D-06 , 0.1607275777155997D-08 , & - 0.4041694478481021D-11 , 0.3830066686549623D-14 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.1836883492284450D-04 , & - 0.2727463976332576D-06 , 0.1528562643827656D-08 , - 0.3828808488417011D-11 , & 0.3614153780625615D-14 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.1760563232879023D-04 , - 0.2604116034329022D-06 , & 0.1453804998301984D-08 , - 0.3627437374237223D-11 , 0.3410744685420261D-14 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.1687487357225473D-04 , - 0.2486486907848458D-06 , 0.1382800256966789D-08 , & - 0.3436944964603362D-11 , 0.3219098740159350D-14 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.1617516398514704D-04 , & - 0.2374307156203210D-06 , 0.1315356344675002D-08 , - 0.3256730817480803D-11 , & 0.3038519992100707D-14 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.1550516885840460D-04 , - 0.2267320139699398D-06 , & 0.1251291151836282D-08 , - 0.3086228203719166D-11 , 0.2868354469289057D-14 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.1486361085282726D-04 , - 0.2165281404699697D-06 , 0.1190432009397050D-08 , & - 0.2924902179722337D-11 , 0.2707987597524954D-14 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.1424926757439185D-04 , & - 0.2067958106351714D-06 , 0.1132615196287394D-08 , - 0.2772247783271911D-11 , & 0.2556841789754512D-14 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.1366096922040025D-04 , - 0.1975128454163308D-06 , & 0.1077685470253280D-08 , - 0.2627788326796399D-11 , 0.2414374179430384D-14 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.1309759640703599D-04 , - 0.1886581196174162D-06 , 0.1025495630227332D-08 , & - 0.2491073805779285D-11 , 0.2280074510611085D-14 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.1255807793124391D-04 , & - 0.1802115104427640D-06 , 0.9759060888140715D-09 , - 0.2361679366564460D-11 , & 0.2153463129124782D-14 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.1204138877063832D-04 , - 0.1721538506215862D-06 , & 0.9287844791494076D-09 , - 0.2239203891653545D-11 , 0.2034089125878947D-14 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.1154654809869183D-04 , - 0.1644668827440539D-06 , 0.8840052767903686D-09 , & - 0.2123268652187066D-11 , 0.1921528582162634D-14 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.1107261741677054D-04 , & - 0.1571332162577863D-06 , 0.8414494441898587D-09 , - 0.2013516044348861D-11 , & 0.1815382929712472D-14 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.1061869866632868D-04 , - 0.1501362850738939D-06 , & 0.8010040860163500D-09 , - 0.1909608379072831D-11 , 0.1715277394685445D-14 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.1018393260141699D-04 , - 0.1434603098245292D-06 , 0.7625621370070170D-09 , & - 0.1811226776228313D-11 , 0.1620859570007853D-14 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.9767497060432964D-05 , & - 0.1370902594480122D-06 , 0.7260220527347920D-09 , - 0.1718070089241402D-11 , & 0.1531798045749305D-14 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.9368605371465107D-05 , - 0.1310118154895370D-06 , & 0.6912875214939897D-09 , - 0.1629853903160803D-11 , 0.1447781134941622D-14 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.8986504893082436D-05 , - 0.1252113390736182D-06 , 0.6582671965503070D-09 , & - 0.1546309602547218D-11 , 0.1368515689211164D-14 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.8620475462363964D-05 , & - 0.1196758372352010D-06 , 0.6268744305182245D-09 , - 0.1467183463955053D-11 , & 0.1293725961433151D-14 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.8269828052241365D-05 , - 0.1143929329114129D-06 , & 0.5970270347718331D-09 , - 0.1392235826874631D-11 , 0.1223152562401536D-14 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.7933903418232150D-05 , - 0.1093508353961666D-06 , 0.5686470462776268D-09 , & - 0.1321240299489297D-11 , 0.1156551470331629D-14 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.7612070836155192D-05 , & - 0.1045383126782872D-06 , 0.5416605091993472D-09 , - 0.1253983015758332D-11 , & 0.1093693106559487D-14 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.7303726796853905D-05 , - 0.9994466373734425D-07 , & 0.5159972607522962D-09 , - 0.1190261917828569D-11 , 0.1034361452836941D-14 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.7008293935269387D-05 , - 0.9555969467885862D-07 , 0.4915907416293609D-09 , & - 0.1129886110808166D-11 , 0.9783532506594463D-15 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.6725219838188338D-05 , & - 0.9137369365822912D-07 , 0.4683778039285681D-09 , - 0.1072675224917345D-11 , & 0.9254772235753100D-15 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.6453975980951625D-05 , - 0.8737740810052081D-07 , & 0.4462985349700494D-09 , - 0.1018458827654963D-11 , 0.8755533592390503D-15 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.6194056670533748D-05 , - 0.8356202246430692D-07 , 0.4252960875029403D-09 , & - 0.9670758627458984D-12 , 0.8284122295116280D-15 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.5944978145193373D-05 , & - 0.7991913860964330D-07 , 0.4053165268412156D-09 , - 0.9183741395979894D-12 , & 0.7838943683163633D-15 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.5706277505915583D-05 , - 0.7644075424255176D-07 , & 0.3863086711162517D-09 , - 0.8722098172082333D-12 , 0.7418496573284795D-15 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.5477511886407303D-05 , - 0.7311924505673432D-07 , 0.3682239537776269D-09 , & - 0.8284469495437976D-12 , 0.7021367771573997D-15 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.5258257568268614D-05 , & - 0.6994734647847885D-07 , 0.3510162867914900D-09 , - 0.7869570416313428D-12 , & 0.6646226788070284D-15 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.5048109179006658D-05 , - 0.6691813689853933D-07 , & 0.3346419341645543D-09 , - 0.7476186380635114D-12 , 0.6291820935444467D-15 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.4846678796291654D-05 , - 0.6402501996067900D-07 , 0.3190593831567128D-09 , & - 0.7103169144464729D-12 , 0.5956970550990767D-15 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.4653595328552297D-05 , & - 0.6126171093342301D-07 , 0.3042292387919093D-09 , - 0.6749433297259093D-12 , & 0.5640564832212684D-15 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.4468503700268973D-05 , - 0.5862222071436336D-07 , & 0.2901141084414738D-09 , - 0.6413952629716114D-12 , 0.5341557623346684D-15 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.4291064152930279D-05 , - 0.5610084169906607D-07 , 0.2766784980845768D-09 , & - 0.6095756835936596D-12 , 0.5058963568083873D-15 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.4120951664538059D-05 , & - 0.5369213551027007D-07 , 0.2638887199540739D-09 , - 0.5793928535599456D-12 , & 0.4791854607905909D-15 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.3957855193757188D-05 , - 0.5139091862348454D-07 , & 0.2517127914234186D-09 , - 0.5507600158646348D-12 , 0.4539356433855270D-15 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.3801477143739669D-05 , - 0.4919225119089043D-07 , 0.2401203518452009D-09 , & - 0.5235951290583423D-12 , 0.4300645393453920D-15 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.3651532761429104D-05 , & - 0.4709142522358481D-07 , 0.2290825777954733D-09 , - 0.4978206033941024D-12 , & 0.4074945471518817D-15 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.3507749606208735D-05 , - 0.4508395391561199D-07 , & 0.2185721056197410D-09 , - 0.4733630582379215D-12 , 0.3861525506574752D-15 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.3369866917988890D-05 , - 0.4316555984678438D-07 , 0.2085629499134331D-09 , & - 0.4501530751961716D-12 , 0.3659696425802140D-15 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.3237635242041493D-05 , & - 0.4133216677963506D-07 , 0.1990304412958458D-09 , - 0.4281249983989262D-12 , & 0.3468808922948946D-15 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.3110815855951848D-05 , - 0.3957988902168727D-07 , & 0.1899511533918843D-09 , - 0.4072167149628701D-12 , 0.3288251017793929D-15 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.2989180321874909D-05 , - 0.3790502262267449D-07 , 0.1813028401969394D-09 , & - 0.3873694623239879D-12 , 0.3117445882984545D-15 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.2872510008714204D-05 , & - 0.3630403634595593D-07 , 0.1730643735228676D-09 , - 0.3685276394139670D-12 , & 0.2955849743903674D-15 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.2760595775920097D-05 , - 0.3477356490302606D-07 , & 0.1652156926455051D-09 , - 0.3506386478882314D-12 , 0.2802950063559558D-15 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.2653237409448398D-05 , - 0.3331039911271895D-07 , 0.1577377399665687D-09 , & - 0.3336527061112014D-12 , 0.2658263540615256D-15 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.2550243326545048D-05 , & - 0.3191147970513054D-07 , 0.1506124155212682D-09 , - 0.3175227072729719D-12 , & 0.2521334502802836D-15 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.2451430178759183D-05 , - 0.3057388993370786D-07 , & 0.1438225265835727D-09 , - 0.3022040696336174D-12 , 0.2391733267088606D-15 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.2356622528577366D-05 , - 0.2929484926567942D-07 , 0.1373517433943160D-09 , & - 0.2876546026837503D-12 , 0.2269054658773605D-15 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.2265652380089984D-05 , & - 0.2807170532719218D-07 , 0.1311845473450042D-09 , - 0.2738343596974451D-12 , & 0.2152916449230224D-15 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.2178359027430137D-05 , - 0.2690193003627490D-07 , & 0.1253062001298969D-09 , - 0.2607055376490812D-12 , 0.2042958201544919D-15 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.2094588632057351D-05 , - 0.2578311236954219D-07 , 0.1197026974299738D-09 , & - 0.2482323461673446D-12 , 0.1938839890851448D-15 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.2014193948825802D-05 , & - 0.2471295314087579D-07 , 0.1143607330022290D-09 , - 0.2363809009165601D-12 , & 0.1840240744378501D-15 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.1937034000103963D-05 , - 0.2368925922071046D-07 , & 0.1092676607782320D-09 , - 0.2251191147441242D-12 , 0.1746858085267559D-15 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.1862973945386604D-05 , - 0.2270994031418350D-07 , 0.1044114697266577D-09 , & - 0.2144166176439979D-12 , 0.1658406425189754D-15 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.1791884619732865D-05 , & - 0.2177300165239032D-07 , 0.9978073994891005D-10 , - 0.2042446388715174D-12 , & 0.1574616275773152D-15 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.1723642407156451D-05 , - 0.2087654099499380D-07 , & 0.9536461978891527D-10 , - 0.1945759350931527D-12 , 0.1495233342992523D-15 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.1658129004688541D-05 , - 0.2001874432613012D-07 , 0.9115279724555226D-10 , & - 0.1853847079763298D-12 , 0.1420017653644797D-15 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.1595231072948647D-05 , & - 0.1919788022025073D-07 , 0.8713546570299513D-10 , - 0.1766465114828162D-12 , & 0.1348742617470072D-15 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.1534840183821839D-05 , - 0.1841229798139887D-07 , & 0.8330330780653806D-10 , - 0.1683381983751465D-12 , 0.1281194411054766D-15 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.1476852507027617D-05 , - 0.1766042259703973D-07 , 0.7964746487165933D-10 , & - 0.1604378378449783D-12 , 0.1217171149097156D-15 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.1421168634030005D-05 , & - 0.1694075146917528D-07 , 0.7615951504641868D-10 , - 0.1529246526194677D-12 , & 0.1156482221083397D-15 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.1367693349260627D-05 , - 0.1625185055777343D-07 , & 0.7283144915674094D-10 , - 0.1457789524421786D-12 , 0.1098947611960496D-15 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.1316335582350306D-05 , - 0.1559235280241689D-07 , 0.6965565743366506D-10 , & - 0.1389820909744335D-12 , 0.1044397414748390D-15 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.1267008044499159D-05 , & - 0.1496095272578275D-07 , 0.6662489900589236D-10 , - 0.1325163883498713D-12 , & 0.9926710889844018D-16 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.1219627177992697D-05 , - 0.1435640493325791D-07 , & 0.6373228970314734D-10 , - 0.1263650922948561D-12 , 0.9436170266412904D-16 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.1174112968343962D-05 , - 0.1377752097571418D-07 , 0.6097128262798522D-10 , & - 0.1205123252878136D-12 , 0.8970920195171482D-16 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.1130388832645697D-05 , & - 0.1322316718637986D-07 , 0.5833565348391922D-10 , - 0.1149430422501431D-12 , & 0.8529608159063405D-16 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.1088381320528497D-05 , - 0.1269226030107464D-07 , & 0.5581947614065804D-10 , - 0.1096429693310543D-12 , 0.8110955421538548D-16 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.1048020185809723D-05 , - 0.1218376760033653D-07 , 0.5341711900345430D-10 , & - 0.1045985855100298D-12 , 0.7713754571254686D-16 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.1009238120582359D-05 , & - 0.1169670301177565D-07 , 0.5112322329097106D-10 , - 0.9979706832004064D-13 , & 0.7336864413012474D-16 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.9719706580098987D-06 , - 0.1123012529136083D-07 , & 0.4893269100405186D-10 , - 0.9522625984799763D-13 , 0.6979206467460075D-16 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.9361560030347440D-06 , - 0.1078313537886059D-07 , 0.4684066941285960D-10 , & - 0.9087462639960443D-13 , 0.6639761058383659D-16 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.9017350860777968D-06 , & - 0.1035487644124985D-07 , 0.4484254777989909D-10 , - 0.8673124312011654D-13 , & 0.6317565326417377D-16 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.8686512132736359D-06 , - 0.9944529147059406D-08 , & 0.4293393296256330D-10 , - 0.8278573712400655D-13 , 0.6011708195917055D-16 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.8368501072066984D-06 , - 0.9551311623019181D-08 , 0.4111064616445660D-10 , & - 0.7902827329276473D-13 , 0.5721328588074769D-16 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.8062797695832580D-06 , & - 0.9174477318756616D-08 , 0.3936871050510271D-10 , - 0.7544952226576771D-13 , & 0.5445612349861529D-16 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.7768904353698053D-06 , - 0.8813313979027987D-08 , & 0.3770434367517311D-10 , - 0.7204063894240369D-13 , 0.5183790009236447D-16 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.7486342878399751D-06 , - 0.8467139840684995D-08 , 0.3611393853766705D-10 , & - 0.6879321779986936D-13 , 0.4935132867383131D-16 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.7214656347780799D-06 , & - 0.8135305264659277D-08 , 0.3459406783914650D-10 , - 0.6569929593909141D-13 , & 0.4698952649935043D-16 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.6953406571279067D-06 , - 0.7817189374509128D-08 , & 0.3314146705167397D-10 , - 0.6275131359231864D-13 , 0.4474598060108379D-16 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.6702173658518182D-06 , - 0.7512199163258103D-08 , 0.3175302824403006D-10 , & - 0.5994209666284721D-13 , 0.4261452993269876D-16 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.6460554656167744D-06 , & - 0.7219767535770032D-08 , 0.3042578943256178D-10 , - 0.5726483082754512D-13 , & 0.4058934169580485D-16 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.6228164923779427D-06 , - 0.6939354545339646D-08 , & 0.2915693793710896D-10 , - 0.5471306303980918D-13 , 0.3866490788043820D-16 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.6004634455694445D-06 , - 0.6670442795983395D-08 , 0.2794378849990054D-10 , & - 0.5228065454702232D-13 , 0.3683600689569055D-16 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.5789609039845692D-06 , & - 0.6412538467122490D-08 , 0.2678378596326143D-10 , - 0.4996178171754240D-13 , & 0.3509770022609202D-16 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.5582749651073951D-06 , - 0.6165170301782166D-08 , & 0.2567449916109871D-10 , - 0.4775092007290691D-13 , 0.3344531709640568D-16 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.5383730050855717D-06 , - 0.5927886570599763D-08 , 0.2461360625728418D-10 , & - 0.4564281230444899D-13 , 0.3187442794225988D-16 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.5192238653039124D-06 , & - 0.5700256928034195D-08 , 0.2359890118679797D-10 , - 0.4363247687819249D-13 , & 0.3038084725846163D-16 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.5007862911648631D-06 , - 0.5481735415116262D-08 , & 0.2262768461596017D-10 , - 0.4171400406567135D-13 , 0.2895974057976737D-16 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.4830547655483510D-06 , - 0.5272203009250828D-08 , 0.2169917210541536D-10 , & - 0.3988530603045786D-13 , 0.2760913760700173D-16 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.4659899277963955D-06 , & - 0.5071142824551316D-08 , 0.2081082752209921D-10 , - 0.3814087211603929D-13 , & 0.2632456383294967D-16 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.3030303030303336D-01 , & - 0.2189353481773701D-02 , 0.7934802913344803D-04 , - 0.1922968092918301D-05 , & 0.3504044992676412D-07 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.3030302996270061D-01 , - 0.2189351522376626D-02 , & 0.7934364142608442D-04 , - 0.1918088692793271D-05 , 0.3257175741040063D-07 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.3030301691798807D-01 , - 0.2189318762873534D-02 , 0.7931219214064620D-04 , & - 0.1904376091780389D-05 , 0.3027734331086179D-07 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.3030293024019533D-01 , & - 0.2189183092815119D-02 , 0.7923193382148807D-04 , - 0.1883101546974315D-05 , & 0.2814488154583675D-07 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.3030262723526058D-01 , - 0.2188840562285394D-02 , & 0.7908612867574930D-04 , - 0.1855400607571004D-05 , 0.2616291929797306D-07 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.3030186414703274D-01 , - 0.2188166562438303D-02 , 0.7886232098647970D-04 , & - 0.1822285973196309D-05 , 0.2432081504953630D-07 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.3030028794491496D-01 , & - 0.2187024899367881D-02 , 0.7855169654880147D-04 , - 0.1784659209696977D-05 , & 0.2260868102041059D-07 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.3029743653519052D-01 , - 0.2185275069009009D-02 , & 0.7814851979633023D-04 , - 0.1743321419935139D-05 , 0.2101732969611087D-07 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.3029274520097154D-01 , - 0.2182778001873766D-02 , 0.7764964021816716D-04 , & - 0.1698982959023260D-05 , 0.1953822415480137D-07 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.3028555747305280D-01 , & - 0.2179400512009847D-02 , 0.7705406051102833D-04 , - 0.1652272275992794D-05 , & 0.1816343192304526D-07 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.3027513897193143D-01 , - 0.2175018654141036D-02 , & 0.7636255967465300D-04 , - 0.1603743957053321D-05 , 0.1688558210926706D-07 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.3026069304771644D-01 , - 0.2169520166083327D-02 , 0.7557736494895440D-04 , & - 0.1553886039320479D-05 , 0.1569782558177724D-07 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.3024137728649663D-01 , & - 0.2162806149836196D-02 , 0.7470186711522821D-04 , - 0.1503126658127104D-05 , & 0.1459379797483257D-07 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.3021632015501305D-01 , - 0.2154792123879159D-02 , & 0.7374037424724160D-04 , - 0.1451840085738913D-05 , 0.1356758532160657D-07 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.3018463722549844D-01 , - 0.2145408560847576D-02 , 0.7269789950682600D-04 , & - 0.1400352214438203D-05 , 0.1261369212727737D-07 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.3014544656394374D-01 , & - 0.2134601008639641D-02 , 0.7157997903776553D-04 , - 0.1348945532479684D-05 , & 0.1172701170873646D-07 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.3009788298189037D-01 , - 0.2122329878868705D-02 , & 0.7039251642596082D-04 , - 0.1297863637330243D-05 , 0.1090279863977420D-07 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.3004111094766956D-01 , - 0.2108569974198068D-02 , 0.6914165056726620D-04 , & - 0.1247315326849226D-05 , 0.1013664315206953D-07 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.2997433603090409D-01 , & - 0.2093309815279271D-02 , 0.6783364412088837D-04 , - 0.1197478305620524D-05 , & 0.9424447352965145D-08 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.2989681481674033D-01 , - 0.2076550818581073D-02 , & 0.6647479002927788D-04 , - 0.1148502540487199D-05 , 0.8762403130903999D-08 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.2980786327602054D-01 , - 0.2058306368185240D-02 , 0.6507133385821257D-04 , & - 0.1100513296440418D-05 , 0.8146971628592366D-08 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.2970686361646227D-01 , & - 0.2038600817494713D-02 , 0.6362940995614341D-04 , - 0.1053613881356021D-05 , & 0.7574864172489523D-08 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.2959326966962873D-01 , - 0.2017468450622651D-02 , & 0.6215498965245931D-04 , - 0.1007888125634241D-05 , 0.7043024555150496D-08 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.2946661089056430D-01 , - 0.1994952427894280D-02 , 0.6065383991250768D-04 , & - 0.9634026205633154D-06 , 0.6548612574310291D-08 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.2932649506272975D-01 , & - 0.1971103735296612D-02 , 0.5913149104513224D-04 , - 0.9202087371791049D-06 , & 0.6088988739435390D-08 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.2917260981141959D-01 , - 0.1945980153764429D-02 , & 0.5759321221811837D-04 , - 0.8783444455153686D-06 , 0.5661700062818710D-08 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.2900472303513508D-01 , - 0.1919645260814822D-02 , 0.5604399368004142D-04 , & - 0.8378359524189336D-06 , 0.5264466858192254D-08 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.2882268236723432D-01 , & - 0.1892167474166235D-02 , 0.5448853471520583D-04 , - 0.7986991745278263D-06 , & 0.4895170475309793D-08 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.2862641378028152D-01 , - 0.1863619144538811D-02 , & 0.5293123647310066D-04 , - 0.7609410615666397D-06 , 0.4551841904039815D-08 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.2841591944345596D-01 , - 0.1834075702775118D-02 , 0.5137619891640370D-04 , & - 0.7245607837911554D-06 , 0.4232651186234590D-08 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.2819127493965504D-01 , & - 0.1803614864694921D-02 , 0.4982722122323992D-04 , - 0.6895507962035150D-06 , & 0.3935897578030543D-08 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.2795262594394861D-01 , - 0.1772315895660941D-02 , & 0.4828780506122545D-04 , - 0.6558977910508232D-06 , 0.3660000409311667D-08 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.2770018445916244D-01 , - 0.1740258935646199D-02 , 0.4676116022378877D-04 , & - 0.6235835491055881D-06 , 0.3403490590854400D-08 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.2743422469787376D-01 , & - 0.1707524384623411D-02 , 0.4525021218424587D-04 , - 0.5925856992980281D-06 , & 0.3165002723189263D-08 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.2715507869322725D-01 , - 0.1674192347313389D-02 , & 0.4375761118092004D-04 , - 0.5628783954209376D-06 , 0.2943267764481391D-08 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.2686313171392253D-01 , - 0.1640342135706124D-02 , 0.4228574249797255D-04 , & - 0.5344329178509471D-06 , 0.2737106217766168D-08 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.2655881755162693D-01 , & - 0.1606051827281385D-02 , 0.4083673765217972D-04 , - 0.5072182075194113D-06 , & 0.2545421800694643D-08 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.2624261374208144D-01 , - 0.1571397876487175D-02 , & 0.3941248623631505D-04 , - 0.4812013387168978D-06 , 0.2367195563561055D-08 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.2591503677434952D-01 , - 0.1536454776763027D-02 , 0.3801464820550707D-04 , & - 0.4563479367212713D-06 , 0.2201480423816472D-08 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.2557663733612154D-01 , & - 0.1501294770208973D-02 , 0.3664466642453076D-04 , - 0.4326225456970095D-06 , & 0.2047396087531012D-08 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.2522799563676126D-01 , - 0.1465987601884257D-02 , & 0.3530377932182565D-04 , - 0.4099889518177157D-06 , 0.1904124330365138D-08 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.2486971684391352D-01 , - 0.1430600315661540D-02 , 0.3399303352053300D-04 , & - 0.3884104661111224D-06 , 0.1770904612559140D-08 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.2450242666400956D-01 , & - 0.1395197088552391D-02 , 0.3271329633836559D-04 , - 0.3678501711125930D-06 , & 0.1647030004260136D-08 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.2412676709191900D-01 , - 0.1359839100449024D-02 , & 0.3146526806697775D-04 , - 0.3482711350358489D-06 , 0.1531843399187231D-08 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.2374339235031665D-01 , - 0.1324584436288347D-02 , 0.3024949395798825D-04 , & - 0.3296365968254144D-06 , 0.1424733996197432D-08 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.2335296503505101D-01 , & - 0.1289488017730537D-02 , 0.2906637585717466D-04 , - 0.3119101251412142D-06 , & 0.1325134029765636D-08 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.2295615247891709D-01 , - 0.1254601561550188D-02 , & 0.2791618344084710D-04 , - 0.2950557540393975D-06 , 0.1232515731739778D-08 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.2255362334273438D-01 , - 0.1219973562058642D-02 , 0.2679906501922352D-04 , & - 0.2790380978523779D-06 , 0.1146388507984037D-08 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.2214604443949741D-01 , & - 0.1185649295007420D-02 , 0.2571505788096190D-04 , - 0.2638224475331729D-06 , & 0.1066296314685946D-08 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.2173407779458487D-01 , - 0.1151670840561311D-02 , & 0.2466409816102343D-04 , - 0.2493748505123969D-06 , 0.9918152201835212D-09 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.2131837794256236D-01 , - 0.1118077123072611D-02 , 0.2364603022089592D-04 , & - 0.2356621759188948D-06 , 0.9225511391719958D-09 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.2089958945897492D-01 , & - 0.1084903965533091D-02 , 0.2266061553603633D-04 , - 0.2226521668353654D-06 , & 0.8581377270819732D-09 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.2047834472367590D-01 , - 0.1052184156725201D-02 , & 0.2170754109031372D-04 , - 0.2103134810968507D-06 , 0.7982344232867606D-09 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.2005526191065917D-01 , - 0.1019947529237483D-02 , 0.2078642728136261D-04 , & - 0.1986157219913160D-06 , 0.7425246326011387D-09 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.1963094319802819D-01 , & - 0.9882210466495929D-03 , 0.1989683534418238D-04 , - 0.1875294600863864D-06 , & 0.6907140352810984D-09 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.1920597319062917D-01 , - 0.9570288983287753D-03 , & 0.1903827430313392D-04 , - 0.1770262472834972D-06 , 0.6425290164283133D-09 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.1878091754697722D-01 , - 0.9263926004114320D-03 , 0.1821020746476453D-04 , & - 0.1670786240892009D-06 , 0.5977152063481194D-09 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.1835632180138887D-01 , & - 0.8963311016695326D-03 , 0.1741205846570332D-04 , - 0.1576601209921008D-06 , & 0.5560361240088043D-09 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.1793271037169541D-01 , - 0.8668608930822736D-03 , & 0.1664321689127961D-04 , - 0.1487452547420571D-06 , 0.5172719163067247D-09 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.1751058574250628D-01 , - 0.8379961200472121D-03 , 0.1590304348156923D-04 , & - 0.1403095202449947D-06 , 0.4812181863587602D-09 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.1709042781374901D-01 , & - 0.8097486962736116D-03 , 0.1519087494233483D-04 , - 0.1323293787111899D-06 , & 0.4476849045240783D-09 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.1667269340405403D-01 , - 0.7821284185015872D-03 , & 0.1450602837881491D-04 , - 0.1247822426265408D-06 , 0.4164953963034060D-09 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.1625781589852450D-01 , - 0.7551430812859862D-03 , 0.1384780537059348D-04 , & - 0.1176464580544631D-06 , 0.3874854016786413D-09 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.1584620503048227D-01 , & - 0.7287985911725141D-03 , 0.1321549570586736D-04 , - 0.1109012847201179D-06 , & 0.3605022008408568D-09 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.1543824678690956D-01 , - 0.7030990796759000D-03 , & 0.1260838079335317D-04 , - 0.1045268742780816D-06 , 0.3354038016125425D-09 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.1503430342750568D-01 , - 0.6780470145462754D-03 , 0.1202573676987227D-04 , & - 0.9850424711893050D-07 , 0.3120581842024689D-09 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.1463471360753039D-01 , & - 0.6536433088803089D-03 , 0.1146683732133558D-04 , - 0.9281526802899475D-07 , & 0.2903425992404186D-09 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.1423979259490392D-01 , - 0.6298874276982717D-03 , & 0.1093095623444346D-04 , - 0.8744262098037965D-07 , 0.2701429153259696D-09 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.1384983257237507D-01 , - 0.6067774916676985D-03 , 0.1041736969594096D-04 , & - 0.8236978329491655D-07 , 0.2513530125922231D-09 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.1346510301593282D-01 , & - 0.5843103777082538D-03 , 0.9925358355730470D-05 , - 0.7758099939557007D-07 , & 0.2338742190329888D-09 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.1308585114103236D-01 , - 0.5624818162618596D-03 , & 0.9454209169567878D-05 , - 0.7306125433178895D-07 , 0.2176147865721773D-09 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.1271230240861168D-01 , - 0.5412864850566203D-03 , 0.9003217036454289D-05 , & - 0.6879624724096642D-07 , 0.2024894040679101D-09 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.1234466108329773D-01 , & - 0.5207180992334999D-03 , 0.8571686245203080D-05 , - 0.6477236488639964D-07 , & 0.1884187446425838D-09 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.1198311083662800D-01 , - 0.5007694977409154D-03 , & 0.8158931744013380D-05 , - 0.6097665539261505D-07 , 0.1753290449147070D-09 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.1162781538854083D-01 , - 0.4814327259347439D-03 , 0.7764280246223984D-05 , & - 0.5739680228145772D-07 , 0.1631517138797998D-09 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.1127891918082081D-01 , & - 0.4626991143503054D-03 , 0.7387071184768421D-05 , - 0.5402109889677369D-07 , & 0.1518229693470701D-09 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.1093654807660627D-01 , - 0.4445593536383266D-03 , & 0.7026657527197085D-05 , - 0.5083842329159302D-07 , 0.1412834999865826D-09 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.1060081008048414D-01 , - 0.4270035656794901D-03 , 0.6682406462489555D-05 , & - 0.4783821363935390D-07 , 0.1314781511792292D-09 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.1027179607410977D-01 , & - 0.4100213709120566D-03 , 0.6353699970250619D-05 , - 0.4501044421972974D-07 , & 0.1223556329896729D-09 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.9949580562677592D-02 , - 0.3936019519239506D-03 , & 0.6039935282263494D-05 , - 0.4234560201985135D-07 , 0.1138682487011383D-09 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.9634222427963194D-02 , - 0.3777341133757735D-03 , 0.5740525245777823D-05 , & - 0.3983466398312132D-07 , 0.1059716424613493D-09 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.9325765684020864D-02 , & - 0.3624063383337132D-03 , 0.5454898597329137D-05 , - 0.3746907493020856D-07 , & 0.9862456469143997D-10 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.9024240231975808D-02 , - 0.3476068411018775D-03 , & 0.5182500155324904D-05 , - 0.3524072617010659D-07 , 0.9178865400490996D-10 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.8729662610695323D-02 , - 0.3333236166526932D-03 , 0.4922790939098606D-05 , & - 0.3314193481330421D-07 , 0.8542823447231271D-10 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.8442036740440754D-02 , & - 0.3195444867610057D-03 , 0.4675248221613989D-05 , - 0.3116542379396437D-07 , & 0.7951012714956511D-10 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.8161354656910116D-02 , - 0.3062571429533363D-03 , & 0.4439365522509759D-05 , - 0.2930430260355425D-07 , 0.7400347486423486D-10 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.7887597233376023D-02 , - 0.2934491863883707D-03 , 0.4214652547707812D-05 , & - 0.2755204873452210D-07 , 0.6887957932524541D-10 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.7620734888887931D-02 , & - 0.2811081647876727D-03 , 0.4000635081355908D-05 , - 0.2590248982925193D-07 , & 0.6411174968735945D-10 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.7360728280772303D-02 , - 0.2692216065381159D-03 , & 0.3796854835456112D-05 , - 0.2434978652670495D-07 , 0.5967516176322350D-10 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.7107528979902231D-02 , - 0.2577770520886947D-03 , 0.3602869262127002D-05 , & - 0.2288841599672090D-07 , 0.5554672713272973D-10 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.6861080127426674D-02 , & - 0.2467620827645975D-03 , 0.3418251333064958D-05 , - 0.2151315614988876D-07 , & 0.5170497145237525D-10 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.6621317071868378D-02 , - 0.2361643471215111D-03 , & 0.3242589290417010D-05 , - 0.2021907050922578D-07 , 0.4812992131661124D-10 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.6388167985683100D-02 , - 0.2259715849618178D-03 , 0.3075486372934970D-05 , & - 0.1900149372846509D-07 , 0.4480299906883180D-10 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.6161554460553680D-02 , & - 0.2161716491329440D-03 , 0.2916560520964765D-05 , - 0.1785601774062383D-07 , & 0.4170692500218621D-10 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.5941392080863498D-02 , - 0.2067525252263736D-03 , & 0.2765444063530078D-05 , - 0.1677847851964127D-07 , 0.3882562642994492D-10 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.5727590974930996D-02 , - 0.1977023492929881D-03 , 0.2621783390483971D-05 , & - 0.1576494343714366D-07 , 0.3614415314176571D-10 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.5520056343737189D-02 , & - 0.1890094236880770D-03 , 0.2485238612446674D-05 , - 0.1481169919591822D-07 , & 0.3364859879640604D-10 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.5318688966998674D-02 , - 0.1806622311562130D-03 , & 0.2355483211001924D-05 , - 0.1391524032131858D-07 , 0.3132602783310279D-10 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.5123385686545245D-02 , - 0.1726494472626700D-03 , 0.2232203681393206D-05 , & - 0.1307225819159525D-07 , 0.2916440751325723D-10 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.4934039867077746D-02 , & - 0.1649599512751242D-03 , 0.2115099169756045D-05 , - 0.1227963058810050D-07 , & 0.2715254473153857D-10 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.4750541834460265D-02 , - 0.1575828355953193D-03 , & 0.2003881106719135D-05 , - 0.1153441174629979D-07 , 0.2528002726087882D-10 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.4572779291786407D-02 , - 0.1505074138368207D-03 , 0.1898272839025935D-05 , & - 0.1083382288864737D-07 , 0.2353716911951069D-10 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.4400637713540294D-02 , & - 0.1437232276414865D-03 , 0.1798009260662283D-05 , - 0.1017524322059507D-07 , & 0.2191495977022385D-10 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.4234000718220229D-02 , - 0.1372200523229055D-03 , & 0.1702836444811135D-05 , - 0.9556201371219817D-08 , 0.2040501688234868D-10 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.4072750419863677D-02 , - 0.1309879014217268D-03 , 0.1612511277816985D-05 , & - 0.8974367260309326D-08 , 0.1899954240604788D-10 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.3916767758955979D-02 , & - 0.1250170302538163D-03 , 0.1526801096206310D-05 , - 0.8427544374094472D-08 , & 0.1769128172611095D-10 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.3765932813236735D-02 , - 0.1192979385280582D-03 , & 0.1445483327683055D-05 , - 0.7913662432197428D-08 , 0.1647348567880135D-10 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.3620125088971294D-02 , - 0.1138213721074692D-03 , 0.1368345136912187D-05 , & - 0.7430770428840586D-08 , 0.1533987523063966D-10 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.3479223793266264D-02 , & - 0.1085783239830229D-03 , 0.1295183076792878D-05 , - 0.6977030031779652D-08 , & 0.1428460863208611D-10 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.3343108088036379D-02 , - 0.1035600345261222D-03 , & 0.1225802745829461D-05 , - 0.6550709322915413D-08 , 0.1330225087228191D-10 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.3211657326258706D-02 , - 0.9875799108243107D-04 , 0.1160018452124629D-05 , & - 0.6150176865052000D-08 , 0.1238774527328869D-10 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.3084751271142947D-02 , & - 0.9416392696565463D-04 , 0.1097652884431312D-05 , - 0.5773896079728350D-08 , & 0.1153638707355003D-10 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.2962270298875064D-02 , - 0.8976981990709937D-04 , & 0.1038536790634148D-05 , - 0.5420419921598437D-08 , 0.1074379886095463D-10 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.2844095585591070D-02 , - 0.8556789001338828D-04 , 0.9825086639625662D-06 , & - 0.5088385835333579D-08 , 0.1000590772567788D-10 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.2730109279228844D-02 , & - 0.8155059728121432D-04 , 0.9294144371733770D-06 , - 0.4776510981510710D-08 , & 0.9318924012071539D-11 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.2620194656927359D-02 , - 0.7771063871566938D-04 , & 0.8791071848942481D-06 , - 0.4483587718502254D-08 , 0.8679321557446975D-11 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.2514236268618387D-02 , - 0.7404094509512240D-04 , 0.8314468342626796D-06 , & - 0.4208479327847099D-08 , 0.8083819313408455D-11 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.2412120067456097D-02 , & - 0.7053467742301948D-04 , 0.7862998839531385D-06 , - 0.3950115971093099D-08 , & 0.7529364252756058D-11 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.2313733527733766D-02 , - 0.6718522310464660D-04 , & 0.7435391316491666D-06 , - 0.3707490866610817D-08 , 0.7013115471834937D-11 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.2218965750902330D-02 , - 0.6398619188359555D-04 , 0.7030434099732759D-06 , & - 0.3479656675315444D-08 , 0.6532429404463224D-11 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.2127707560316010D-02 , & - 0.6093141157088950D-04 , 0.6646973308632674D-06 , - 0.3265722084742080D-08 , & 0.6084846069538873D-11 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.2039851585309826D-02 , - 0.5801492359716326D-04 , & 0.6283910383527151D-06 , - 0.3064848581363503D-08 , 0.5668076279875077D-11 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.1955292335186552D-02 , - 0.5523097841570127D-04 , 0.5940199696843304D-06 , & - 0.2876247401465142D-08 , 0.5279989744868087D-11 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.1873926263700917D-02 , & - 0.5257403078276996D-04 , 0.5614846246711740D-06 , - 0.2699176651365721D-08 , & 0.4918604004411110D-11 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.1795651824587653D-02 , - 0.5003873493895400D-04 , & 0.5306903431934044D-06 , - 0.2532938588151591D-08 , 0.4582074135791848D-11 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.1720369518678292D-02 , - 0.4761993971375634D-04 , 0.5015470907064838D-06 , & - 0.2376877052523460D-08 , 0.4268683179447268D-11 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.1647981933120340D-02 , & - 0.4531268357352806D-04 , 0.4739692516179692D-06 , - 0.2230375045725475D-08 , & 0.3976833233211907D-11 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.1578393773221143D-02 , - 0.4311218963187398D-04 , & 0.4478754303860303D-06 , - 0.2092852442945313D-08 , 0.3705037168302974D-11 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.1511511887379171D-02 , - 0.4101386063889326D-04 , 0.4231882601696185D-06 , & - 0.1963763835877427D-08 , 0.3451910923459312D-11 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.1447245285584406D-02 , & - 0.3901327396519055D-04 , 0.3998342188631712D-06 , - 0.1842596497548805D-08 , & 0.3216166336807468D-11 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.1385505151938774D-02 , - 0.3710617659481710D-04 , & 0.3777434523376335D-06 , - 0.1728868462824556D-08 , 0.2996604477830833D-11 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.1326204851607763D-02 , - 0.3528848013940449D-04 , 0.3568496046980782D-06 , & - 0.1622126718308062D-08 , 0.2792109444410812D-11 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.1269259932639039D-02 , & - 0.3355625588569152D-04 , 0.3370896553760992D-06 , - 0.1521945495718745D-08 , & 0.2601642592463810D-11 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.1214588123025520D-02 , - 0.3190572988638398D-04 , & 0.3184037628605327D-06 , - 0.1427924663075284D-08 , 0.2424237167884923D-11 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.1162109323385518D-02 , - 0.3033327810357285D-04 , 0.3007351148718789D-06 , & - 0.1339688208316700D-08 , 0.2258993312664628D-11 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.1111745595636144D-02 , & - 0.2883542161348754D-04 , 0.2840297847902367D-06 , - 0.1256882810292285D-08 , & 0.2105073419059624D-11 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.1063421147974447D-02 , - 0.2740882187923832D-04 , & 0.2682365941342925D-06 , - 0.1179176492258613D-08 , 0.1961697807439927D-11 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.1017062316504608D-02 , - 0.2605027609841998D-04 , 0.2533069809003995D-06 , & - 0.1106257353322087D-08 , 0.1828140705225960D-11 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.9725975438190303D-03 , & - 0.2475671263125799D-04 , 0.2391948735679452D-06 , - 0.1037832373485696D-08 , & 0.1703726505882650D-11 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.9299573548031280D-03 , - 0.2352518651366449D-04 , & 0.2258565705734053D-06 , - 0.9736262881623913D-09 , 0.1587826288372227D-11 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.8890743299626623D-03 , - 0.2235287506003947D-04 , 0.2132506250691210D-06 , & - 0.9133805282849806D-09 , 0.1479854578922202D-11 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.8498830765137444D-03 , & - 0.2123707355887684D-04 , 0.2013377347742907D-06 , - 0.8568522222997610D-09 , & 0.1379266338156640D-11 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.8123201974875762D-03 , - 0.2017519106434164D-04 , & 0.1900806367355677D-06 , - 0.8038132565583465D-09 , 0.1285554157874279D-11 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.7763242590646666D-03 , - 0.1916474628583898D-04 , 0.1794440068121630D-06 , & - 0.7540493907842797D-09 , 0.1198245652817395D-11 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.7418357563834849D-03 , & - 0.1820336357822927D-04 , 0.1693943637148936D-06 , - 0.7073594255159163D-09 , & 0.1116901033875035D-11 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.7087970779871562D-03 , - 0.1728876903313801D-04 , & 0.1598999774156845D-06 , - 0.6635544185247138D-09 , 0.1041110850000581D-11 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.6771524691210315D-03 , - 0.1641878667297959D-04 , 0.1509307817633878D-06 , & - 0.6224569474346383D-09 , 0.9704938871153114D-12 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.6468479940605185D-03 , & - 0.1559133474837429D-04 , 0.1424582911405136D-06 , - 0.5839004158974744D-09 , & 0.9046952130537357D-12 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.6178314976042821D-03 , - 0.1480442213850103D-04 , & 0.1344555209925582D-06 , - 0.5477284007941671D-09 , 0.8433843583256646D-12 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.5900525659243078D-03 , - 0.1405614485527632D-04 , 0.1268969120815241D-06 , & - 0.5137940381347156D-09 , 0.7862536232836214D-12 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.5634624868903514D-03 , & - 0.1334468265040588D-04 , 0.1197582583051844D-06 , - 0.4819594453991044D-09 , & 0.7330165028503103D-12 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.5380142099977817D-03 , - 0.1266829572464455D-04 , & 0.1130166379333703D-06 , - 0.4520951782078439D-09 , 0.6834062206119634D-12 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.5136623060498179D-03 , - 0.1202532153912521D-04 , 0.1066503481239214D-06 , & - 0.4240797193555586D-09 , 0.6371743646973330D-12 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.4903629266688622D-03 , & - 0.1141417172680198D-04 , 0.1006388425708773D-06 , - 0.3977989982929889D-09 , & 0.5940896183031466D-12 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.4680737632629384D-03 , - 0.1083332909032297D-04 , & 0.9496267202859126D-07 , - 0.3731459387535643D-09 , 0.5539365774138420D-12 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.4467540085799458D-03 , - 0.1028134476392961D-04 , 0.8960342835196501D-07 , & - 0.3500200361876123D-09 , 0.5165146550099313D-12 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.4263643132729342D-03 , & - 0.9756835338364204D-05 , 0.8454368998001928D-07 , - 0.3283269549756459D-09 , & 0.4816370523173580D-12 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.4068667478373185D-03 , - 0.9258480215047354D-05 , & 0.7976697135989043D-07 , - 0.3079781553018238D-09 , 0.4491298103160620D-12 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.3882247622435128D-03 , - 0.8785018985561815D-05 , 0.7525767421589665D-07 , & - 0.2888905396761889D-09 , 0.4188309225386888D-12 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.3704031464424431D-03 , & - 0.8335248915884555D-05 , 0.7100104134776101D-07 , - 0.2709861212485748D-09 , & 0.3905895102346404D-12 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.3533679912706433D-03 , - 0.7908022519539432D-05 , & 0.6698311271373570D-07 , - 0.2541917120720233D-09 , 0.3642650546631378D-12 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.3370866498497414D-03 , - 0.7502245218608667D-05 , 0.6319068370249281D-07 , & - 0.2384386301677798D-09 , 0.3397266825876837D-12 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.3215276994744887D-03 , & - 0.7116873089321782D-05 , 0.5961126548299900D-07 , - 0.2236624242396369D-09 , & 0.3168525012165201D-12 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.3066609040670671D-03 , - 0.6750910690931478D-05 , & 0.5623304734308869D-07 , - 0.2098026150173129D-09 , 0.2955289791904251D-12 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.2924571772391836D-03 , - 0.6403408975827070D-05 , 0.5304486092489004D-07 , & - 0.1968024522439051D-09 , 0.2756503704216360D-12 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.2788885459557166D-03 , & - 0.6073463277860852D-05 , 0.5003614626103691D-07 , - 0.1846086863499012D-09 , & 0.2571181777688792D-12 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.2659281148812092D-03 , - 0.5760211377899467D-05 , & 0.4719691953651184D-07 , - 0.1731713539753488D-09 , 0.2398406538335107D-12 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.2535500313972840D-03 , - 0.5462831643612448D-05 , 0.4451774248765119D-07 , & - 0.1624435764891144D-09 , 0.2237323362640379D-12 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.2417294513307764D-03 , & - 0.5180541241748589D-05 , 0.4198969336368676D-07 , - 0.1523813707415377D-09 , & 0.2087136151915462D-12 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.2304425053828397D-03 , - 0.4912594420147226D-05 , & 0.3960433937113001D-07 , - 0.1429434713010882D-09 , 0.1947103305419726D-12 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.2196662663325597D-03 , - 0.4658280858625205D-05 , 0.3735371053994611D-07 , & - 0.1340911635251005D-09 , 0.1816533972047673D-12 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.2093787169528823D-03 , & - 0.4416924085011958D-05 , 0.3523027492986757D-07 , - 0.1257881267680706D-09 , & 0.1694784560614953D-12 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.1995587186954379D-03 , - 0.4187879955274046D-05 , & 0.3322691511994808D-07 , - 0.1180002871490741D-09 , 0.1581255491230646D-12 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.1901859811549442D-03 , - 0.3970535195738101D-05 , 0.3133690591934139D-07 , & - 0.1106956793059266D-09 , 0.1475388171072084D-12 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.1812410322638607D-03 , & - 0.3764306004235776D-05 , 0.2955389323041563D-07 , - 0.1038443165632737D-09 , & 0.1376662178581514D-12 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.1727051892895458D-03 , - 0.3568636709659536D-05 , & 0.2787187401913316D-07 , - 0.9741806904958967D-10 , 0.1284592642211155D-12 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.1645605305879683D-03 , - 0.3382998486975271D-05 , 0.2628517733026466D-07 , & - 0.9139054925640757D-10 , 0.1198727799875837D-12 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.1567898681078458D-03 , & - 0.3206888125676099D-05 , 0.2478844629484375D-07 , - 0.8573700458828767D-10 , & 0.1118646726576566D-12 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.1493767206921483D-03 , - 0.3039826850830403D-05 , & 0.2337662108844710D-07 , - 0.8043421650931241D-10 , 0.1043957218928689D-12 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.1423052880311179D-03 , - 0.2881359192231806D-05 , 0.2204492277499806D-07 , & - 0.7546040583644247D-10 , 0.9742938252400876D-13 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.1355604257531830D-03 , & - 0.2731051908296954D-05 , 0.2078883804048637D-07 , - 0.7079514391070586D-10 , & 0.9093160114160112D-13 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.1291276204989729D-03 , - 0.2588492943585712D-05 , & 0.1960410466413035D-07 , - 0.6641926908383177D-10 , 0.8487064531260523D-13 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.1229929665152446D-03 , - 0.2453290444310794D-05 , 0.1848669783356129D-07 , & - 0.6231480847334713D-10 , 0.7921694457354782D-13 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.1171431425416566D-03 , & - 0.2325071809419826D-05 , 0.1743281714560127D-07 , - 0.5846490443408325D-10 , & 0.7394294233652352D-13 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.1115653895335356D-03 , - 0.2203482785258448D-05 , & 0.1643887431339533D-07 , - 0.5485374558440814D-10 , 0.6902295801516720D-13 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.1062474890716576D-03 , - 0.2088186599690883D-05 , 0.1550148152768775D-07 , & - 0.5146650206607772D-10 , 0.6443305862471696D-13 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.1011777424420529D-03 , & - 0.1978863134044572D-05 , 0.1461744043793371D-07 , - 0.4828926477762841D-10 , & 0.6015093919937425D-13 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.9634495043844797D-04 , - 0.1875208132676287D-05 , & 0.1378373173087774D-07 , - 0.4530898837100751D-10 , 0.5615581145840546D-13 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.9173839378745488D-04 , - 0.1776932446974114D-05 , 0.1299750526303867D-07 , & - 0.4251343773941087D-10 , 0.5242830009818903D-13 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.8734781424434263D-04 , & - 0.1683761313610040D-05 , 0.1225607072726655D-07 , - 0.3989113781275754D-10 , & 0.4895034622128056D-13 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.8316339631499471D-04 , - 0.1595433665072685D-05 , & 0.1155688882121886D-07 , - 0.3743132644406594D-10 , 0.4570511739188591D-13 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.7917574963343555D-04 , - 0.1511701472007420D-05 , 0.1089756289772453D-07 , & - 0.3512391021773641D-10 , 0.4267692388546055D-13 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.7537589188716411D-04 , & - 0.1432329114270534D-05 , 0.1027583105876174D-07 , - 0.3295942295817837D-10 , & 0.3985114065285215D-13 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.7175523239271113D-04 , - 0.1357092781740046D-05 , & 0.9689558686042261D-08 , - 0.3092898682634654D-10 , 0.3721413467020778D-13 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.6830555623042850D-04 , - 0.1285779902201681D-05 , 0.9136731374714594D-08 , & - 0.2902427581113226D-10 , 0.3475319726119408D-13 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.6501900891798206D-04 , & - 0.1218188595062521D-05 , 0.8615448248189644D-08 , - 0.2723748146649898D-10 , & 0.3245648104663851D-13 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.6188808168972699D-04 , - 0.1154127151344332D-05 , & 0.8123915644988133D-08 , - 0.2556128079177877D-10 , 0.3031294124540500D-13 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.5890559725800061D-04 , - 0.1093413536800775D-05 , 0.7660441143303278D-08 , & - 0.2398880607673831D-10 , 0.2831228097058852D-13 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.5606469611893972D-04 , & - 0.1035874918605108D-05 , 0.7223427915611699D-08 , - 0.2251361662343584D-10 , & 0.2644490028554280D-13 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.5335882334991392D-04 , - 0.9813472138878670D-06 , & 0.6811369390742990D-08 , - 0.2112967221343321D-10 , 0.2470184874186664D-13 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.5078171592955551D-04 , - 0.9296746600913869D-06 , 0.6422844213795292D-08 , & - 0.1983130823485693D-10 , 0.2307478118569433D-13 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.4832739050158688D-04 , & - 0.8807094045780722D-06 , 0.6056511474390431D-08 , - 0.1861321232061958D-10 , & 0.2155591655281369D-13 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.4599013158399556D-04 , - 0.8343111140189977D-06 , & 0.5711106204213252D-08 , - 0.1747040246249469D-10 , 0.2013799951518548D-13 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.4376448028871395D-04 , - 0.7903466026832619D-06 , 0.5385435121635872D-08 , & - 0.1639820647251892D-10 , 0.1881426473867894D-13 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.4164522339955774D-04 , & - 0.7486894773828782D-06 , 0.5078372606147925D-08 , - 0.1539224270641146D-10 , & 0.1757840357037884D-13 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.3962738294859412D-04 , - 0.7092198006614596D-06 , & 0.4788856903951668D-08 , - 0.1444840200933007D-10 , 0.1642453303271376D-13 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.3770620613435717D-04 , - 0.6718237689234153D-06 , 0.4515886535528384D-08 , & - 0.1356283075785956D-10 , 0.1534716690752659D-13 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.3587715566386722D-04 , & - 0.6363934065241073D-06 , 0.4258516905859933D-08 , - 0.1273191496609798D-10 , & 0.1434118880773512D-13 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.3413590045865352D-04 , - 0.6028262742711746D-06 , & 0.4015857100659045D-08 , - 0.1195226537278838D-10 , 0.1340182708034935D-13 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.3247830677746056D-04 , - 0.5710251928432953D-06 , 0.3787066866323126D-08 , & - 0.1122070347232571D-10 , 0.1252463144182562D-13 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.3090042960335951D-04 , & - 0.5408979779814149D-06 , 0.3571353747042789D-08 , - 0.1053424838148950D-10 , & 0.1170545117075336D-13 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.2939850445884358D-04 , - 0.5123571899898498D-06 , & 0.3367970391166755D-08 , - 0.9890104552156406D-11 , 0.1094041482111524D-13 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.2796893952205267D-04 , - 0.4853198948937984D-06 , 0.3176212004169453D-08 , & - 0.9285650237329369D-11 , 0.1022591130638829D-13 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.2660830802516973D-04 , & - 0.4597074365784633D-06 , 0.2995413939379953D-08 , - 0.8718426661627230D-11 , & 0.9558572258440189D-14 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.2531334104455380D-04 , - 0.4354452214948942D-06 , & 0.2824949432748153D-08 , - 0.8186127893280345D-11 , 0.8935255619042040D-14 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.2408092051017203D-04 , - 0.4124625125744271D-06 , 0.2664227455437365D-08 , & - 0.7686591320172345D-11 , 0.8353030319740477D-14 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.2290807253821798D-04 , & - 0.3906922338773440D-06 , 0.2512690690670644D-08 , - 0.7217788730453885D-11 , & 0.7809162017725982D-14 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.2179196102025746D-04 , - 0.3700707845175216D-06 , & 0.2369813621724775D-08 , - 0.6777817941837497D-11 , 0.7301099795169742D-14 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.2072988153643144D-04 , - 0.3505378627515244D-06 , 0.2235100733531038D-08 , & - 0.6364894970328444D-11 , 0.6826463783124748D-14 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.1971925541606907D-04 , & - 0.3320362969356593D-06 , 0.2108084803424185D-08 , - 0.5977346652414990D-11 , & 0.6383033589795215D-14 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.1875762414944162D-04 , - 0.3145118865588611D-06 , & 0.1988325298812654D-08 , - 0.5613603758008867D-11 , 0.5968737549236916D-14 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.1784264399327274D-04 , - 0.2979132505402684D-06 , 0.1875406861101950D-08 , & - 0.5272194521069155D-11 , 0.5581642688182447D-14 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.1697208076800551D-04 , & - 0.2821916823652236D-06 , 0.1768937870239936D-08 , - 0.4951738559790898D-11 , & 0.5219945359929182D-14 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.1614380496911590D-04 , - 0.2673010140564183D-06 , & 0.1668549100493879D-08 , - 0.4650941204876030D-11 , 0.4881962545307111D-14 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.1535578699808878D-04 , - 0.2531974854281583D-06 , 0.1573892442387229D-08 , & - 0.4368588153794941D-11 , 0.4566123714689872D-14 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.1460609263949520D-04 , & - 0.2398396205872630D-06 , 0.1484639701219040D-08 , - 0.4103540470720373D-11 , & 0.4270963255380760D-14 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.1389287870999633D-04 , - 0.2271881102489100D-06 , & 0.1400481461064398D-08 , - 0.3854729891343335D-11 , 0.3995113405346248D-14 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.1321438896230131D-04 , - 0.2152057010741255D-06 , 0.1321126019890033D-08 , & - 0.3621154439435740D-11 , 0.3737297685826866D-14 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.1256895004289434D-04 , & - 0.2038570885291489D-06 , 0.1246298372145968D-08 , - 0.3401874281119649D-11 , & 0.3496324741734656D-14 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.1195496774027267D-04 , - 0.1931088170420473D-06 , & 0.1175739260742055D-08 , - 0.3196007870234653D-11 , 0.3271082633287189D-14 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.1137092335671229D-04 , - 0.1829291845339381D-06 , 0.1109204278545936D-08 , & - 0.3002728322267731D-11 , 0.3060533501718278D-14 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.1081537018809324D-04 , & - 0.1732881509538817D-06 , 0.1046463015758789D-08 , - 0.2821260000493913D-11 , & 0.2863708581708593D-14 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.1028693027039846D-04 , - 0.1641572532721546D-06 , & 0.9872982668232758D-09 , - 0.2650875345399166D-11 , 0.2679703582418731D-14 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.9784291165922754D-05 , - 0.1555095230955305D-06 , 0.9315052719777759D-09 , & - 0.2490891873382153D-11 , 0.2507674351589044D-14 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.9306202939474711D-05 , & - 0.1473194092587239D-06 , 0.8788910067072563D-09 , - 0.2340669375669421D-11 , & 0.2346832846063690D-14 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.8851475243358224D-05 , - 0.1395627039392029D-06 , & 0.8292735090455647D-09 , - 0.2199607284984538D-11 , 0.2196443367481676D-14 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.8418974608711646D-05 , - 0.1322164737680277D-06 , 0.7824812525082376D-09 , & - 0.2067142226097144D-11 , 0.2055819071940560D-14 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.8007621715839950D-05 , & - 0.1252589921933942D-06 , 0.7383525410972970D-09 , - 0.1942745682588853D-11 , & 0.1924318678426315D-14 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.7616388918455531D-05 , - 0.1186696774038324D-06 , & 0.6967349513564167D-09 , - 0.1825921842777913D-11 , 0.1801343433180595D-14 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.7244297832754079D-05 , - 0.1124290326894366D-06 , 0.6574848017385098D-09 , & - 0.1716205567869329D-11 , 0.1686334266524019D-14 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.6890416977133540D-05 , & - 0.1065185889544457D-06 , 0.6204666468635713D-09 , - 0.1613160472653781D-11 , & 0.1578769127317377D-14 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.6553859646371846D-05 , - 0.1009208521917032D-06 , & 0.5855528124937925D-09 , - 0.1516377157113323D-11 , 0.1478160527948979D-14 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.6233781763206699D-05 , - 0.9561925179286469D-07 , 0.5526229460149094D-09 , & - 0.1425471519168410D-11 , 0.1384053225776244D-14 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.5929379882822312D-05 , & - 0.9059809238981509D-07 , 0.5215635977107039D-09 , - 0.1340083186073236D-11 , & 0.1296022073941318D-14 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.5639889258637204D-05 , - 0.8584250772180042D-07 , & 0.4922678232797664D-09 , - 0.1259874036589218D-11 , 0.1213670009903315D-14 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.5364582083284115D-05 , - 0.8133841822500807D-07 , 0.4646348168386412D-09 , & - 0.1184526835327987D-11 , 0.1136626198707602D-14 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.5102765649461143D-05 , & - 0.7707248834007633D-07 , 0.4385695505556011D-09 , - 0.1113743915078125D-11 , & 0.1064544264940369D-14 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.4853780744119680D-05 , - 0.7303208832470155D-07 , & 0.4139824481978899D-09 , - 0.1047245975586753D-11 , 0.9971006768089518D-15 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.4617000063872055D-05 , - 0.6920525723234986D-07 , 0.3907890726273315D-09 , & - 0.9847709448868889D-12 , 0.9339932267039094D-15 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.4391826638336876D-05 , & - 0.6558066682650672D-07 , 0.3689098255712068D-09 , - 0.9260728972904540D-12 , & 0.8749396000912050D-15 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.4177692470215030D-05 , - 0.6214758955424455D-07 , & 0.3482696770631246D-09 , - 0.8709210705227436D-12 , 0.8196760707623441D-15 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.3974057104456300D-05 , - 0.5889586615460336D-07 , 0.3287978987914190D-09 , & - 0.8190989145566539D-12 , 0.7679562553009686D-15 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.3780406326173555D-05 , & - 0.5581587589935687D-07 , 0.3104278181275128D-09 , - 0.7704032133961314D-12 , & 0.7195499641158044D-15 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.3596250886045641D-05 , - 0.5289850788945923D-07 , & 0.2930965834623509D-09 , - 0.7246432545043988D-12 , 0.6742421227583623D-15 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.3421125382040726D-05 , - 0.5013513529412371D-07 , 0.2767449511031084D-09 , & - 0.6816400701717381D-12 , 0.6318317844385706D-15 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.3254587014111711D-05 , & - 0.4751758826485988D-07 , 0.2613170694285998D-09 , - 0.6412256887063180D-12 , & 0.5921311734737216D-15 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.3096214563511059D-05 , - 0.4503813074350389D-07 , & 0.2467602893162120D-09 , - 0.6032424668918699D-12 , 0.5549648252382206D-15 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.2945607361058927D-05 , - 0.4268943760376235D-07 , 0.2330249805021814D-09 , & - 0.5675424515671788D-12 , 0.5201687718823625D-15 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.2802384231703044D-05 , & - 0.4046457193305954D-07 , 0.2200643526644150D-09 , - 0.5339867666234914D-12 , & 0.4875897692409691D-15 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.2666182648640146D-05 , - 0.3835696585361310D-07 , & 0.2078342997518014D-09 , - 0.5024450700477759D-12 , 0.4570846048794573D-15 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.2536657778528140D-05 , - 0.3636040016630384D-07 , 0.1962932412023570D-09 , & - 0.4727950150643336D-12 , 0.4285194248616379D-15 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.2413481641150383D-05 , & - 0.3446898608143933D-07 , 0.1854019779038621D-09 , - 0.4449217585928804D-12 , & 0.4017691181817036D-15 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.2296342272337925D-05 , - 0.3267714738042052D-07 , & 0.1751235535454142D-09 , - 0.4187174932321244D-12 , 0.3767167357925263D-15 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.2184943033385532D-05 , - 0.3097960505712765D-07 , 0.1654231323026451D-09 , & - 0.3940810285399208D-12 , 0.3532529666936452D-15 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.2079001755651648D-05 , & - 0.2937135991836449D-07 , 0.1562678681019784D-09 , - 0.3709173609753772D-12 , & 0.3312756149604536D-15 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.1978250109370338D-05 , - 0.2784767874731307D-07 , & 0.1476267957530599D-09 , - 0.3491373052220061D-12 , 0.3106891430539711D-15 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.1882432916626455D-05 , - 0.2640407995908322D-07 , 0.1394707216378278D-09 , & - 0.3286571322079806D-12 , 0.2914042307908976D-15 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.1791307541808524D-05 , & - 0.2503632065076004D-07 , 0.1317721241077124D-09 , - 0.3093982377661108D-12 , & 0.2733373709555406D-15 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.1704643179825639D-05 , - 0.2374038247379785D-07 , & 0.1245050496929889D-09 , - 0.2912868083068192D-12 , 0.2564104707521015D-15 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.1622220420911904D-05 , - 0.2251246168970884D-07 , 0.1176450335977645D-09 , & - 0.2742535507088936D-12 , 0.2405505185014451D-15 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.1543830610566386D-05 , & - 0.2134895655471616D-07 , 0.1111690077440046D-09 , - 0.2582333985547485D-12 , & 0.2256892363996045D-15 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.1469275320144772D-05 , - 0.2024645650849613D-07 , & 0.1050552201861448D-09 , - 0.2431652510604103D-12 , 0.2117627692612349D-15 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.1398365939523479D-05 , - 0.1920173328272911D-07 , 0.9928316622761239D-10 , & - 0.2289917446798778D-12 , 0.1987114083535890D-15 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.1330923073937440D-05 , & - 0.1821172947068311D-07 , 0.9383350768967257D-10 , - 0.2156590018494109D-12 , & 0.1864793009549186D-15 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.1266776170129178D-05 , - 0.1727355050013158D-07 , & 0.8868801152271783D-10 , - 0.2031164296855893D-12 , 0.1750142093784893D-15 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.1205763066817246D-05 , - 0.1638445572372147D-07 , 0.8382948508429417D-10 , & - 0.1913165150853396D-12 , 0.1642672718088070D-15 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.1147729615417835D-05 , & - 0.1554185065304855D-07 , 0.7924171863038743D-10 , - 0.1802146405825567D-12 , & 0.1541927859663313D-15 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.1092529176972482D-05 , - 0.1474327765247075D-07 , & 0.7490942103414857D-10 , - 0.1697688884012184D-12 , 0.1447479870027509D-15 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.1040022406107380D-05 , - 0.1398641073549288D-07 , 0.7081817784022790D-10 , & - 0.1599398995002783D-12 , 0.1358928771194340D-15 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.9900768009371240D-06 , & - 0.1326904728021013D-07 , 0.6695439440193511D-10 , - 0.1506907014737726D-12 , & 0.1275900319714977D-15 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.9425663616415780D-06 , - 0.1258910138193819D-07 , & 0.6330524849388078D-10 , - 0.1419865614058684D-12 , 0.1198044322534834D-15 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.8973713697772148D-06 , - 0.1194459896771100D-07 , 0.5985865281079244D-10 , & - 0.1337948640216504D-12 , 0.1125033201607660D-15 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.8543779458458930D-06 , & - 0.1133367002057817D-07 , 0.5660320357831657D-10 , - 0.1260849609508706D-12 , & 0.1056560342498225D-15 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.8134778446602063D-06 , - 0.1075454414770834D-07 , & 0.5352814704506571D-10 , - 0.1188280631563504D-12 , 0.9923388402952724D-16 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.7745681594729660D-06 , - 0.1020554501415528D-07 , 0.5062334092784397D-10 , & - 0.1119971241823306D-12 , 0.9321001931536616D-16 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.7375510927201621D-06 , & - 0.9685085772823177D-08 , 0.4787922160283434D-10 , - 0.1055667385236816D-12 , & 0.8755931484700633D-16 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.7023335856345906D-06 , - 0.9191662707658910D-08 , & 0.4528676301310837D-10 , - 0.9951302356339916D-13 , 0.8225824344830929D-16 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.6688272476938348D-06 , - 0.8723852970732655D-08 , 0.4283745675358559D-10 , & - 0.9381355076772870D-13 , 0.7728479270878630D-16 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.6369480271689383D-06 , & - 0.8280308944664631D-08 , 0.4052327579651453D-10 , - 0.8844724206900825D-13 , & 0.7261835439209481D-16 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.6066160204845350D-06 , - 0.7859754539905226D-08 , & 0.3833664848662661D-10 , - 0.8339429088022428D-13 , 0.6823963638575642D-16 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.5777552277543611D-06 , - 0.7460980856815078D-08 , 0.3627042990546453D-10 , & - 0.7863607886236453D-13 , 0.6413057285981828D-16 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.5502935040793943D-06 , & - 0.7082844489309142D-08 , 0.3431788676171217D-10 , - 0.7415512388886407D-13 , & 0.6027426180923601D-16 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.5241621729719519D-06 , - 0.6724261457965927D-08 , & 0.3247266116731100D-10 , - 0.6993498296317194D-13 , 0.5665486689396603D-16 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.4992959755832648D-06 , - 0.6384205619889370D-08 , 0.3072875695696299D-10 , & - 0.6596020600227716D-13 , 0.5325756271056872D-16 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.4756329094103615D-06 , & - 0.6061705677220479D-08 , 0.2908051944710451D-10 , - 0.6221627628362383D-13 , & 0.5006847025434897D-16 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.4531139409993700D-06 , - 0.5755840616018058D-08 , & 0.2752260796663496D-10 , - 0.5868953641664169D-13 , 0.4707458187239918D-16 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.4316830322595507D-06 , - 0.5465739264928595D-08 , 0.2604998882156073D-10 , & - 0.5536715970653697D-13 , 0.4426372435653509D-16 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.4112868865166470D-06 , & - 0.5190576267920261D-08 , 0.2465791111057251D-10 , - 0.5223708525738121D-13 , & 0.4162449350395154D-16 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.3918748376071312D-06 , - 0.4929569960694725D-08 , & 0.2334189213910411D-10 , - 0.4928797483088837D-13 , 0.3914620739985391D-16 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.3733986775802868D-06 , - 0.4681979504241853D-08 , 0.2209769954884426D-10 , & - 0.4650916351202438D-13 , 0.3681885562075224D-16 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.3558126870520281D-06 , & - 0.4447104645242409D-08 , 0.2092134631668557D-10 , - 0.4389063864768057D-13 , & 0.3463307196456352D-16 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.3390605293004680D-06 , - 0.4224111138887318D-08 , & 0.1980821808378639D-10 , - 0.4142109951045993D-13 , 0.3257851518682950D-16 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.3231270019781537D-06 , - 0.4012718456965538D-08 , 0.1875649965202646D-10 , & - 0.3909554377224691D-13 , 0.3065016662644364D-16 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.3079593628669777D-06 , & - 0.3812152154586099D-08 , 0.1776194315079641D-10 , - 0.3690365415541319D-13 , & 0.2883866215511710D-16 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.2935201506449313D-06 , - 0.3621847194965729D-08 , & 0.1682137942219267D-10 , - 0.3483758871161782D-13 , 0.2713677236097656D-16 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.2797738371841370D-06 , - 0.3441269449111665D-08 , 0.1593182254226530D-10 , & - 0.3288998342985318D-13 , 0.2553773108042110D-16 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.2666866200782901D-06 , & - 0.3269912645086799D-08 , 0.1509045276205902D-10 , - 0.3105390939746759D-13 , & 0.2403519476663196D-16 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.2542263631419570D-06 , - 0.3107297211693183D-08 , & 0.1429460860630892D-10 , - 0.2932284978686017D-13 , 0.2262321808980881D-16 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.2423624696501339D-06 , - 0.2952968309713719D-08 , 0.1354177533355740D-10 , & - 0.2769066972038498D-13 , 0.2129622443969842D-16 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.2310659653403470D-06 , & - 0.2806496489129293D-08 , 0.1282958579009273D-10 , - 0.2615161228893413D-13 , & 0.2004899726324414D-16 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.2203092002063100D-06 , - 0.2667473640581361D-08 , & 0.1215579947791046D-10 , - 0.2470024976742710D-13 , 0.1887663689528137D-16 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.2100659165482535D-06 , - 0.2535513515655994D-08 , 0.1151830307279803D-10 , & - 0.2333147976215202D-13 , 0.1777455283165094D-16 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.2003111490387998D-06 , & - 0.2410250181652392D-08 , 0.1091510143403127D-10 , - 0.2204050195873824D-13 , & 0.1673844122246308D-16 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.1910212133967529D-06 , - 0.2291337584908674D-08 , & 0.1034431385628825D-10 , - 0.2082280598629659D-13 , 0.1576427129249444D-16 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.1821734534423512D-06 , - 0.2178446182940772D-08 , 0.9804156993257226D-11 , & - 0.1967413238137932D-13 , 0.1484825144861768D-16 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.1737464496326749D-06 , & - 0.2071265232782974D-08 , 0.9292953856089014D-11 , - 0.1859048714204813D-13 , & 0.1398683682576671D-16 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.1657197986612078D-06 , - 0.1969499852155541D-08 , & 0.8809118905480828D-11 , - 0.1756810767092072D-13 , 0.1317669976988216D-16 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.1580740539875769D-06 , - 0.1872870072748835D-08 , 0.8351152431194131D-11 , & - 0.1660344805240587D-13 , 0.1241471549134528D-16 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.1507908441614216D-06 , & - 0.1781112046651811D-08 , 0.7917644751168665D-11 , - 0.1569318432677395D-13 , & 0.1169796306886297D-16 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.1438525927296563D-06 , - 0.1693974457346856D-08 , & 0.7507258748428295D-11 , - 0.1483417625576010D-13 , 0.1102369368444090D-16 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.1372426180956844D-06 , - 0.1611219533079628D-08 , 0.7118733372500701D-11 , & - 0.1402347165417745D-13 , 0.1038933136623794D-16 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.1309450569291264D-06 , & - 0.1532621940344241D-08 , 0.6750877591431427D-11 , - 0.1325829161776890D-13 , & 0.9792459421715904D-17 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.1249448781819969D-06 , - 0.1457968772624572D-08 , & 0.6402569335663745D-11 , - 0.1253602592415793D-13 , 0.9230814697701616D-17 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.1192276456079111D-06 , - 0.1387056561280158D-08 , 0.6072741213734994D-11 , & - 0.1185420231829681D-13 , 0.8702262517536900D-17 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.1137797572368366D-06 , & - 0.1319693969453165D-08 , 0.5760391682112781D-11 , - 0.1121050659188707D-13 , & 0.8204809723065052D-17 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.1085882390540484D-06 , - 0.1255699191012446D-08 , & 0.5464572603473299D-11 , - 0.1060275582621243D-13 , 0.7736582856461535D-17 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.1036407522561919D-06 , - 0.1194899901441320D-08 , 0.5184388273367377D-11 , & - 0.1002889461185403D-13 , 0.7295823661186674D-17 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 ], shape = [ ntx_al + 1 , npf + 1 , ngrd + 1 ]) real ( kind = 8 ), public , parameter :: xgrid ( 0 : ntx_al , 0 : npx ) = reshape ([ & 0.1000000000000002D+01 , - 0.3611521804789727D-01 , 0.6521544875763918D-03 , & - 0.7851060511361206D-05 , 0.7088540166271935D-07 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.9999999996488655D+00 , & - 0.3611521602834190D-01 , 0.6521499739451746D-03 , - 0.7846060914505879D-05 , & 0.6837103663170047D-07 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.9999999857613000D+00 , - 0.3611518120587972D-01 , & 0.6521166025751763D-03 , - 0.7831537944047128D-05 , 0.6594585825069580D-07 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.9999998902444154D+00 , - 0.3611503186317466D-01 , 0.6520283564989865D-03 , & - 0.7808173494582328D-05 , 0.6360670299394732D-07 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.9999995441624123D+00 , & - 0.3611464095414269D-01 , 0.6518620964067741D-03 , - 0.7776613068080583D-05 , & 0.6135051954862591D-07 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.9999986403332588D+00 , - 0.3611384315809781D-01 , & 0.6515973539174863D-03 , - 0.7737467497690540D-05 , 0.5917436483454416D-07 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.9999967038582842D+00 , - 0.3611244128986202D-01 , 0.6512161371478471D-03 , & - 0.7691314595046865D-05 , 0.5707540016505309D-07 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.9999930696939034D+00 , & - 0.3611021211218662D-01 , 0.6507027479223964D-03 , - 0.7638700724333661D-05 , & 0.5505088754411531D-07 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.9999868664503488D+00 , - 0.3610691159392973D-01 , & 0.6500436100005023D-03 , - 0.7580142306228217D-05 , 0.5309818609472401D-07 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.9999770056725089D+00 , - 0.3610227965469983D-01 , 0.6492271077274293D-03 , & - 0.7516127254719005D-05 , 0.5121474861400895D-07 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.9999621759230846D+00 , & - 0.3609604443409548D-01 , 0.6482434345462154D-03 , - 0.7447116349667743D-05 , & 0.4939811825053579D-07 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.9999408410486373D+00 , - 0.3608792612124097D-01 , & 0.6470844508353548D-03 , - 0.7373544547866152D-05 , 0.4764592529946437D-07 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.9999112420649808D+00 , - 0.3607764037802694D-01 , 0.6457435505642123D-03 , & - 0.7295822235223767D-05 , 0.4595588411138549D-07 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.9998714021501020D+00 , & - 0.3606490138730765D-01 , 0.6442155362837079D-03 , - 0.7214336422613530D-05 , & 0.4432579011080377D-07 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.9998191342806275D+00 , - 0.3604942455527483D-01 , & 0.6424965019942149D-03 , - 0.7129451887796671D-05 , 0.4275351692037754D-07 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.9997520510920613D+00 , - 0.3603092889531422D-01 , 0.6405837234558510D-03 , & - 0.7041512265747561D-05 , 0.4123701358716433D-07 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.9996675765838184D+00 , & - 0.3600913911885142D-01 , 0.6384755555284542D-03 , - 0.6950841089602322D-05 , & 0.3977430190725368D-07 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.9995629593277358D+00 , - 0.3598378745699816D-01 , & 0.6361713361495887D-03 , - 0.6857742784362254D-05 , 0.3836347384529769D-07 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.9994352868734384D+00 , - 0.3595461523521653D-01 , 0.6336712965789662D-03 , & - 0.6762503615394005D-05 , 0.3700268904557278D-07 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.9992815010758829D+00 , & - 0.3592137422171983D-01 , 0.6309764775567380D-03 , - 0.6665392593683018D-05 , & 0.3569017243132630D-07 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.9990984140997982D+00 , - 0.3588382776891923D-01 , & 0.6280886510412604D-03 , - 0.6566662339714887D-05 , 0.3442421188927639D-07 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.9988827248827350D+00 , - 0.3584175176590054D-01 , 0.6250102472092035D-03 , & - 0.6466549907780633D-05 , 0.3320315603624449D-07 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.9986310358632349D+00 , & - 0.3579493541867145D-01 , 0.6217442864173015D-03 , - 0.6365277572426582D-05 , & 0.3202541206500726D-07 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.9983398698033363D+00 , - 0.3574318187375038D-01 , & 0.6182943158406733D-03 , - 0.6263053578697257D-05 , 0.3088944366655810D-07 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.9980056865554513D+00 , - 0.3568630869957054D-01 , 0.6146643505175048D-03 , & - 0.6160072857750353D-05 , 0.2979376902606765D-07 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.9976248996426590D+00 , & - 0.3562414823914290D-01 , 0.6108588185440213D-03 , - 0.6056517709356436D-05 , & 0.2873695888992932D-07 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.9971938925388306D+00 , - 0.3555654784645532D-01 , & 0.6068825101771280D-03 , - 0.5952558452732234D-05 , 0.2771763470136841D-07 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.9967090345508339D+00 , - 0.3548337001817838D-01 , 0.6027405306148762D-03 , & - 0.5848354047095279D-05 , 0.2673446680218262D-07 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.9961666962194663D+00 , & - 0.3540449243139892D-01 , 0.5984382562370684D-03 , - 0.5744052683269072D-05 , & 0.2578617269826847D-07 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.9955632641688638D+00 , - 0.3531980789730607D-01 , & 0.5939812940998690D-03 , - 0.5639792347611693D-05 , 0.2487151538667085D-07 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.9948951553459882D+00 , - 0.3522922424000792D-01 , 0.5893754444892714D-03 , & - 0.5535701359486962D-05 , 0.2398930174197364D-07 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.9941588306025444D+00 , & - 0.3513266410895925D-01 , 0.5846266663487061D-03 , - 0.5431898883445553D-05 , & 0.2313838095992633D-07 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.9933508075813602D+00 , - 0.3503006473282644D-01 , & 0.5797410454059956D-03 , - 0.5328495417233926D-05 , 0.2231764305627656D-07 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.9924676728780009D+00 , - 0.3492137762200434D-01 , 0.5747247648342804D-03 , & - 0.5225593256701512D-05 , 0.2152601741885035D-07 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.9915060934562149D+00 , & - 0.3480656822642801D-01 , 0.5695840782904992D-03 , - 0.5123286938630988D-05 , & 0.2076247141099121D-07 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.9904628273028372D+00 , - 0.3468561555478778D-01 , & 0.5643252851835001D-03 , - 0.5021663662472900D-05 , 0.2002600902453652D-07 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.9893347333140262D+00 , - 0.3455851176075700D-01 , 0.5589547080319466D-03 , & - 0.4920803691924030D-05 , 0.1931566958057389D-07 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.9881187804102758D+00 , & - 0.3442526170137560D-01 , 0.5534786717798382D-03 , - 0.4820780737248802D-05 , & 0.1863052647628289D-07 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.9868120558825826D+00 , - 0.3428588247229820D-01 , & 0.5479034849447572D-03 , - 0.4721662319204600D-05 , 0.1796968597622724D-07 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.9854117729764578D+00 , - 0.3414040292420946D-01 , 0.5422354224808554D-03 , & - 0.4623510115395003D-05 , 0.1733228604652099D-07 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.9839152777243090D+00 , & - 0.3398886316433204D-01 , 0.5364807102451646D-03 , - 0.4526380289839663D-05 , & 0.1671749523034778D-07 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.9823200550399906D+00 , - 0.3383131404660054D-01 , & 0.5306455109620299D-03 , - 0.4430323806515685D-05 , 0.1612451156336634D-07 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.9806237340921983D+00 , - 0.3366781665374678D-01 , 0.5247359115863794D-03 , & - 0.4335386727592931D-05 , 0.1555256152758753D-07 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.9788240929758184D+00 , & - 0.3349844177423815D-01 , 0.5187579119721455D-03 , - 0.4241610497054601D-05 , & 0.1500089904235819D-07 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.9769190627024169D+00 , - 0.3332326937672677D-01 , & 0.5127174147574679D-03 , - 0.4149032210364663D-05 , 0.1446880449113570D-07 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.9749067305327729D+00 , - 0.3314238808440491D-01 , 0.5066202163833524D-03 , & - 0.4057684870815116D-05 , 0.1395558378278365D-07 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.9727853426757950D+00 , & - 0.3295589465141815D-01 , 0.5004719991672346D-03 , - 0.3967597633158782D-05 , & 0.1346056744616409D-07 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.9705533063792705D+00 , - 0.3276389344326150D-01 , & 0.4942783243574352D-03 , - 0.3878796035107068D-05 , 0.1298310975684544D-07 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.9682091914388110D+00 , - 0.3256649592287433D-01 , 0.4880446260987841D-03 , & - 0.3791302217247034D-05 , 0.1252258789478677D-07 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.9657517311519848D+00 , & - 0.3236382014395655D-01 , 0.4817762062437639D-03 , - 0.3705135131908079D-05 , & 0.1207840113189971D-07 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.9631798227450927D+00 , - 0.3215599025284886D-01 , & 0.4754782299473788D-03 , - 0.3620310741485451D-05 , 0.1164997004842826D-07 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.9604925273002942D+00 , - 0.3194313600015471D-01 , 0.4691557219876081D-03 , & - 0.3536842206705777D-05 , 0.1123673577712426D-07 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.9576890692108974D+00 , & - 0.3172539226312945D-01 , 0.4628135637567661D-03 , - 0.3454740065298578D-05 , & 0.1083815927423256D-07 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.9547688351925679D+00 , - 0.3150289857972088D-01 , & 0.4564564908723630D-03 , - 0.3374012401517544D-05 , 0.1045372061633503D-07 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.9517313728780417D+00 , - 0.3127579869501688D-01 , 0.4500890913591659D-03 , & - 0.3294665006935876D-05 , 0.1008291832213603D-07 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.9485763890226171D+00 , & - 0.3104424012073669D-01 , 0.4437158043570944D-03 , - 0.3216701532921467D-05 , & 0.9725268698304777D-08 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.9453037473473198D+00 , - 0.3080837370829358D-01 , & 0.4373409193123626D-03 , - 0.3140123635179827D-05 , 0.9380305208521232D-08 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.9419134660461329D+00 , - 0.3056835323585661D-01 , 0.4309685756119077D-03 , & - 0.3064931110735659D-05 , 0.9047577864902408D-08 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.9384057149831428D+00 , & - 0.3032433500974881D-01 , 0.4246027626236334D-03 , - 0.2991122027707642D-05 , & 0.8726652641015368D-08 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.9347808126047981D+00 , - 0.3007647748043467D-01 , & 0.4182473201073416D-03 , - 0.2918692848215320D-05 , 0.8417110905711109D-08 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.9310392225918197D+00 , - 0.2982494087327523D-01 , 0.4119059389634547D-03 , & - 0.2847638544742048D-05 , 0.8118548877040851D-08 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.9271815502745566D+00 , & - 0.2956988683415948D-01 , 0.4055821622887257D-03 , - 0.2777952710263590D-05 , & 0.7830577095542363D-08 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.9232085388348176D+00 , - 0.2931147809005866D-01 , & 0.3992793867101202D-03 , - 0.2709627662438244D-05 , 0.7552819916209288D-08 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.9191210653164068D+00 , - 0.2904987812449366D-01 , 0.3930008639699272D-03 , & - 0.2642654542141209D-05 , 0.7284915018480717D-08 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.9149201364657723D+00 , & - 0.2878525086785481D-01 , 0.3867497027369266D-03 , - 0.2577023406613337D-05 , & 0.7026512933611873D-08 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.9106068844233319D+00 , - 0.2851776040246799D-01 , & 0.3805288706201129D-03 , - 0.2512723317482369D-05 , 0.6777276588809340D-08 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.9061825622851837D+00 , - 0.2824757068225962D-01 , 0.3743411963630485D-03 , & - 0.2449742423903193D-05 , 0.6536880867536208D-08 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.9016485395540542D+00 , & - 0.2797484526683750D-01 , 0.3681893721984108D-03 , - 0.2388068041052664D-05 , & 0.6305012185413559D-08 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.8970062974974615D+00 , - 0.2769974706977139D-01 , & 0.3620759563436987D-03 , - 0.2327686724203913D-05 , 0.6081368081165092D-08 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.8922574244302182D+00 , - 0.2742243812082949D-01 , 0.3560033756203871D-03 , & - 0.2268584338595003D-05 , 0.5865656822071277D-08 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.8874036109375314D+00 , & - 0.2714307934190184D-01 , 0.3499739281800672D-03 , - 0.2210746125297084D-05 , & 0.5657597023418406D-08 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.8824466450541053D+00 , - 0.2686183033631973D-01 , & 0.3439897863222787D-03 , - 0.2154156763277922D-05 , 0.5456917281446073D-08 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.8773884074138170D+00 , - 0.2657884919126219D-01 , 0.3380529993898553D-03 , & - 0.2098800427847874D-05 , 0.5263355819314348D-08 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.8722308663837020D+00 , & - 0.2629429229292436D-01 , 0.3321654967286385D-03 , - 0.2044660845666816D-05 , & 0.5076660145628777D-08 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.8669760731951703D+00 , - 0.2600831415410914D-01 , & 0.3263290906993993D-03 , - 0.1991721346482490D-05 , 0.4896586725077795D-08 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.8616261570845866D+00 , - 0.2572106725389308D-01 , 0.3205454797307280D-03 , & - 0.1939964911762920D-05 , 0.4722900660752903D-08 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.8561833204545620D+00 , & - 0.2543270188900812D-01 , 0.3148162514025188D-03 , - 0.1889374220378159D-05 , & 0.4555375387737225D-08 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.8506498340665497D+00 , - 0.2514336603657411D-01 , & 0.3091428855504915D-03 , - 0.1839931691479488D-05 , 0.4393792377562729D-08 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.8450280322746013D+00 , - 0.2485320522781212D-01 , 0.3035267573829580D-03 , & - 0.1791619524717417D-05 , 0.4237940853150598D-08 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.8393203083094211D+00 , & - 0.2456236243236493D-01 , 0.2979691406017585D-03 , - 0.1744419737933323D-05 , & 0.4087617513862921D-08 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.8335291096211707D+00 , - 0.2427097795284919D-01 , & 0.2924712105199682D-03 , - 0.1698314202453361D-05 , 0.3942626270307020D-08 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.8276569332888037D+00 , - 0.2397918932926339D-01 , 0.2870340471696090D-03 , & - 0.1653284676107302D-05 , 0.3802777988546490D-08 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.8217063215030573D+00 , & - 0.2368713125287583D-01 , 0.2816586383931887D-03 , - 0.1609312834089310D-05 , & 0.3667890243385298D-08 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.8156798571296254D+00 , - 0.2339493548921945D-01 , & 0.2763458829134524D-03 , - 0.1566380297772197D-05 , 0.3537787080403101D-08 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.8095801593584224D+00 , - 0.2310273080982205D-01 , 0.2710965933762468D-03 , & - 0.1524468661581523D-05 , 0.3412298786431365D-08 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.8034098794442814D+00 , & - 0.2281064293230496D-01 , 0.2659114993618847D-03 , - 0.1483559518030909D-05 , & 0.3291261668170900D-08 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.7971716965438901D+00 , - 0.2251879446848712D-01 , & 0.2607912503608560D-03 , - 0.1443634481015220D-05 , 0.3174517838662009D-08 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.7908683136532269D+00 , - 0.2222730488013680D-01 , 0.2557364187101520D-03 , & - 0.1404675207453685D-05 , 0.3061915011328729D-08 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.7845024536492762D+00 , & - 0.2193629044201914D-01 , 0.2507475024868698D-03 , - 0.1366663417370720D-05 , & 0.2953306301328490D-08 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.7780768554393154D+00 , - 0.2164586421189354D-01 , & 0.2458249283561348D-03 , - 0.1329580912498055D-05 , 0.2848550033948074D-08 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.7715942702206158D+00 , - 0.2135613600712229D-01 , 0.2409690543707235D-03 , & - 0.1293409593477786D-05 , 0.2747509559795925D-08 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.7650574578529692D+00 , & - 0.2106721238755853D-01 , 0.2361801727200885D-03 , - 0.1258131475742227D-05 , & 0.2650053076549754D-08 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.7584691833460486D+00 , - 0.2077919664438952D-01 , & 0.2314585124267931D-03 , - 0.1223728704142753D-05 , 0.2556053457026894D-08 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.7518322134632162D+00 , - 0.2049218879461892D-01 , 0.2268042419886359D-03 , & - 0.1190183566396439D-05 , 0.2465388083353159D-08 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.7451493134430361D+00 , & - 0.2020628558087977D-01 , 0.2222174719650048D-03 , - 0.1157478505415926D-05 , & 0.2377938687013855D-08 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.7384232438394076D+00 , - 0.1992158047627856D-01 , & 0.2176982575062450D-03 , - 0.1125596130584843D-05 , 0.2293591194578342D-08 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.7316567574808988D+00 , - 0.1963816369397859D-01 , 0.2132466008250392D-03 , & - 0.1094519228038058D-05 , 0.2212235578896847D-08 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.7248525965495752D+00 , & - 0.1935612220124019D-01 , 0.2088624536090141D-03 , - 0.1064230770003192D-05 , & 0.2133765715575476D-08 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.7180134897793253D+00 , - 0.1907553973764343D-01 , & 0.2045457193739677D-03 , - 0.1034713923257039D-05 , 0.2058079244542167D-08 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.7111421497734108D+00 , - 0.1879649683722776D-01 , 0.2002962557572947D-03 , & - 0.1005952056747930D-05 , 0.1985077436523011D-08 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.7042412704407474D+00 , & - 0.1851907085429223D-01 , 0.1961138767513455D-03 , - 0.9779287484325860D-06 , & 0.1914665064254787D-08 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.6973135245501620D+00 , - 0.1824333599260796D-01 , & 0.1919983548766030D-03 , - 0.9506277913735763D-06 , 0.1846750278265676D-08 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.6903615614016858D+00 , - 0.1796936333780390D-01 , 0.1879494232947011D-03 , & - 0.9240331991412484D-06 , 0.1781244487062158D-08 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.6833880046137242D+00 , & - 0.1769722089269501D-01 , 0.1839667778614284D-03 , - 0.8981292105617887D-06 , & 0.1718062241565766D-08 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.6763954500247809D+00 , - 0.1742697361533108D-01 , & 0.1800500791199818D-03 , - 0.8729002938510132D-06 , 0.1657121123648976D-08 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.6693864637082331D+00 , - 0.1715868345955255D-01 , 0.1761989542348333D-03 , & - 0.8483311501714851D-06 , 0.1598341638624811D-08 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.6623635800985108D+00 , & - 0.1689240941784810D-01 , 0.1724129988666718D-03 , - 0.8244067166486717D-06 , & 0.1541647111549948D-08 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.6553293002268925D+00 , - 0.1662820756631741D-01 , & 0.1686917789889668D-03 , - 0.8011121688800414D-06 , 0.1486963587206019D-08 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.6482860900649963D+00 , - 0.1636613111155002D-01 , 0.1650348326467777D-03 , & - 0.7784329229692760D-06 , 0.1434219733628682D-08 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.6412363789739489D+00 , & - 0.1610623043923983D-01 , 0.1614416716585057D-03 , - 0.7563546371161323D-06 , & 0.1383346749058578D-08 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.6341825582570939D+00 , - 0.1584855316436221D-01 , & 0.1579117832613440D-03 , - 0.7348632127909166D-06 , 0.1334278272192828D-08 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.6271269798140200D+00 , - 0.1559314418274839D-01 , 0.1544446317012420D-03 , & - 0.7139447955210371D-06 , 0.1286950295619982D-08 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.6200719548936169D+00 , & - 0.1534004572389974D-01 , 0.1510396597682472D-03 , - 0.6935857753156824D-06 , & 0.1241301082325503D-08 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.6130197529437773D+00 , - 0.1508929740489116D-01 , & 0.1476962902781327D-03 , - 0.6737727867533005D-06 , 0.1197271085158870D-08 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.6059726005553269D+00 , - 0.1484093628522071D-01 , 0.1444139275012574D-03 , & - 0.6544927087552729D-06 , 0.1154802869157256D-08 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.5989326804976904D+00 , & - 0.1459499692246893D-01 , 0.1411919585396384D-03 , - 0.6357326640679290D-06 , & 0.1113841036624446D-08 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.5919021308437822D+00 , - 0.1435151142863873D-01 , & 0.1380297546532456D-03 , - 0.6174800184738844D-06 , 0.1074332154867269D-08 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.5848830441815519D+00 , - 0.1411050952705256D-01 , 0.1349266725365511D-03 , & - 0.5997223797525468D-06 , 0.1036224686495285D-08 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.5778774669096109D+00 , & - 0.1387201860969091D-01 , 0.1318820555463872D-03 , - 0.5824475964085867D-06 , & 0.9994689221927948D-09 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.5708873986143276D+00 , - 0.1363606379486140D-01 , & 0.1288952348821821D-03 , - 0.5656437561861328D-06 , 0.9640169158754858D-09 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.5639147915257812D+00 , - 0.1340266798509464D-01 , 0.1259655307196585D-03 , & - 0.5492991843855003D-06 , 0.9298224221471274D-09 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.5569615500499443D+00 , & - 0.1317185192516831D-01 , 0.1230922532990849D-03 , - 0.5334024419983248D-06 , & 0.8968408359747292D-09 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.5500295303744767D+00 , - 0.1294363426016670D-01 , & 0.1202747039691815D-03 , - 0.5179423236761046D-06 , 0.8650291345034716D-09 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.5431205401455020D+00 , - 0.1271803159348852D-01 , 0.1175121761877823D-03 , & - 0.5029078555463167D-06 , 0.8343458209355107D-09 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.5362363382127683D+00 , & - 0.1249505854472091D-01 , 0.1148039564803591D-03 , - 0.4882882928894737D-06 , & 0.8047508703994496D-09 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.5293786344405864D+00 , - 0.1227472780730275D-01 , & 0.1121493253575107D-03 , - 0.4740731176897362D-06 , 0.7762056777398644D-09 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.5225490895819784D+00 , - 0.1205705020590516D-01 , 0.1095475581925189D-03 , & - 0.4602520360709733D-06 , 0.7486730071587808D-09 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.5157493152134779D+00 , & - 0.1184203475346198D-01 , 0.1069979260600657D-03 , - 0.4468149756294780D-06 , & 0.7221169436434091D-09 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.5089808737280556D+00 , - 0.1162968870778726D-01 , & 0.1044996965372018D-03 , - 0.4337520826738971D-06 , 0.6965028461167792D-09 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.5022452783836778D+00 , - 0.1142001762772153D-01 , 0.1020521344676464D-03 , & - 0.4210537193823122D-06 , 0.6717973022501610D-09 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.4955439934050289D+00 , & - 0.1121302542875243D-01 , 0.9965450269048878D-04 , - 0.4087104608858226D-06 , & 0.6479680848783278D-09 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.4888784341359751D+00 , - 0.1100871443805956D-01 , & 0.9730606273435124D-04 , - 0.3967130922874212D-06 , 0.6249841099608065D-09 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.4822499672403789D+00 , - 0.1080708544893708D-01 , 0.9500607547805988D-04 , & - 0.3850526056244229D-06 , 0.6028153960342776D-09 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.4756599109489148D+00 , & - 0.1060813777455152D-01 , 0.9275380177885677D-04 , - 0.3737201967822001D-06 , & 0.5814330251032323D-09 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.4691095353495883D+00 , - 0.1041186930099543D-01 , & 0.9054850306917229D-04 , - 0.3627072623665039D-06 , 0.5608091049178724D-09 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.4626000627196905D+00 , - 0.1021827653960125D-01 , 0.8838944192296087D-04 , & - 0.3520053965411885D-06 , 0.5409167325900436D-09 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.4561326678969813D+00 , & - 0.1002735467848277D-01 , 0.8627588259258736D-04 , - 0.3416063878377317D-06 , & 0.5217299594997430D-09 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.4497084786879332D+00 , - 0.9839097633274584D-02 , & 0.8420709151723462D-04 , - 0.3315022159425287D-06 , 0.5032237574464226D-09 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.4433285763109229D+00 , - 0.9653498097043287D-02 , 0.8218233780378544D-04 , & - 0.3216850484675518D-06 , 0.4853739860009335D-09 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.4369939958723032D+00 , & - 0.9470547589346259D-02 , 0.8020089368111365D-04 , - 0.3121472377095966D-06 , & 0.4681573610155262D-09 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.4307057268733409D+00 , - 0.9290236504417284D-02 , & 0.7826203492870173D-04 , - 0.3028813174029897D-06 , 0.4515514242508255D-09 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.4244647137460607D+00 , - 0.9112554158460216D-02 , 0.7636504128048255D-04 , & - 0.2938799994702962D-06 , 0.4355345140801637D-09 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.4182718564160858D+00 , & - 0.8937488836034676D-02 , 0.7450919680478531D-04 , - 0.2851361707752581D-06 , & 0.4200857372330557D-09 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.4121280108906161D+00 , - 0.8765027835519823D-02 , & 0.7269379026124490D-04 , - 0.2766428898818902D-06 , 0.4051849415409561D-09 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.4060339898697437D+00 , - 0.8595157513644487D-02 , 0.7091811543551605D-04 , & - 0.2683933838233848D-06 , 0.3908126896497487D-09 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.3999905633793524D+00 , & - 0.8427863329074012D-02 , 0.6918147145261313D-04 , - 0.2603810448842044D-06 , & 0.3769502336646742D-09 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.3939984594239121D+00 , - 0.8263129885046119D-02 , & 0.6748316306967769D-04 , - 0.2525994273984951D-06 , 0.3635794906946259D-09 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.3880583646575168D+00 , - 0.8100940971049801D-02 , 0.6582250094895549D-04 , & - 0.2450422445677086D-06 , 0.3506830192639078D-09 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.3821709250715828D+00 , & - 0.7941279603543148D-02 , 0.6419880191174602D-04 , - 0.2377033653001006D-06 , & 0.3382439965606897D-09 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.3763367466976681D+00 , - 0.7784128065707500D-02 , & 0.6261138917406701D-04 , - 0.2305768110745562D-06 , 0.3262461964924768D-09 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.3705563963239320D+00 , - 0.7629467946236974D-02 , 0.6105959256475844D-04 , & - 0.2236567528309935D-06 , 0.3146739685199713D-09 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.3648304022238011D+00 , & - 0.7477280177163726D-02 , 0.5954274872672935D-04 , - 0.2169375078894063D-06 , & 0.3035122172417152D-09 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.3591592548954640D+00 , - 0.7327545070720747D-02 , & 0.5806020130203337D-04 , - 0.2104135368994258D-06 , 0.2927463827028818D-09 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.3535434078108652D+00 , - 0.7180242355245210D-02 , 0.5661130110143868D-04 , & - 0.2040794408221123D-06 , 0.2823624214025323D-09 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.3479832781729243D+00 , & - 0.7035351210126636D-02 , 0.5519540625913994D-04 , - 0.1979299579455308D-06 , & 0.2723467879745604D-09 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.3424792476797490D+00 , - 0.6892850299805119D-02 , & 0.5381188237324053D-04 , - 0.1919599609355073D-06 , 0.2626864175184288D-09 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.3370316632946657D+00 , - 0.6752717806826024D-02 , 0.5246010263261588D-04 , & - 0.1861644539228294D-06 , 0.2533687085566506D-09 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.3316408380209394D+00 , & - 0.6614931463958435D-02 , 0.5113944793074957D-04 , - 0.1805385696280125D-06 , & 0.2443815065967820D-09 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.3263070516800990D+00 , - 0.6479468585385548D-02 , & 0.4984930696711679D-04 , - 0.1750775665246347D-06 , 0.2357130882764859D-09 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.3210305516928345D+00 , - 0.6346306096976029D-02 , 0.4858907633667187D-04 , & - 0.1697768260421194D-06 , 0.2273521460709828D-09 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.3158115538614743D+00 , & - 0.6215420565646062D-02 , 0.4735816060797871D-04 , - 0.1646318498087374D-06 , & 0.2192877735429419D-09 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.3106502431531042D+00 , - 0.6086788227822633D-02 , & 0.4615597239050746D-04 , - 0.1596382569354949D-06 , 0.2115094511155704D-09 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.3055467744824206D+00 , - 0.5960385017019062D-02 , 0.4498193239160199D-04 , & - 0.1547917813414742D-06 , 0.2040070323503441D-09 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.3005012734934684D+00 , & - 0.5836186590534533D-02 , 0.4383546946360822D-04 , - 0.1500882691211057D-06 , & 0.1967707307114775D-09 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.2955138373394422D+00 , - 0.5714168355289793D-02 , & 0.4271602064163590D-04 , - 0.1455236759537604D-06 , 0.1897911067998707D-09 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.2905845354597830D+00 , - 0.5594305492811757D-02 , 0.4162303117241177D-04 , & - 0.1410940645559729D-06 , 0.1830590560398769D-09 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.2857134103538335D+00 , & - 0.5476572983380119D-02 , 0.4055595453466550D-04 , - 0.1367956021765315D-06 , & 0.1765657968028334D-09 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.2809004783503579D+00 , - 0.5360945629349489D-02 , & 0.3951425245147589D-04 , - 0.1326245581345973D-06 , 0.1703028589518580D-09 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.2761457303722713D+00 , - 0.5247398077660925D-02 , 0.3849739489498898D-04 , & - 0.1285773014009542D-06 , 0.1642620727929739D-09 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.2714491326959588D+00 , & - 0.5135904841557033D-02 , 0.3750486008390613D-04 , - 0.1246502982224249D-06 , & 0.1584355584181453D-09 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.2668106277046010D+00 , - 0.5026440321515042D-02 , & 0.3653613447412544D-04 , - 0.1208401097894360D-06 , 0.1528157154263259D-09 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.2622301346349567D+00 , - 0.4918978825412521D-02 , 0.3559071274290669D-04 , & - 0.1171433899466591D-06 , 0.1473952130091100D-09 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.2577075503170912D+00 , & - 0.4813494587940600D-02 , 0.3466809776691598D-04 , - 0.1135568829466054D-06 , & 0.1421669803880539D-09 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.2532427499065656D+00 , - 0.4709961789279694D-02 , & 0.3376780059449373D-04 , - 0.1100774212460103D-06 , 0.1371241975911939D-09 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.2488355876086402D+00 , - 0.4608354573052876D-02 , 0.3288934041247656D-04 , & - 0.1067019233447951D-06 , 0.1322602865567284D-09 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.2444858973940713D+00 , & - 0.4508647063572137D-02 , 0.3203224450789148D-04 , - 0.1034273916673605D-06 , & 0.1275689025522603D-09 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.2401934937061141D+00 , - 0.4410813382392839D-02 , & 0.3119604822482836D-04 , - 0.1002509104859261D-06 , 0.1230439258984064D-09 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.2359581721583718D+00 , - 0.4314827664191761D-02 , 0.3038029491678544D-04 , & - 0.9716964388560073D-07 , 0.1186794539859767D-09 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.2317797102231574D+00 , & - 0.4220664071984051D-02 , 0.2958453589477058D-04 , - 0.9418083377083325D-07 , & 0.1144697935763116D-09 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.2276578679100639D+00 , - 0.4128296811694540D-02 , & 0.2880833037143045D-04 , - 0.9128179791287113D-07 , 0.1104094533747324D-09 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.2235923884344645D+00 , - 0.4037700146098712D-02 , 0.2805124540146862D-04 , & - 0.8846992803782454D-07 , 0.1064931368674177D-09 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.2195829988756874D+00 , & - 0.3948848408148710D-02 , 0.2731285581860327D-04 , - 0.8574268795491209D-07 , & 0.1027157354123623D-09 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.2156294108246347D+00 , - 0.3861716013699578D-02 , & 0.2659274416930504D-04 , - 0.8309761172444356D-07 , 0.9907232157540491D-10 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.2117313210206400D+00 , - 0.3776277473650957D-02 , 0.2589050064354549D-04 , & - 0.8053230186507536D-07 , 0.9555814270263329D-10 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.2078884119773770D+00 , & - 0.3692507405519285D-02 , 0.2520572300277740D-04 , - 0.7804442759985784D-07 , & 0.9216861472078116D-10 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.2041003525976589D+00 , - 0.3610380544455520D-02 , & 0.2453801650535856D-04 , - 0.7563172314057781D-07 , 0.8889931615753033D-10 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.2003667987769825D+00 , - 0.3529871753723177D-02 , 0.2388699382962178D-04 , & - 0.7329198600988675D-07 , 0.8574598237391792D-10 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.1966873939956952D+00 , & - 0.3450956034651438D-02 , 0.2325227499478530D-04 , - 0.7102307540069233D-07 , & 0.8270450000132483D-10 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.1930617698996789D+00 , - 0.3373608536077866D-02 , & 0.2263348727988903D-04 , - 0.6882291057228091D-07 , 0.7977090157578892D-10 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.1894895468694655D+00 , - 0.3297804563295163D-02 , 0.2203026514093433D-04 , & - 0.6668946928262970D-07 , 0.7694136036264373D-10 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.1859703345777124D+00 , & - 0.3223519586516151D-02 , 0.2144225012639657D-04 , - 0.6462078625635877D-07 , & 0.7421218536473156D-10 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.1825037325349867D+00 , - 0.3150729248871081D-02 , & 0.2086909079127261D-04 , - 0.6261495168776732D-07 , 0.7157981650767942D-10 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.1790893306238179D+00 , - 0.3079409373951104D-02 , 0.2031044260981761D-04 , & - 0.6067010977839266D-07 , 0.6904081999595741D-10 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.1757267096209988D+00 , & - 0.3009535972911584D-02 , 0.1976596788711855D-04 , - 0.5878445730852647D-07 , & 0.6659188383366146D-10 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.1724154417081243D+00 , - 0.2941085251148724D-02 , & 0.1923533566964500D-04 , - 0.5695624224211909D-07 , 0.6422981350417794D-10 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.1691550909703727D+00 , - 0.2874033614562755D-02 , 0.1871822165491082D-04 , & - 0.5518376236450081D-07 , 0.6195152780309393D-10 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.1659452138835478D+00 , & - 0.2808357675420740D-02 , 0.1821430810037425D-04 , - 0.5346536395234706D-07 , & 0.5975405481891786D-10 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.1627853597894110D+00 , - 0.2744034257831822D-02 , & 0.1772328373169771D-04 , - 0.5179944047531443D-07 , 0.5763452805636738D-10 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.1596750713593436D+00 , - 0.2681040402847512D-02 , 0.1724484365048206D-04 , & - 0.5018443132877370D-07 , 0.5559018269716738D-10 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.1566138850463928D+00 , & - 0.2619353373199397D-02 , 0.1677868924158532D-04 , - 0.4861882059706783D-07 , & 0.5361835199348075D-10 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.1536013315257612D+00 , - 0.2558950657686426D-02 , & 0.1632452808012913D-04 , - 0.4710113584672356D-07 , 0.5171646378926713D-10 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.1506369361238137D+00 , - 0.2499809975223667D-02 , 0.1588207383829187D-04 , & - 0.4562994694904778D-07 , 0.4988203716503206D-10 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.1477202192356801D+00 , & - 0.2441909278564241D-02 , 0.1545104619198143D-04 , - 0.4420386493154259D-07 , & 0.4811267920158971D-10 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.1448506967315445D+00 , - 0.2385226757705859D-02 , & 0.1503117072747624D-04 , - 0.4282154085757572D-07 , 0.4640608185861761D-10 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.1420278803517181D+00 , - 0.2329740842993182D-02 , 0.1462217884811788D-04 , & - 0.4148166473374710D-07 , 0.4476001896393170D-10 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.1392512780905985D+00 , & - 0.2275430207926968D-02 , 0.1422380768113441D-04 , - 0.4018296444439646D-07 , & 0.4317234330955444D-10 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.1365203945696301D+00 , - 0.2222273771690738D-02 , & 0.1383579998466878D-04 , - 0.3892420471270100D-07 , 0.4164098385078767D-10 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.1338347313993792D+00 , - 0.2170250701405449D-02 , 0.1345790405508273D-04 , & - 0.3770418608781746D-07 , 0.4016394300463686D-10 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.1311937875308531D+00 , & - 0.2119340414122448D-02 , 0.1308987363460221D-04 , - 0.3652174395752838D-07 , & 0.3873929404406241D-10 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.1285970595961875D+00 , - 0.2069522578564697D-02 , & 0.1273146781936667D-04 , - 0.3537574758585701D-07 , 0.3736517858465920D-10 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.1260440422388404D+00 , - 0.2020777116626069D-02 , 0.1238245096794058D-04 , & - 0.3426509917512241D-07 , 0.3603980416048556D-10 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.1235342284334305D+00 , & - 0.1973084204638247D-02 , 0.1204259261034211D-04 , - 0.3318873295191136D-07 , & 0.3476144188587983D-10 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.1210671097953642D+00 , - 0.1926424274414554D-02 , & 0.1171166735764027D-04 , - 0.3214561427645075D-07 , 0.3352842420021410D-10 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.1186421768803981D+00 , - 0.1880778014079763D-02 , 0.1138945481216855D-04 , & - 0.3113473877487012D-07 , 0.3233914269264350D-10 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.1162589194742892D+00 , & - 0.1836126368694767D-02 , 0.1107573947839993D-04 , - 0.3015513149385142D-07 , & 0.3119204600401350D-10 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.1139168268726863D+00 , - 0.1792450540684691D-02 , & 0.1077031067452490D-04 , - 0.2920584607716914D-07 , 0.3008563780318824D-10 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.1116153881514209D+00 , - 0.1749731990078880D-02 , 0.1047296244477157D-04 , & - 0.2828596396363195D-07 , 0.2901847483516035D-10 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.1093540924273559D+00 , & - 0.1707952434570889D-02 , 0.1018349347250358D-04 , - 0.2739459360594313D-07 , & 0.2798916503839577D-10 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.1071324291099557D+00 , - 0.1667093849406439D-02 , & 0.9901706994129417D-05 , - 0.2653086971000541D-07 , 0.2699636572895811D-10 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.1049498881437407D+00 , - 0.1627138467107078D-02 , 0.9627410713853726D-05 , & - 0.2569395249420232D-07 , 0.2603878184904354D-10 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.1028059602417928D+00 , & - 0.1588068777037027D-02 , 0.9360416719299054D-05 , - 0.2488302696819615D-07 , & 0.2511516427764170D-10 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.1007001371104776D+00 , - 0.1549867524820545D-02 , & 0.9100541398023883D-05 , - 0.2409730223078983D-07 , 0.2422430820111884D-10 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.9863191166555302D-01 , - 0.1512517711616863D-02 , 0.8847605354960719D-05 , & - 0.2333601078640787D-07 , 0.2336505154159776D-10 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.9660077823983229D-01 , & - 0.1476002593259600D-02 , 0.8601433330795814D-05 , - 0.2259840787975871D-07 , & 0.2253627344108451D-10 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.9460623278257177D-01 , - 0.1440305679267313D-02 , & 0.8361854121310036D-05 , - 0.2188377084824874D-07 , 0.2173689279936425D-10 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.9264777305075361D-01 , - 0.1405410731731677D-02 , 0.8128700497698473D-05 , & - 0.2119139849172585D-07 , 0.2096586686375934D-10 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.9072489879243330D-01 , & - 0.1371301764089557D-02 , 0.7901809127884522D-05 , - 0.2052061045913775D-07 , & 0.2022218986890979D-10 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.8883711192232295D-01 , - 0.1337963039785070D-02 , & 0.7681020498842381D-05 , - 0.1987074665169823D-07 , 0.1950489172480189D-10 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.8698391668978084D-01 , - 0.1305379070827533D-02 , 0.7466178839940262D-05 , & - 0.1924116664216176D-07 , 0.1881303675133357D-10 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.8516481983937646D-01 , & - 0.1273534616250987D-02 , 0.7257132047314984D-05 , - 0.1863124910981489D-07 , & 0.1814572245776578D-10 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.8337933076420101D-01 , - 0.1242414680480855D-02 , & 0.7053731609287072D-05 , - 0.1804039129079975D-07 , 0.1750207836546777D-10 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.8162696165209174D-01 , - 0.1212004511613046D-02 , 0.6855832532824123D-05 , & - 0.1746800844339326D-07 , 0.1688126487242060D-10 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.7990722762493879D-01 , & - 0.1182289599610708D-02 , 0.6663293271058740D-05 , - 0.1691353332787233D-07 , & 0.1628247215799763D-10 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.7821964687124064D-01 , - 0.1153255674423598D-02 , & 0.6475975651866067D-05 , - 0.1637641570060321D-07 , 0.1570491912659343D-10 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.7656374077207413D-01 , - 0.1124888704034923D-02 , 0.6293744807504717D-05 , & - 0.1585612182200036D-07 , 0.1514785238872299D-10 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.7493903402064486D-01 , & - 0.1097174892440306D-02 , 0.6116469105323766D-05 , - 0.1535213397800739D-07 , & 0.1461054527826230D-10 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.7334505473557941D-01 , - 0.1070100677563375D-02 , & 0.5944020079537281D-05 , - 0.1486395001475982D-07 , 0.1409229690454811D-10 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.7178133456812304D-01 , - 0.1043652729112331D-02 , 0.5776272364066885D-05 , & - 0.1439108288609670D-07 , 0.1359243123810065D-10 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.7024740880340176D-01 , & - 0.1017817946381686D-02 , 0.5613103626451850D-05 , - 0.1393306021359493D-07 , & 0.1311029622877638D-10 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.6874281645590868D-01 , - 0.9925834560031955D-03 , & 0.5454394502825282D-05 , - 0.1348942385880734D-07 , 0.1264526295520080D-10 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.6726710035937042D-01 , - 0.9679366096499070D-03 , 0.5300028533954051D-05 , & - 0.1305972950739215D-07 , 0.1219672480437140D-10 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.6581980725114972D-01 , & - 0.9438649816970456D-03 , 0.5149892102339341D-05 , - 0.1264354626482865D-07 , & 0.1176409668036091D-10 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.6440048785133663D-01 , - 0.9203563668433664D-03 , & 0.5003874370373888D-05 , - 0.1224045626342015D-07 , 0.1134681424108849D-10 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.6300869693668029D-01 , - 0.8973987776964405D-03 , 0.4861867219551236D-05 , & - 0.1185005428029233D-07 , 0.1094433316216325D-10 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.6164399340951004D-01 , & - 0.8749804423252165D-03 , 0.4723765190721689D-05 , - 0.1147194736610128D-07 , & 0.1055612842683992D-10 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.6030594036179325D-01 , - 0.8530898017830653D-03 , & 0.4589465425388940D-05 , - 0.1110575448417219D-07 , 0.1018169364116034D-10 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.5899410513447492D-01 , - 0.8317155076043969D-03 , 0.4458867608040838D-05 , & - 0.1075110615979576D-07 , 0.9820540373387509D-11 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.5770805937224191D-01 , & - 0.8108464192778117D-03 , 0.4331873909507089D-05 , - 0.1040764413941591D-07 , & 0.9472197516870390D-11 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.5644737907385254D-01 , - 0.7904716016986232D-03 , & 0.4208388931336276D-05 , - 0.1007502105944820D-07 , 0.9136210675508543D-11 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.5521164463816966D-01 , - 0.7705803226034826D-03 , 0.4088319651183992D-05 , & - 0.9752900124474594D-08 , 0.8812141571014750D-11 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.5400044090603364D-01 , & - 0.7511620499897160D-03 , 0.3971575369203511D-05 , - 0.9440954794566051D-08 , & 0.8499567471202594D-11 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.5281335719810912D-01 , - 0.7322064495218796D-03 , & 0.3858067655429959D-05 , - 0.9138868481490389D-08 , 0.8198080638553142D-11 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.5164998734883648D-01 , - 0.7137033819279222D-03 , 0.3747710298148570D-05 , & - 0.8846334253568343D-08 , 0.7907287798341415D-11 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.5050992973661773D-01 , & - 0.6956429003872558D-03 , 0.3640419253237263D-05 , - 0.8563054548946644D-08 , & 0.7626809625628903D-11 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.4939278731036306D-01 , - 0.6780152479129166D-03 , & 0.3536112594473435D-05 , - 0.8288740897062267D-08 , 0.7356280250452839D-11 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.4829816761252281D-01 , - 0.6608108547299182D-03 , 0.3434710464794598D-05 , & - 0.8023113648077583D-08 , 0.7095346780566876D-11 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.4722568279872633D-01 , & - 0.6440203356517876D-03 , 0.3336135028502160D-05 , - 0.7765901710071303D-08 , & 0.6843668841110512D-11 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.4617494965414755D-01 , - 0.6276344874571950D-03 , & 0.3240310424397464D-05 , - 0.7516842293775505D-08 , 0.6600918130606860D-11 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.4514558960671437D-01 , - 0.6116442862684934D-03 , 0.3147162719838932D-05 , & - 0.7275680664654041D-08 , 0.6366777992709532D-11 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.4413722873727634D-01 , & - 0.5960408849338984D-03 , 0.3056619865708985D-05 , - 0.7042169902122662D-08 , & 0.6140943003140038D-11 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.4314949778684314D-01 , - 0.5808156104149529D-03 , & 0.2968611652279207D-05 , - 0.6816070665716180D-08 , 0.5923118571276853D-11 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.4218203216100358D-01 , - 0.5659599611808455D-03 , 0.2883069665962093D-05 , & - 0.6597150968012762D-08 , 0.5713020555876458D-11 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.4123447193163272D-01 , & - 0.5514656046110673D-03 , 0.2799927246937568D-05 , - 0.6385185954130193D-08 , & 0.5510374894425087D-11 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.4030646183599215D-01 , - 0.5373243744078176D-03 , & 0.2719119447642320D-05 , - 0.6179957687613585D-08 , 0.5314917245637667D-11 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.3939765127332598D-01 , - 0.5235282680194966D-03 , 0.2640582992109947D-05 , & - 0.5981254942538559D-08 , 0.5126392644637643D-11 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.3850769429905331D-01 , & - 0.5100694440765516D-03 , 0.2564256236149774D-05 , - 0.5788873001658338D-08 , & 0.4944555170367839D-11 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.3763624961665465D-01 , - 0.4969402198408729D-03 , & 0.2490079128352154D-05 , - 0.5602613460427575D-08 , 0.4769167624798563D-11 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.3678298056734832D-01 , - 0.4841330686698687D-03 , 0.2417993171908017D-05 , & - 0.5422284036739955D-08 , 0.4600001223514452D-11 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.3594755511765001D-01 , & - 0.4716406174962903D-03 , 0.2347941387230378D-05 , - 0.5247698386220824D-08 , & 0.4436835297276472D-11 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.3512964584490655D-01 , - 0.4594556443248063D-03 , & 0.2279868275365502D-05 , - 0.5078675922920124D-08 , 0.4279457004169761D-11 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.3432892992089297D-01 , - 0.4475710757462760D-03 , 0.2213719782181393D-05 , & - 0.4915041645254955D-08 , 0.4127661051961841D-11 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.3354508909355868D-01 , & - 0.4359799844706035D-03 , 0.2149443263321291D-05 , - 0.4756625967054900D-08 , & 0.3981249430309002D-11 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.3277780966700801D-01 , - 0.4246755868790107D-03 , & 0.2086987449909877D-05 , - 0.4603264553567158D-08 , 0.3840031152461568D-11 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.3202678247979636D-01 , - 0.4136512405964990D-03 , 0.2026302414999855D-05 , & - 0.4454798162282170D-08 , 0.3703822006131082D-11 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.3129170288162239D-01 , & - 0.4029004420852326D-03 , 0.1967339540746693D-05 , - 0.4311072488444114D-08 , & 0.3572444313194455D-11 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.3057227070849394D-01 , - 0.3924168242595152D-03 , & 0.1910051486299285D-05 , - 0.4171938015114183D-08 , 0.3445726697921596D-11 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.2986819025644322D-01 , - 0.3821941541229908D-03 , 0.1854392156394349D-05 , & - 0.4037249867658047D-08 , 0.3323503863424224D-11 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.2917917025386491D-01 , & - 0.3722263304286495D-03 , 0.1800316670642472D-05 , - 0.3906867672532267D-08 , & 0.3205616376034207D-11 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.2850492383254884D-01 , - 0.3625073813621768D-03 , & 0.1747781333493744D-05 , - 0.3780655420247795D-08 , 0.3091910457330202D-11 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.2784516849747629D-01 , - 0.3530314622491392D-03 , 0.1696743604870992D-05 , & - 0.3658481332391880D-08 , 0.2982237783541271D-11 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.2719962609544814D-01 , & - 0.3437928532864659D-03 , 0.1647162071458754D-05 , - 0.3540217732592900D-08 , & 0.2876455292065835D-11 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.2656802278260952D-01 , - 0.3347859572986336D-03 , & 0.1598996418636144D-05 , - 0.3425740921315702D-08 , 0.2774424994853548D-11 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.2595008899093519D-01 , - 0.3260052975189368D-03 , 0.1552207403041925D-05 , & - 0.3314931054378070D-08 , 0.2676013798406687D-11 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.2534555939373704D-01 , & - 0.3174455153961828D-03 , 0.1506756825760147D-05 , - 0.3207672025081854D-08 , & 0.2581093330166234D-11 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.2475417287025363D-01 , - 0.3091013684271167D-03 , & 0.1462607506114851D-05 , - 0.3103851349855189D-08 , 0.2489539771056203D-11 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.2417567246937962D-01 , - 0.3009677280148480D-03 , 0.1419723256062425D-05 , & - 0.3003360057305016D-08 , 0.2401233693967743D-11 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.2360980537259142D-01 , & - 0.2930395773535218D-03 , 0.1378068855170303D-05 , - 0.2906092580581855D-08 , & 0.2316059907972365D-11 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.2305632285612325D-01 , - 0.2853120093394420D-03 , & 0.1337610026170852D-05 , - 0.2811946652961449D-08 , 0.2233907308061046D-11 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.2251498025244653D-01 , - 0.2777802245088282D-03 , 0.1298313411079358D-05 , & - 0.2720823206550494D-08 , 0.2154668730213213D-11 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.2198553691110327D-01 , & - 0.2704395290023589D-03 , 0.1260146547865190D-05 , - 0.2632626274026192D-08 , & 0.2078240811606563D-11 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.2146775615894295D-01 , - 0.2632853325566259D-03 , & 0.1223077847665324D-05 , - 0.2547262893321868D-08 , 0.2004523855785347D-11 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.2096140525981045D-01 , - 0.2563131465226018D-03 , 0.1187076572529540D-05 , & - 0.2464643015173267D-08 , 0.1933421702611252D-11 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.2046625537373107D-01 , & - 0.2495185819111939D-03 , 0.1152112813686741D-05 , - 0.2384679413442521D-08 , & 0.1864841602827244D-11 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.1998208151563710D-01 , - 0.2428973474659398D-03 , & 0.1118157470321968D-05 , - 0.2307287598139049D-08 , 0.1798694097070723D-11 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.1950866251367902D-01 , - 0.2364452477628728D-03 , 0.1085182228853840D-05 , & - 0.2232385731058896D-08 , 0.1734892899178192D-11 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.1904578096716238D-01 , & - 0.2301581813375669D-03 , 0.1053159542702252D-05 , - 0.2159894543966203D-08 , & 0.1673354783629206D-11 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.1859322320415089D-01 , - 0.2240321388393515D-03 , & 0.1022062612536332D-05 , - 0.2089737259242580D-08 , 0.1613999476982785D-11 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.1815077923877371D-01 , - 0.2180632012126644D-03 , 0.9918653669927850D-06 , & - 0.2021839512932274D-08 , 0.1556749553164653D-11 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.1771824272827434D-01 , & - 0.2122475379054946D-03 , 0.9625424438548905D-06 , - 0.1956129280112986D-08 , & 0.1501530332468749D-11 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.1729541092983677D-01 , - 0.2065814051048506D-03 , & 0.9340691716825657D-06 , - 0.1892536802524195D-08 , 0.1448269784141220D-11 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.1688208465722337D-01 , - 0.2010611439991722D-03 , 0.9064215518840492D-06 , & - 0.1830994518386711D-08 , 0.1396898432419852D-11 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.1647806823725748D-01 , & - 0.1956831790675864D-03 , 0.8795762412199015D-06 , - 0.1771436994349089D-08 , & 0.1347349265906363D-11 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.1608316946618266D-01 , - 0.1904440163958982D-03 , & 0.8535105347301571D-06 , - 0.1713800859498303D-08 , 0.1299557650153332D-11 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.1569719956592901D-01 , - 0.1853402420191875D-03 , 0.8282023490756143D-06 , & - 0.1658024741373864D-08 , 0.1253461243351745D-11 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.1531997314031619D-01 , & - 0.1803685202908758D-03 , 0.8036302062843889D-06 , - 0.1604049203926295D-08 , & 0.1208999915009175D-11 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.1495130813122093D-01 , - 0.1755255922781088D-03 , & 0.7797732178949948D-06 , - 0.1551816687362507D-08 , 0.1166115667512520D-11 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.1459102577473645D-01 , - 0.1708082741832928D-03 , 0.7566110694873686D-06 , & - 0.1501271449822306D-08 , 0.1124752560472967D-11 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.1423895055734932D-01 , & - 0.1662134557916118D-03 , 0.7341240055933888D-06 , - 0.1452359510831786D-08 , & 0.1084856637754516D-11 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.1389491017215890D-01 , - 0.1617380989443393D-03 , & 0.7122928149785875D-06 , - 0.1405028596480948D-08 , 0.1046375857090854D-11 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.1355873547516281D-01 , - 0.1573792360377515D-03 , 0.6910988162868907D-06 , & - 0.1359228086274373D-08 , 0.1009260022198782D-11 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.1323026044163129D-01 , & - 0.1531339685474403D-03 , 0.6705238440403671D-06 , - 0.1314908961605229D-08 , & 0.9734607172996379D-12 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.1290932212259216D-01 , - 0.1489994655778123D-03 , & 0.6505502349861047D-06 , - 0.1272023755804325D-08 , 0.9389312439632955D-12 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.1259576060144691D-01 , - 0.1449729624365562D-03 , 0.6311608147824705D-06 , & - 0.1230526505717300D-08 , 0.9056265601923633D-12 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.1228941895073790D-01 , & - 0.1410517592338521D-03 , 0.6123388850171522D-06 , - 0.1190372704764399D-08 , & 0.8735032216671167D-12 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.1199014318908536D-01 , - 0.1372332195060887D-03 , & 0.5940682105495163D-06 , - 0.1151519257438567D-08 , 0.8425193250745231D-12 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.1169778223831214D-01 , - 0.1335147688638491D-03 , 0.5763330071699505D-06 , & - 0.1113924435198890D-08 , 0.8126344534474338D-12 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.1141218788077328D-01 , & - 0.1298938936639200D-03 , 0.5591179295689981D-06 , - 0.1077547833717652D-08 , & 0.7838096234426404D-12 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.1113321471690663D-01 , - 0.1263681397050743D-03 , & 0.5424080596092218D-06 , - 0.1042350331440461D-08 , 0.7560072344890237D-12 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.1086072012301983D-01 , - 0.1229351109473701D-03 , 0.5261888948928705D-06 , & - 0.1008294049420095D-08 , 0.7291910197394607D-12 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.1059456420932838D-01 , & - 0.1195924682547078D-03 , 0.5104463376185539D-06 , - 0.9753423123858340D-09 , & 0.7033259987625086D-12 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.1033460977825836D-01 , - 0.1163379281603809D-03 , & 0.4951666837202548D-06 , - 0.9434596110111870D-09 , 0.6783784319121544D-12 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.1008072228302717D-01 , - 0.1131692616553523D-03 , 0.4803366122821460D-06 , & - 0.9126115653439564D-09 , 0.6543157763161090D-12 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.9832769786514324D-02 , & - 0.1100842929989866D-03 , 0.4659431752227984D-06 , - 0.8827648893636728D-09 , & 0.6311066434252325D-12 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.9590622920434166D-02 , - 0.1070808985519641D-03 , & 0.4519737872424988D-06 , - 0.8538873566324263D-09 , 0.6087207580687180D-12 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.9354154844821282D-02 , - 0.1041570056311006D-03 , 0.4384162160275122D-06 , & - 0.8259477670061214D-09 , 0.5871289189616221D-12 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.9123241207839000D-02 , & - 0.1013105913857942D-03 , 0.4252585727052593D-06 , - 0.7989159143741475D-09 , & 0.5663029606132273D-12 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.8897760105920529D-02 , - 0.9853968169582047D-04 , & 0.4124893025444836D-06 , - 0.7727625553963855D-09 , 0.5462157165865458D-12 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.8677592044251892D-02 , - 0.9584235009019217D-04 , 0.4000971758946212D-06 , & - 0.7474593792073932D-09 , 0.5268409840610413D-12 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.8462619897604920D-02 , & - 0.9321671668680231D-04 , 0.3880712793586864D-06 , - 0.7229789780584843D-09 , & 0.5081534896523391D-12 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.8252728871528317D-02 , - 0.9066094715256572D-04 , & 0.3764010071941170D-06 , - 0.6992948188692896D-09 , 0.4901288564443420D-12 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.8047806463903949D-02 , - 0.8817325168377432D-04 , 0.3650760529361293D-06 , & - 0.6763812156612114D-09 , 0.4727435721907427D-12 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.7847742426875241D-02 , & - 0.8575188400638151D-04 , 0.3540864012382499D-06 , - 0.6542133028460059D-09 , & 0.4559749586444571D-12 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.7652428729153820D-02 , - 0.8339514039592954D-04 , & 0.3434223199248015D-06 , - 0.6327670093435112D-09 , 0.4398011419749682D-12 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.7461759518710183D-02 , - 0.8110135871683469D-04 , 0.3330743522502292D-06 , & - 0.6120190335033080D-09 , 0.4242010242349903D-12 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.7275631085853615D-02 , & - 0.7886891748074499D-04 , 0.3230333093602639D-06 , - 0.5919468188058451D-09 , & 0.4091542558392374D-12 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.7093941826706200D-02 , - 0.7669623492368558D-04 , & 0.3132902629500250D-06 , - 0.5725285303192861D-09 , 0.3946412090193899D-12 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.6916592207075172D-02 , - 0.7458176810170719D-04 , 0.3038365381142682D-06 , & - 0.5537430318890384D-09 , 0.3806429522206386D-12 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.6743484726727566D-02 , & - 0.7252401200475441D-04 , 0.2946637063850879D-06 , - 0.5355698640376078D-09 , & 0.3671412254064034D-12 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.6574523884070650D-02 , - 0.7052149868847102D-04 , & 0.2857635789524883D-06 , - 0.5179892225530853D-09 , 0.3541184162390147D-12 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.6409616141241203D-02 , - 0.6857279642366112D-04 , 0.2771282000633310D-06 , & - 0.5009819377452229D-09 , 0.3415575371052868D-12 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.6248669889606350D-02 , & - 0.6667650886312538D-04 , 0.2687498405942710D-06 , - 0.4845294543486733D-09 , & 0.3294422029570126D-12 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.6091595415678292D-02 , - 0.6483127422559425D-04 , & 0.2606209917943862D-06 , - 0.4686138120535868D-09 , 0.3177566099374756D-12 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.5938304867444875D-02 , - 0.6303576449648010D-04 , 0.2527343591933006D-06 , & - 0.4532176266443423D-09 , 0.3064855147660972D-12 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.5788712221117679D-02 , & - 0.6128868464517348D-04 , 0.2450828566706957D-06 , - 0.4383240717277660D-09 , & 0.2956142148543272D-12 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.5642733248298872D-02 , - 0.5958877185860912D-04 , & 0.2376596006831949D-06 , - 0.4239168610327519D-09 , 0.2851285291268419D-12 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.5500285483567872D-02 , - 0.5793479479083011D-04 , 0.2304579046446978D-06 , & - 0.4099802312637353D-09 , 0.2750147795230299D-12 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.5361288192488474D-02 , & - 0.5632555282828022D-04 , 0.2234712734563247D-06 , - 0.3964989254909974D-09 , & 0.2652597731546347D-12 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.5225662340036848D-02 , - 0.5475987537055686D-04 , & 0.2166933981822258D-06 , - 0.3834581770612935D-09 , 0.2558507850962826D-12 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.5093330559450554D-02 , - 0.5323662112635904D-04 , 0.2101181508675869D-06 , & - 0.3708436940127875D-09 , 0.2467755417864438D-12 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.4964217121498385D-02 , & - 0.5175467742436689D-04 , 0.2037395794952529D-06 , - 0.3586416439787624D-09 , & 0.2380222050171763D-12 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.4838247904170720D-02 , - 0.5031295953879255D-04 , & 0.1975519030774683D-06 , - 0.3468386395650370D-09 , 0.2295793564917661D-12 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.4715350362789684D-02 , - 0.4891041002934331D-04 , 0.1915495068793176D-06 , & - 0.3354217241864816D-09 , 0.2214359829301219D-12 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.4595453500538279D-02 , & - 0.4754599809534170D-04 , 0.1857269377705236D-06 , - 0.3243783583484589D-09 , & 0.2135814617024934D-12 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.4478487839407423D-02 , - 0.4621871894374893D-04 , & 0.1800788997023437D-06 , - 0.3136964063594464D-09 , 0.2060055469727743D-12 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.4364385391559570D-02 , - 0.4492759317084138D-04 , 0.1746002493063753D-06 , & - 0.3033641234615131D-09 , 0.1986983563333132D-12 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.4253079631107443D-02 , & - 0.4367166615729208D-04 , 0.1692859916121587D-06 , - 0.2933701433657240D-09 , & 0.1916503579137998D-12 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.4144505466306210D-02 , - 0.4245000747641191D-04 , & 0.1641312758805389D-06 , - 0.2837034661799396D-09 , 0.1848523579474097D-12 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.4038599212157194D-02 , - 0.4126171031530852D-04 , 0.1591313915498174D-06 , & - 0.2743534467168553D-09 , 0.1782954887779880D-12 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.3935298563421160D-02 , & - 0.4010589090872307D-04 , 0.1542817642917957D-06 , - 0.2653097831704936D-09 , & 0.1719711972926289D-12 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.3834542568038922D-02 , - 0.3898168798530845D-04 , & 0.1495779521748831D-06 , - 0.2565625061497240D-09 , 0.1658712337645609D-12 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.3736271600956961D-02 , - 0.3788826222611502D-04 , 0.1450156419315036D-06 , & - 0.2481019680577264D-09 , 0.1599876410917847D-12 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.3640427338355551D-02 , & - 0.3682479573505322D-04 , 0.1405906453271087D-06 , - 0.2399188328066558D-09 , & 0.1543127444174254D-12 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.3546952732276771D-02 , - 0.3579049152110510D-04 , & 0.1362988956281622D-06 , - 0.2320040658570909D-09 , 0.1488391411182599D-12 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.3455791985649649D-02 , - 0.3478457299205997D-04 , 0.1321364441665286D-06 , & - 0.2243489245721661D-09 , 0.1435596911483593D-12 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.3366890527709538D-02 , & - 0.3380628345955209D-04 , 0.1280994569977591D-06 , - 0.2169449488765947D-09 , & 0.1384675077252505D-12 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.3280194989808764D-02 , - 0.3285488565518186D-04 , & 0.1241842116508280D-06 , - 0.2097839522110919D-09 , 0.1335559483464480D-12 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.3195653181615440D-02 , - 0.3192966125750432D-04 , 0.1203870939669322D-06 , & - 0.2028580127729916D-09 , 0.1288186061246364D-12 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.3113214067697218D-02 , & - 0.3102991042967226D-04 , 0.1167045950250254D-06 , - 0.1961594650341368D-09 , & 0.1242493014302012D-12 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.3032827744486712D-02 , - 0.3015495136752413D-04 , & 0.1131333081518138D-06 , - 0.1896808915273925D-09 , 0.1198420738302069D-12 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.2954445417625206D-02 , - 0.2930411985790999D-04 , 0.1096699260139971D-06 , & - 0.1834151148933990D-09 , 0.1155911743133048D-12 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.2878019379681182D-02 , & - 0.2847676884705170D-04 , 0.1063112377905909D-06 , - 0.1773551901794351D-09 , & 0.1114910577904321D-12 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.2803502988240113D-02 , - 0.2767226801873668D-04 , & 0.1030541264232231D-06 , - 0.1714943973825145D-09 , 0.1075363758615153D-12 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.2730850644361949D-02 , - 0.2689000338214754D-04 , 0.9989556594234436D-07 , & - 0.1658262342290778D-09 , 0.1037219698387459D-12 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.2660017771402566D-02 , & - 0.2612937686913291D-04 , 0.9683261886734815D-07 , - 0.1603444091838784D-09 , & 0.1000428640173269D-12 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.2590960794195512D-02 , - 0.2538980594072793D-04 , & 0.9386243367864164D-07 , - 0.1550428346808859D-09 , 0.9649425918490986D-13 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.2523637118590206D-02 , - 0.2467072320273555D-04 , 0.9098224235976030D-07 , & - 0.1499156205692547D-09 , 0.9307152636125975D-13 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.2458005111342773D-02 , & - 0.2397157603018311D-04 , 0.8818935800766461D-07 , - 0.1449570677676158D-09 , & 0.8977020075997757D-13 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.2394024080355649D-02 , - 0.2329182620047155D-04 , & 0.8548117250940507D-07 , - 0.1401616621201604D-09 , 0.8658597596440668D-13 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.2331654255262001D-02 , - 0.2263094953503743D-04 , 0.8285515428338570D-07 , & - 0.1355240684481830D-09 , 0.8351469831012418D-13 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.2270856768351043D-02 , & - 0.2198843554935109D-04 , 0.8030884608350259D-07 , - 0.1310391247909485D-09 , & 0.8055236146669050D-13 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.2211593635830208D-02 , - 0.2136378711107693D-04 , & 0.7783986286447485D-07 , - 0.1267018368299360D-09 , 0.7769510121158833D-13 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.2153827739420223D-02 , - 0.2075652010622513D-04 , 0.7544588970673066D-07 , & - 0.1225073724906973D-09 , 0.7493919038953491D-13 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.2097522808278980D-02 , & - 0.2016616311312644D-04 , 0.7312467979924956D-07 , - 0.1184510567167437D-09 , & 0.7228103405059139D-13 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.2042643401250184D-02 , - 0.1959225708406514D-04 , & 0.7087405247880511D-07 , - 0.1145283664100503D-09 , 0.6971716476072778D-13 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.1989154889432683D-02 , - 0.1903435503440759D-04 , 0.6869189132408977D-07 , & - 0.1107349255329322D-09 , 0.6724423807872591D-13 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.1937023439066397D-02 , & - 0.1849202173906692D-04 , 0.6657614230324355D-07 , - 0.1070665003662107D-09 , & 0.6485902819352073D-13 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.1886215994730726D-02 , - 0.1796483343614715D-04 , & 0.6452481197334523D-07 , - 0.1035189949187447D-09 , 0.6255842371628849D-13 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.1836700262851352D-02 , - 0.1745237753761272D-04 , 0.6253596573046193D-07 , & - 0.1000884464835555D-09 , 0.6033942362179336D-13 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.1788444695511297D-02 , & - 0.1695425234683211D-04 , 0.6060772610888853D-07 , - 0.9677102133592020D-10 , & 0.5819913333369777D-13 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.1741418474562146D-02 , - 0.1647006678284720D-04 , & 0.5873827112824394D-07 , - 0.9356301056895499D-10 , 0.5613476094873014D-13 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.1695591496031302D-02 , - 0.1599944011122234D-04 , 0.5692583268712550D-07 , & - 0.9046082606234546D-10 , 0.5414361359478458D-13 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.1650934354821172D-02 , & - 0.1554200168133005D-04 , 0.5516869500205556D-07 , - 0.8746099658001872D-10 , & 0.5222309391820180D-13 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.1607418329696188D-02 , - 0.1509739066993276D-04 , & 0.5346519309048824D-07 , - 0.8456016399268219D-10 , 0.5037069669564925D-13 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.1565015368553550D-02 , - 0.1466525583092257D-04 , 0.5181371129667492D-07 , & - 0.8175507962128009D-10 , 0.4858400556618064D-13 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.1523698073973629D-02 , & - 0.1424525525108371D-04 , 0.5021268185921928D-07 , - 0.7904260069754260D-10 , & 0.4686068987921207D-13 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.1483439689045948D-02 , - 0.1383705611174475D-04 , & 0.4866058351918230D-07 , - 0.7641968693792149D-10 , 0.4519850165430314D-13 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.1444214083466679D-02 , - 0.1344033445619026D-04 , 0.4715594016762774D-07 , & - 0.7388339722732146D-10 , 0.4359527264877718D-13 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.1405995739903645D-02 , & - 0.1305477496270403D-04 , 0.4569731953152756D-07 , - 0.7143088640914924D-10 , & 0.4204891152935547D-13 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.1368759740624777D-02 , - 0.1268007072311830D-04 , & 0.4428333189697463D-07 , - 0.6905940217830978D-10 , 0.4055740114411598D-13 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.1332481754386041D-02 , - 0.1231592302674610D-04 , 0.4291262886867800D-07 , & - 0.6676628207388552D-10 , 0.3911879589121799D-13 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.1297138023574865D-02 , & - 0.1196204114957597D-04 , 0.4158390216474282D-07 , - 0.6454895056833635D-10 , & 0.3773121918096040D-13 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.1262705351605099D-02 , - 0.1161814214861069D-04 , & 0.4029588244576295D-07 , - 0.6240491625015594D-10 , 0.3639286098786277D-13 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.1229161090559598D-02 , - 0.1128395066123416D-04 , 0.3904733817728040D-07 , & - 0.6033176909701778D-10 , 0.3510197548957632D-13 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.1196483129076503D-02 , & - 0.1095919870949261D-04 , 0.3783707452469018D-07 , - 0.5832717783653533D-10 , & 0.3385687878954463D-13 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.1164649880475371D-02 , - 0.1064362550917857D-04 , & 0.3666393227969368D-07 , - 0.5638888739185204D-10 , 0.3265594672044346D-13 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.1133640271119300D-02 , - 0.1033697728360863D-04 , 0.3552678681742770D-07 , & - 0.5451471640936411D-10 , 0.3149761272553457D-13 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.1103433729009226D-02 , & - 0.1003900708198765D-04 , 0.3442454708341881D-07 , - 0.5270255486596269D-10 , & 0.3038036581516949D-13 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.1074010172606626D-02 , - 0.9749474602254543D-05 , & 0.3335615460953595D-07 , - 0.5095036175326539D-10 , 0.2930274859577806D-13 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.1045349999880860D-02 , - 0.9468146018306988D-05 , 0.3232058255813563D-07 , & - 0.4925616283638561D-10 , 0.2826335536877020D-13 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.1017434077577446D-02 , & - 0.9194793811504133D-05 , 0.3131683479361595D-07 , - 0.4761804848486549D-10 , & 0.2726083029687135D-13 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.9902437307035836D-03 , - 0.8929196606348796D-05 , & 0.3034394498061646D-07 , - 0.4603417157347310D-10 , 0.2629386563549957D-13 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.9637607322272679D-03 , - 0.8671139010252420D-05 , 0.2940097570812104D-07 , & - 0.4450274545063656D-10 , 0.2536120002687708D-13 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.9379672929863852D-03 , & - 0.8420411457288152D-05 , 0.2848701763874126D-07 , - 0.4302204197235787D-10 , & 0.2446161685465119D-13 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.9128460518042227D-03 , - 0.8176810055839395D-05 , & 0.2760118868247686D-07 , - 0.4159038959951764D-10 , 0.2359394265687818D-13 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.8883800658078372D-03 , - 0.7940136440052980D-05 , 0.2674263319426877D-07 , & - 0.4020617155654695D-10 , 0.2275704559529999D-13 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.8645528009457841D-03 , & - 0.7710197625008113D-05 , 0.2591052119467875D-07 , - 0.3886782404950699D-10 , & 0.2194983397891695D-13 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.8413481227017496D-03 , - 0.7486805865514131D-05 , & 0.2510404761304746D-07 , - 0.3757383454167879D-10 , 0.2117125483993063D-13 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.8187502870006483D-03 , - 0.7269778518451789D-05 , 0.2432243155250039D-07 , & - 0.3632274008482493D-10 , 0.2042029256019924D-13 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.7967439313038039D-03 , & - 0.7058937908574753D-05 , 0.2356491557618810D-07 , - 0.3511312570434363D-10 , & 0.1969596754641372D-13 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.7753140658898628D-03 , - 0.6854111197689669D-05 , & 0.2283076501416367D-07 , - 0.3394362283659136D-10 , 0.1899733495226661D-13 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.7544460653181334D-03 , - 0.6655130257134926D-05 , 0.2211926729031675D-07 , & - 0.3281290781670498D-10 , 0.1832348344594646D-13 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.7341256600710757D-03 , & - 0.6461831543479928D-05 , 0.2142973126879899D-07 , - 0.3171970041530695D-10 , & 0.1767353402135045D-13 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.7143389283727186D-03 , - 0.6274055977368413D-05 , & 0.2076148661939134D-07 , - 0.3066276242252831D-10 , 0.1704663885146419D-13 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.6950722881798109D-03 , - 0.6091648825430941D-05 , 0.2011388320127836D-07 , & - 0.2964089627783383D-10 , 0.1644198018241313D-13 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.6763124893425579D-03 , & - 0.5914459585193351D-05 , 0.1948629046470946D-07 , - 0.2865294374418152D-10 , & 0.1585876926674291D-13 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.6580466059318366D-03 , - 0.5742341872909537D-05 , & 0.1887809687004113D-07 , - 0.2769778462509522D-10 , 0.1529624533453718D-13 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.6402620287298211D-03 , - 0.5575153314248479D-05 , 0.1828870932366806D-07 , & - 0.2677433552327432D-10 , 0.1475367460103065D-13 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.6229464578809889D-03 , & - 0.5412755437766964D-05 , 0.1771755263036430D-07 , - 0.2588154863940773D-10 , & 0.1423034930942307D-13 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.6060878957005284D-03 , - 0.5255013571101001D-05 , & 0.1716406896156927D-07 , - 0.2501841060990208D-10 , 0.1372558680764529D-13 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.5896746396371930D-03 , - 0.5101796739810307D-05 , 0.1662771733916545D-07 , & - 0.2418394138227476D-10 , 0.1323872865787327D-13 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.5736952753877060D-03 , & - 0.4952977568811813D-05 , 0.1610797313430769D-07 , - 0.2337719312700205D-10 , & 0.1276913977762840D-13 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.5581386701598463D-03 , - 0.4808432186339449D-05 , & 0.1560432758087587D-07 , - 0.2259724918465122D-10 , 0.1231620761134363D-13 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.5429939660813958D-03 , - 0.4668040130368939D-05 , 0.1511628730313440D-07 , & - 0.2184322304716256D-10 , 0.1187934133131495D-13 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.5282505737521637D-03 , & - 0.4531684257447657D-05 , 0.1464337385719363D-07 , - 0.2111425737218335D-10 , & 0.1145797106699570D-13 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.5138981659363462D-03 , - 0.4399250653870963D-05 , & 0.1418512328587951D-07 , - 0.2040952302939078D-10 , 0.1105154716162857D-13 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.4999266713925202D-03 , - 0.4270628549147753D-05 , 0.1374108568662848D-07 , & - 0.1972821817777453D-10 , 0.1065953945524536D-13 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.4863262688386115D-03 , & - 0.4145710231699221D-05 , 0.1331082479203549D-07 , - 0.1906956737288284D-10 , & 0.1028143659309947D-13 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.4730873810492115D-03 , - 0.4024390966736125D-05 , & 0.1289391756269292D-07 , - 0.1843282070306689D-10 , 0.9916745358628784D-14 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.4602006690826657D-03 , - 0.3906568916261085D-05 , 0.1248995379196875D-07 , & - 0.1781725295379006D-10 , 0.9564990030078973D-14 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.4476570266353889D-03 , & - 0.3792145061143621D-05 , 0.1209853572238166D-07 , - 0.1722216279909746D-10 , & 0.9225711759947879D-14 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.4354475745209071D-03 , - 0.3681023125216909D-05 , & 0.1171927767324056D-07 , - 0.1664687201937066D-10 , 0.8898467976441570D-14 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.4235636552711600D-03 , - 0.3573109501346280D-05 , 0.1135180567922493D-07 , & - 0.1609072474451994D-10 , 0.8582831806161204D-14 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.4119968278576441D-03 , & - 0.3468313179420781D-05 , 0.1099575713959203D-07 , - 0.1555308672179398D-10 , & 0.8278391517267725D-14 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.4007388625300039D-03 , - 0.3366545676220075D-05 , & 0.1065078047770490D-07 , - 0.1503334460741241D-10 , 0.7984749982397949D-14 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.3897817357697337D-03 , - 0.3267720967110219D-05 , 0.1031653481058459D-07 , & - 0.1453090528125285D-10 , 0.7701524160631489D-14 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.3791176253566683D-03 , & - 0.3171755419522769D-05 , 0.9992689628197422D-08 , - 0.1404519518384767D-10 , & 0.7428344597832689D-14 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.3687389055460049D-03 , - 0.3078567728172891D-05 , & 0.9678924482197044D-08 , - 0.1357565967497066D-10 , 0.7164854944715977D-14 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.3586381423536110D-03 , - 0.2988078851973010D-05 , 0.9374928683848172D-08 , & - 0.1312176241311544D-10 , 0.6910711492005723D-14 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.3488080889474264D-03 , & - 0.2900211952599681D-05 , 0.9080401010867040D-08 , - 0.1268298475519114D-10 , & 0.6665582722084422D-14 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.3392416811427993D-03 , - 0.2814892334672280D-05 , & 0.8795049422920847D-08 , - 0.1225882517578146D-10 , 0.6429148876544300D-14 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.3299320329996333D-03 , - 0.2732047387503114D-05 , 0.8518590785535760D-08 , & - 0.1184879870533473D-10 , 0.6201101539078212D-14 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.3208724325192539D-03 , & - 0.2651606528379469D-05 , 0.8250750602170034D-08 , - 0.1145243638667256D-10 , & 0.5981143233165756D-14 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.3120563374389486D-03 , - 0.2573501147339079D-05 , & 0.7991262754215811D-08 , - 0.1106928474922440D-10 , 0.5768987034029810D-14 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.3034773711221604D-03 , - 0.2497664553401376D-05 , 0.7739869248699635D-08 , & - 0.1069890530041438D-10 , 0.5564356194357292D-14 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.2951293185423524D-03 , & - 0.2424031922217792D-05 , 0.7496319973458379D-08 , - 0.1034087403364500D-10 , & 0.5366983783295909D-14 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.2870061223586018D-03 , - 0.2352540245105245D-05 , & 0.7260372459573514D-08 , - 0.9994780952340318D-11 , 0.5176612338256022D-14 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.2791018790810051D-03 , - 0.2283128279427789D-05 , 0.7031791650852777D-08 , & - 0.9660229609528325D-11 , 0.4992993529063361D-14 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.2714108353240193D-03 , & - 0.2215736500292254D-05 , 0.6810349680154339D-08 , - 0.9336836662458973D-11 , & 0.4815887834024559D-14 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.2639273841458944D-03 , - 0.2150307053524517D-05 , & 0.6595825652354299D-08 , - 0.9024231441770504D-11 , 0.4645064227482887D-14 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.2566460614723810D-03 , - 0.2086783709893810D-05 , 0.6388005433764053D-08 , & - 0.8722055534732382D-11 , 0.4480299878456671D-14 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.2495615426029394D-03 , & - 0.2025111820553315D-05 , 0.6186681447809538D-08 , - 0.8429962382108244D-11 , & 0.4321379859967247D-14 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.2426686387976983D-03 , - 0.1965238273665997D-05 , & 0.5991652476789692D-08 , - 0.8147616888197011D-11 , 0.4168096868677299D-14 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.2359622939434502D-03 , - 0.1907111452185402D-05 , 0.5802723469536749D-08 , & - 0.7874695043624535D-11 , 0.4020250954473876D-14 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.2294375812969995D-03 , & - 0.1850681192761888D-05 , 0.5619705354805886D-08 , - 0.7610883560471796D-11 , & 0.3877649259643306D-14 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.2230897003042102D-03 , - 0.1795898745745442D-05 , & 0.5442414860226835D-08 , - 0.7355879519339168D-11 , 0.3740105767297813D-14 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.2169139734931305D-03 , - 0.1742716736256950D-05 , 0.5270674336654706D-08 , & - 0.7109390027958962D-11 , 0.3607441058725644D-14 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.2109058434396047D-03 , & - 0.1691089126300496D-05 , 0.5104311587762011D-08 , - 0.6871131890981154D-11 , & 0.3479482079348203D-14 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.2050608698038077D-03 , - 0.1640971177889859D-05 , & 0.4943159704718334D-08 , - 0.6640831290569071D-11 , 0.3356061912978866D-14 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.1993747264361712D-03 , - 0.1592319417163128D-05 , 0.4787056905808528D-08 , & - 0.6418223477453724D-11 , 0.3237019564089046D-14 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.1938431985511979D-03 , & - 0.1545091599459911D-05 , 0.4635846380844567D-08 , - 0.6203052472106646D-11 , & 0.3122199747797448D-14 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.1884621799676879D-03 , - 0.1499246675336283D-05 , & 0.4489376140230337D-08 , - 0.5995070775702132D-11 , 0.3011452687308594D-14 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.1832276704139319D-03 , - 0.1454744757493216D-05 , 0.4347498868542708D-08 , & - 0.5794039090550393D-11 , 0.2904633918536364D-14 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.1781357728964509D-03 , & - 0.1411547088594818D-05 , 0.4210071782496124D-08 , - 0.5599726049693394D-11 , & 0.2801604101657718D-14 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.1731826911308912D-03 , - 0.1369616009953313D-05 , & 0.4076956493161776D-08 , - 0.5411907955365111D-11 , 0.2702228839350753D-14 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.1683647270337117D-03 , - 0.1328914931058248D-05 , 0.3948018872316135D-08 , & - 0.5230368526027561D-11 , 0.2606378501480019D-14 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.1636782782733224D-03 , & - 0.1289408299927969D-05 , 0.3823128922797244D-08 , - 0.5054898651703295D-11 , & 0.2513928056000391D-14 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.1591198358793647D-03 , - 0.1251061574261952D-05 , & 0.3702160652750612D-08 , - 0.4885296157334060D-11 , 0.2424756905858921D-14 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.1546859819088467D-03 , - 0.1213841193373120D-05 , 0.3584991953650053D-08 , & - 0.4721365573904080D-11 , 0.2338748731681928D-14 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.1503733871678723D-03 , & - 0.1177714550879772D-05 , 0.3471504481982013D-08 , - 0.4562917917074857D-11 , & 0.2255791340042098D-14 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.1461788089877293D-03 , - 0.1142649968137277D-05 , & 0.3361583544485265D-08 , - 0.4409770473086568D-11 , 0.2175776517107687D-14 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.1420990890541241D-03 , - 0.1108616668390160D-05 , 0.3255117986840873D-08 , & - 0.4261746591689100D-11 , 0.2098599887482904D-14 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.1381311512883767D-03 , & - 0.1075584751625725D-05 , 0.3152000085710424D-08 , - 0.4118675485873368D-11 , & 0.2024160778055351D-14 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.1342719997794135D-03 , - 0.1043525170110788D-05 , & 0.3052125444023491D-08 , - 0.3980392038181055D-11 , 0.1952362086672904D-14 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.1305187167654165D-03 , - 0.1012409704593588D-05 , 0.2955392889418098D-08 , & - 0.3846736613378034D-11 , 0.1883110155478738D-14 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.1268684606640135D-03 , & - 0.9822109411533757D-06 , 0.2861704375740821D-08 , - 0.3717554877283750D-11 , & 0.1816314648739266D-14 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.1233184641499144D-03 , - 0.9529022486806381D-06 , & 0.2770964887515819D-08 , - 0.3592697621555506D-11 , 0.1751888435005625D-14 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.1198660322789221D-03 , - 0.9244577569713175D-06 , 0.2683082347294747D-08 , & - 0.3472020594233176D-11 , 0.1689747473454987D-14 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.1165085406572686D-03 , & - 0.8968523354188344D-06 , 0.2597967525802049D-08 , - 0.3355384335856130D-11 , & 0.1629810704263450D-14 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.1132434336552461D-03 , - 0.8700615722881098D-06 , & 0.2515533954792637D-08 , - 0.3242654020970263D-11 , 0.1571999942867490D-14 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.1100682226641286D-03 , - 0.8440617545561973D-06 , 0.2435697842541354D-08 , & - 0.3133699304848973D-11 , 0.1516239777976042D-14 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.1069804843953946D-03 , & - 0.8188298483045114D-06 , 0.2358377991885975D-08 , - 0.3028394175257578D-11 , & 0.1462457473200193D-14 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.1039778592212875D-03 , - 0.7943434796480327D-06 , & 0.2283495720747794D-08 , - 0.2926616809096254D-11 , 0.1410582872172140D-14 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.1010580495557657D-03 , - 0.7705809161872353D-06 , 0.2210974785056055D-08 , & - 0.2828249433761910D-11 , 0.1360548307029665D-14 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.9821881827491759D-04 , & - 0.7475210489688429D-06 , 0.2140741304004609D-08 , - 0.2733178193074594D-11 , & 0.1312288510146741D-14 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.9545798717593406D-04 , - 0.7251433749418830D-06 , & 0.2072723687571338D-08 , - 0.2641293017619049D-11 , 0.1265740528995127D-14 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.9277343547375107D-04 , - 0.7034279798958417D-06 , 0.2006852566232837D-08 , & - 0.2552487499356890D-11 , 0.1220843644025897D-14 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.9016309833449247D-04 , & - 0.6823555218680702D-06 , 0.1943060722808889D-08 , - 0.2466658770369571D-11 , & 0.1177539289463781D-14 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.8762496544486365D-04 , - 0.6619072150079186D-06 , & 0.1881283026373147D-08 , - 0.2383707385596858D-11 , 0.1135770976910991D-14 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.8515707961666204D-04 , - 0.6420648138853901D-06 , 0.1821456368168312D-08 , & - 0.2303537209439916D-11 , 0.1095484221660888D-14 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.8275753542559058D-04 , & - 0.6228105982324318D-06 , 0.1763519599465898D-08 , - 0.2226055306102396D-11 , & 0.1056626471625372D-14 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.8042447788357566D-04 , - 0.6041273581052720D-06 , & 0.1707413471312450D-08 , - 0.2151171833547009D-11 , 0.1019147038783264D-14 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.7815610114380987D-04 , - 0.5859983794565242D-06 , 0.1653080576105770D-08 , & - 0.2078799940949064D-11 , 0.9829970330602835D-15 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.7595064723775528D-04 , & - 0.5684074301060597D-06 , 0.1600465290946376D-08 , - 0.2008855669532328D-11 , & 0.9481292985543507D-15 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.7380640484335992D-04 , - 0.5513387460999400D-06 , & 0.1549513722711017D-08 , - 0.1941257856676257D-11 , 0.9144983520230378D-15 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.7172170808375648D-04 , - 0.5347770184469747D-06 , 0.1500173654796656D-08 , & - 0.1875928043187313D-11 , 0.8820603235529184D-15 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.6969493535572786D-04 , & - 0.5187073802227438D-06 , 0.1452394495484816D-08 , - 0.1812790383630541D-11 , & 0.8507728993334252D-15 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.6772450818723935D-04 , - 0.5031153940311814D-06 , & 0.1406127227877705D-08 , - 0.1751771559620964D-11 , 0.8205952664605685D-15 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.6580889012335333D-04 , - 0.4879870398140821D-06 , 0.1361324361358918D-08 , & - 0.1692800695977667D-11 , 0.7914880596985134D-15 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.6394658563985630D-04 , & - 0.4733087029991360D-06 , 0.1317939884532950D-08 , - 0.1635809279646559D-11 , & 0.7634133101295681D-15 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.6213613908394360D-04 , - 0.4590671629773443D-06 , & 0.1275929219599086D-08 , - 0.1580731081300891D-11 , 0.7363343956256006D-15 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.6037613364132092D-04 , - 0.4452495819009107D-06 , 0.1235249178116544D-08 , & - 0.1527502079531602D-11 , 0.7102159930762762D-15 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.5866519032909613D-04 , & - 0.4318434937929283D-06 , 0.1195857918119021D-08 , - 0.1476060387542368D-11 , & 0.6850240323118002D-15 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.5700196701384846D-04 , - 0.4188367939604135D-06 , & 0.1157714902538049D-08 , - 0.1426346182267081D-11 , 0.6607256516600585D-15 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.5538515745427638D-04 , - 0.4062177287024625D-06 , 0.1120780858895748D-08 , & - 0.1378301635830121D-11 , 0.6372891550801857D-15 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.5381349036783741D-04 , & - 0.3939748853055110D-06 , 0.1085017740228729D-08 , - 0.1331870849272408D-11 , & 0.6146839708166403D-15 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.5228572852080760D-04 , - 0.3820971823179013D-06 , & 0.1050388687206058D-08 , - 0.1286999788468723D-11 , 0.5928806115198551D-15 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.5080066784120016D-04 , - 0.3705738600961537D-06 , 0.1016857991405266D-08 , & - 0.1243636222164248D-11 , 0.5718506357814424D-15 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.4935713655399613D-04 , & - 0.3593944716155516D-06 , 0.9843910597114729D-09 , - 0.1201729662060589D-11 , & 0.5515666110337772D-15 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.4795399433815076D-04 , - 0.3485488735378289D-06 , & 0.9529543798057161D-09 , - 0.1161231304883870D-11 , 0.5320020777655640D-15 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.4659013150485308D-04 , - 0.3380272175289537D-06 , 0.9225154867096075D-09 , & - 0.1122093976369650D-11 , 0.5131315150067069D-15 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.4526446819652671D-04 , & - 0.3278199418201773D-06 , 0.8930429303543911D-09 , - 0.1084272077101592D-11 , & 0.4949303070374619D-15 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.4397595360607174D-04 , - 0.3179177630057024D-06 , & 0.8645062441434424D-09 , - 0.1047721530142828D-11 , 0.4773747112784422D-15 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.4272356521585905D-04 , - 0.3083116680704978D-06 , 0.8368759144781603D-09 , & - 0.1012399730401005D-11 , 0.4604418273195928D-15 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.4150630805599932D-04 , & - 0.2989929066419605D-06 , 0.8101233512181084D-09 , - 0.9782654956699056D-12 , & 0.4441095670477334D-15 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.4032321398141977D-04 , - 0.2899529834592925D-06 , & 0.7842208590471210D-09 , - 0.9452790192924130D-12 , 0.4283566258337028D-15 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.3917334096729250D-04 , - 0.2811836510546212D-06 , 0.7591416097179372D-09 , & - 0.9134018243913950D-12 , 0.4131624547415192D-15 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.3805577242236840D-04 , & - 0.2726769026400519D-06 , 0.7348596151487411D-09 , - 0.8825967196168371D-12 , & 0.3985072337233055D-15 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.3696961651978117D-04 , - 0.2644249651949969D-06 , & 0.7113497013457895D-09 , - 0.8528277563592472D-12 , 0.3843718457650126D-15 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.3591400554489548D-04 , - 0.2564202927482741D-06 , 0.6885874831270671D-09 , & - 0.8240601873809859D-12 , 0.3707378519492165D-15 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.3488809525978360D-04 , & - 0.2486555598496153D-06 , 0.6665493396226675D-09 , - 0.7962604268187699D-12 , & 0.3575874674024583D-15 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.3389106428392395D-04 , - 0.2411236552253688D-06 , & 0.6452123905283207D-09 , - 0.7693960115121189D-12 , 0.3449035380957528D-15 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.3292211349072445D-04 , - 0.2338176756133197D-06 , 0.6245544730891943D-09 , & - 0.7434355636140135D-12 , 0.3326695184680027D-15 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.3198046541948332D-04 , & - 0.2267309197716863D-06 , 0.6045541197917814D-09 , - 0.7183487544414494D-12 , & 0.3208694498431288D-15 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.3106536370240767D-04 , - 0.2198568826574836D-06 , & 0.5851905367423459D-09 , - 0.6941062695249752D-12 , 0.3094879396127629D-15 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.3017607250632045D-04 , - 0.2131892497695751D-06 , 0.5664435827110542D-09 , & - 0.6706797748176369D-12 , 0.2985101411573486D-15 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.2931187598869394D-04 , & - 0.2067218916518588D-06 , 0.5482937488215327D-09 , - 0.6480418840250529D-12 , & 0.2879217344794572D-15 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.2847207776765667D-04 , - 0.2004488585521543D-06 , & 0.5307221388662094D-09 , - 0.6261661270196002D-12 , 0.2777089075240560D-15 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.2765600040562901D-04 , - 0.1943643752324799D-06 , 0.5137104502283827D-09 , & - 0.6050269193029061D-12 , 0.2678583381613633D-15 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.2686298490625063D-04 , & - 0.1884628359265230D-06 , 0.4972409553925335D-09 , - 0.5845995324820210D-12 , & 0.2583571768087857D-15 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.2609239022427071D-04 , - 0.1827387994402192D-06 , & 0.4812964840249512D-09 , - 0.5648600657257782D-12 , 0.2491930296692708D-15 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.2534359278807990D-04 , - 0.1771869843914684D-06 , 0.4658604056072842D-09 , & - 0.5457854181689524D-12 , 0.2403539425642090D-15 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.2461598603457028D-04 , & - 0.1718022645851218D-06 , 0.4509166126061499D-09 , - 0.5273532622328919D-12 , & 0.2318283853397965D-15 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.2390897995601695D-04 , - 0.1665796645194767D-06 , & 0.4364495041624423D-09 , - 0.5095420178323288D-12 , 0.2236052368265178D-15 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.2322200065868226D-04 , - 0.1615143550206222D-06 , 0.4224439702844721D-09 , & - 0.4923308274390656D-12 , 0.2156737703321269D-15 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.2255448993285067D-04 , & - 0.1566016490010726D-06 , 0.4088853765295499D-09 , - 0.4756995319742066D-12 , & 0.2080236396492066D-15 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.2190590483400907D-04 , - 0.1518369973392264D-06 , & 0.3957595491590880D-09 , - 0.4596286475015258D-12 , 0.2006448655590496D-15 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.2127571727489438D-04 , - 0.1472159848762801D-06 , 0.3830527607527456D-09 , & - 0.4440993426954717D-12 , 0.1935278228142598D-15 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.2066341362813637D-04 , & - 0.1427343265273181D-06 , 0.3707517162675772D-09 , - 0.4290934170581784D-12 , & 0.1866632275830909D-15 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.2006849433923086D-04 , - 0.1383878635033902D-06 , & 0.3588435395285740D-09 , - 0.4145932798606973D-12 , 0.1800421253391449D-15 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.1949047354958397D-04 , - 0.1341725596414734D-06 , 0.3473157601373889D-09 , & - 0.4005819297844759D-12 , 0.1736558791806336D-15 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.1892887872937490D-04 , & - 0.1300844978393002D-06 , 0.3361563007864447D-09 , - 0.3870429352399077D-12 , & 0.1674961585639659D-15 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.1838325031999030D-04 , - 0.1261198765921183D-06 , & 0.3253534649660066D-09 , - 0.3739604153395305D-12 , 0.1615549284369632D-15 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.1785314138578969D-04 , - 0.1222750066285244D-06 , 0.3148959250521757D-09 , & - 0.3613190215041971D-12 , 0.1558244387575304D-15 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.1733811727496647D-04 , & - 0.1185463076425967D-06 , 0.3047727107641272D-09 , - 0.3491039196812517D-12 , & 0.1502972143841071D-15 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.1683775528927563D-04 , - 0.1149303051196228D-06 , & 0.2949731979792684D-09 , - 0.3373007731544400D-12 , 0.1449660453247139D-15 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.1635164436240385D-04 , - 0.1114236272527955D-06 , 0.2854870978953348D-09 , & - 0.3258957259259447D-12 , 0.1398239773318727D-15 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.1587938474676374D-04 , & - 0.1080230019483212D-06 , 0.2763044465287759D-09 , - 0.3148753866515894D-12 , & 0.1348643028311336D-15 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.1542058770849889D-04 , - 0.1047252539164551D-06 , & 0.2674155945391045D-09 , - 0.3042268131108741D-12 , 0.1300805521713741D-15 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.1497487523049181D-04 , - 0.1015273018460449D-06 , 0.2588111973691975D-09 , & - 0.2939374971941164D-12 , 0.1254664851854583D-15 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.1454187972317168D-04 , & - 0.9842615566023299D-07 , 0.2504822056918385D-09 , - 0.2839953503895496D-12 , & 0.1210160830502457D-15 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.1412124374292368D-04 , - 0.9541891385102928D-07 , & 0.2424198561530873D-09 , - 0.2743886897538016D-12 , 0.1167235404353332D-15 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.1371261971790692D-04 , - 0.9250276089053270D-07 , 0.2346156624033508D-09 , & - 0.2651062243497215D-12 , 0.1125832579302871D-15 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.1331566968109207D-04 , & - 0.8967496471663707D-07 , 0.2270614064072997D-09 , - 0.2561370421360515D-12 , & 0.1085898347404884D-15 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.1293006501033502D-04 , - 0.8693287429112024D-07 , & 0.2197491300240537D-09 , - 0.2474705972939521D-12 , 0.1047380616420621D-15 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.1255548617530679D-04 , - 0.8427391722807030D-07 , 0.2126711268493108D-09 , & - 0.2390966979758869D-12 , 0.1010229141867010D-15 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.1219162249110480D-04 , & - 0.8169559749066136D-07 , 0.2058199343113552D-09 , - 0.2310054944628467D-12 , & 0.9743954614752042D-16 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.1183817187837454D-04 , - 0.7919549315434489D-07 , & 0.1991883260131193D-09 , - 0.2231874677163614D-12 , 0.9398328319739414D-16 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.1149484062977506D-04 , - 0.7677125423457690D-07 , 0.1927693043127177D-09 , & - 0.2156334183121908D-12 , 0.9064961681152449D-16 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.1116134318262586D-04 , & - 0.7442060057725283D-07 , 0.1865560931350993D-09 , - 0.2083344557430238D-12 , & 0.8743419838629418D-16 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.1083740189757628D-04 , - 0.7214131981007269D-07 , & 0.1805421310076875D-09 , - 0.2012819880779275D-12 , 0.8433283356672668D-16 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.1052274684314320D-04 , - 0.6993126535310863D-07 , 0.1747210643131000D-09 , & - 0.1944677119667016D-12 , 0.8134147677515709D-16 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.1021711558596588D-04 , & - 0.6778835448689416D-07 , 0.1690867407522433D-09 , - 0.1878836029776754D-12 , & 0.7845622593397501D-16 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.9920252986630915D-05 , - 0.6571056647640217D-07 , & 0.1636332030112886D-09 , - 0.1815219062578724D-12 , 0.7567331737555664D-16 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.9631911000923930D-05 , - 0.6369594074932298D-07 , 0.1583546826262313D-09 , & - 0.1753751275048286D-12 , 0.7298912093274571D-16 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.9351848486367967D-05 , & - 0.6174257512709889D-07 , 0.1532455940389259D-09 , - 0.1694360242397059D-12 , & 0.7040013520347918D-16 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.9079831013912176D-05 , - 0.5984862410721356D-07 , & 0.1483005288386797D-09 , - 0.1636975973716866D-12 , 0.6790298298338073D-16 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.8815630684637701D-05 , - 0.5801229719527755D-07 , 0.1435142501836666D-09 , & - 0.1581530830439636D-12 , 0.6549440686036388D-16 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.8559025951351071D-05 , & - 0.5623185728549124D-07 , 0.1388816873965981D-09 , - 0.1527959447519646D-12 , & 0.6317126496549850D-16 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.8309801444938431D-05 , - 0.5450561908810563D-07 , & 0.1343979307292588D-09 , - 0.1476198657247550D-12 , 0.6093052687459740D-16 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.8067747805357421D-05 , - 0.5283194760254133D-07 , 0.1300582262906801D-09 , & - 0.1426187415608674D-12 , 0.5876926965517731D-16 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.7832661517146210D-05 , & - 0.5120925663486180D-07 , 0.1258579711338836D-09 , - 0.1377866731100927D-12 , & 0.5668467405363735D-16 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.7604344749332519D-05 , - 0.4963600735833462D-07 , & 0.1217927084962832D-09 , - 0.1331179595930500D-12 , 0.5467402081768159D-16 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.7382605199628205D-05 , - 0.4811070691584931D-07 , 0.1178581231889827D-09 , & - 0.1286070919506225D-12 , 0.5273468714918836D-16 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.7167255942797969D-05 , & - 0.4663190706299525D-07 , 0.1140500371303556D-09 , - 0.1242487464156093D-12 , & 0.5086414328289923D-16 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.6958115283093409D-05 , - 0.4519820285063581D-07 , & 0.1103644050194314D-09 , - 0.1200377782991969D-12 , 0.4905994918646486D-16 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.6755006610646507D-05 , - 0.4380823134584870D-07 , 0.1067973101447514D-09 , & - 0.1159692159850967D-12 , 0.4731975137754298D-16 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.6557758261719217D-05 , & - 0.4246067039013313D-07 , 0.1033449603244919D-09 , - 0.1120382551244375D-12 , & 0.4564127985379654D-16 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.6366203382708452D-05 , - 0.4115423739381595D-07 , & 0.1000036839737788D-09 , - 0.1082402530247239D-12 , 0.4402234513178750D-16 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.6180179797808310D-05 , - 0.3988768816561853D-07 , 0.9676992629524497D-10 , & - 0.1045707232263997D-12 , 0.4246083539090350D-16 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.5999529880233805D-05 , & - 0.3865981577637558D-07 , 0.9364024558900190D-10 , - 0.1010253302607660D-12 , & 0.4095471371859185D-16 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.5824100426912902D-05 , - 0.3746944945592539D-07 , & 0.9061130967831534D-10 , - 0.9759988458321220D-13 , 0.3950201545330749D-16 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.5653742536555864D-05 , - 0.3631545352221852D-07 , 0.8767989244738883D-10 , & - 0.9429033767591783D-13 , 0.3810084562170870D-16 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.5488311491013363D-05 , & - 0.3519672634171888D-07 , 0.8484287048776948D-10 , - 0.9109277731437875D-13 , & 0.3674937646675776D-16 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.5327666639836900D-05 , - 0.3411219932019733D-07 , & 0.8209721984999717D-10 , - 0.8800342299229644D-13 , 0.3544584506350183D-16 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.5171671287957502D-05 , - 0.3306083592304317D-07 , 0.7944001289722378D-10 , & - 0.8501862149955188D-13 , 0.3418855101942426D-16 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.5020192586400499D-05 , & - 0.3204163072424367D-07 , 0.7686841525762784D-10 , - 0.8213484264815998D-13 , & 0.3297585425636626D-16 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.4873101425956552D-05 , - 0.3105360848320566D-07 , & 0.7437968287254982D-10 , - 0.7934867514127049D-13 , 0.3180617287112569D-16 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.4730272333730948D-05 , - 0.3009582324861686D-07 , 0.7197115913736640D-10 , & - 0.7665682258044484D-13 , 0.3067798107194230D-16 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.4591583372495285D-05 , & - 0.2916735748856697D-07 , 0.6964027213221552D-10 , - 0.7405609960659701D-13 , & 0.2958980718817747D-16 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.4456916042767542D-05 , - 0.2826732124617085D-07 , & 0.6738453193977163D-10 , - 0.7154342817013956D-13 , 0.2854023175059236D-16 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.4326155187548415D-05 , - 0.2739485131995750D-07 , 0.6520152804735797D-10 , & - 0.6911583392602418D-13 , 0.2752788563972020D-16 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.4199188899643701D-05 , & - 0.2654911046830941D-07 , 0.6308892683076631D-10 , - 0.6677044274950952D-13 , & 0.2655144829991738D-16 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.4075908431504267D-05 , - 0.2572928663725711D-07 , & 0.6104446911723518D-10 , - 0.6450447736862716D-13 , 0.2560964601676364D-16 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.3956208107516889D-05 , - 0.2493459221095372D-07 , 0.5906596782511742D-10 , & - 0.6231525410945088D-13 , 0.2470125025556436D-16 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.3839985238681007D-05 , & - 0.2416426328417308D-07 , 0.5715130567784298D-10 , - 0.6020017975040378D-13 , & 0.2382507605878751D-16 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.3727140039608046D-05 , - 0.2341755895619390D-07 , & 0.5529843298985792D-10 , - 0.5815674848196287D-13 , 0.2297998050034495D-16 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.3617575547781648D-05 , - 0.2269376064545078D-07 , 0.5350536552229170D-10 , & - 0.5618253896824195D-13 , 0.2216486119470163D-16 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.3511197545018691D-05 , & - 0.2199217142434987D-07 , 0.5177018240617452D-10 , - 0.5427521150705055D-13 , & 0.2137865485886794D-16 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.3407914481072564D-05 , - 0.2131211537366489D-07 , & 0.5009102413109399D-10 , - 0.5243250528514011D-13 , 0.2062033592539943D-16 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.3307637399321641D-05 , - 0.2065293695594519D-07 , 0.4846609059724564D-10 , & - 0.5065223572545748D-13 , 0.1988891520459459D-16 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.3210279864487415D-05 , & - 0.2001400040738427D-07 , 0.4689363922889511D-10 , - 0.4893229192333235D-13 , & 0.1918343859414557D-16 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.3115757892328142D-05 , - 0.1939468914761256D-07 , & 0.4537198314733138D-10 , - 0.4727063416862692D-13 , 0.1850298583455874D-16 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.3023989881255262D-05 , - 0.1879440520689356D-07 , 0.4389948940144986D-10 , & - 0.4566529155097525D-13 , 0.1784666930872151D-16 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.2934896545821265D-05 , & - 0.1821256867021777D-07 , 0.4247457725416158D-10 , - 0.4411435964533530D-13 , & 0.1721363288404949D-16 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.2848400852028954D-05 , - 0.1764861713780266D-07 , & 0.4109571652288146D-10 , - 0.4261599827516955D-13 , 0.1660305079570373D-16 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.2764427954413363D-05 , - 0.1710200520152132D-07 , 0.3976142597240169D-10 , & - 0.4116842935065839D-13 , 0.1601412656942114D-16 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.2682905134848897D-05 , & - 0.1657220393679629D-07 , 0.3847027175850982D-10 , - 0.3976993477943846D-13 , & 0.1544609198255302D-16 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.2603761743035438D-05 , - 0.1605870040950784D-07 , & 0.3722086592076157D-10 , - 0.3841885444744015D-13 , 0.1489820606195650D-16 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.2526929138618403D-05 , - 0.1556099719747923D-07 , 0.3601186492286778D-10 , & - 0.3711358426748045D-13 , 0.1436975411743154D-16 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.2452340634898908D-05 , & - 0.1507861192611403D-07 , 0.3484196823920292D-10 , - 0.3585257429334452D-13 , & 0.1386004680944274D-16 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.2379931444091313D-05 , - 0.1461107681777260D-07 , & 0.3370991698598889D-10 , - 0.3463432689716580D-13 , 0.1336841924990989D-16 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.2309638624086575D-05 , - 0.1415793825448671D-07 , 0.3261449259575278D-10 , & - 0.3345739500798651D-13 , 0.1289423013489425D-16 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.2241401026680893D-05 , & - 0.1371875635362298D-07 , 0.3155451553370081D-10 , - 0.3232038040945183D-13 , & 0.1243686090804906D-16 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.2175159247230200D-05 , - 0.1329310455611665D-07 , & 0.3052884405469294D-10 , - 0.3122193209465877D-13 , 0.1199571495374334D-16 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.2110855575692091D-05 , - 0.1288056922690857D-07 , 0.2953637299954365D-10 , & - 0.3016074467624685D-13 , 0.1157021681880613D-16 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.2048433949017783D-05 , & - 0.1248074926722827D-07 , 0.2857603262941380D-10 , - 0.2913555684988170D-13 , & 0.1115981146187615D-16 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.1987839904857692D-05 , - 0.1209325573837682D-07 , & 0.2764678749709735D-10 , - 0.2814514990934408D-13 , 0.1076396352937776D-16 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.1929020536545131D-05 , - 0.1171771149667270D-07 , 0.2674763535404339D-10 , & - 0.2718834631149647D-13 , 0.1038215665717851D-16 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.1871924449323629D-05 , & - 0.1135375083923391D-07 , 0.2587760609199081D-10 , - 0.2626400828945741D-13 , & 0.1001389279701760D-16 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.1816501717784221D-05 , - 0.1100101916027878D-07 , & 0.2503576071812705D-10 , - 0.2537103651236879D-13 , 0.9658691566826430D-17 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.1762703844479978D-05 , - 0.1065917261763733D-07 , 0.2422119036271719D-10 , & - 0.2450836879019596D-13 , 0.9316089624093870D-17 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.1710483719685896D-05 , & - 0.1032787780917350D-07 , 0.2343301531818177D-10 , - 0.2367497882205191D-13 , & 0.8985640061458760D-17 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.1659795582273106D-05 , - 0.1000681145882781D-07 , & 0.2267038410863399D-10 , - 0.2286987498658772D-13 , 0.8666911823741278D-17 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.1610594981667194D-05 , - 0.9695660111997827D-08 , 0.2193247258891779D-10 , & - 0.2209209917303954D-13 , 0.8359489145652677D-17 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.1562838740861198D-05 , & - 0.9394119839982423D-08 , 0.2121848307221807D-10 , - 0.2134072565157010D-13 , & 0.8062971009449951D-17 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.1516484920454663D-05 , - 0.9101895953223420D-08 , & 0.2052764348534333D-10 , - 0.2061485998158762D-13 , 0.7776970621827932D-17 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.1471492783690846D-05 , - 0.8818702723086190D-08 , 0.1985920655080940D-10 , & - 0.1991363795676947D-13 , 0.7501114909366482D-17 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.1427822762464949D-05 , & - 0.8544263111928002D-08 , 0.1921244899487956D-10 , - 0.1923622458555994D-13 , & 0.7235044031874582D-17 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.1385436424276940D-05 , - 0.8278308511210445D-08 , & 0.1858667078074353D-10 , - 0.1858181310595321D-13 , 0.6978410912996524D-17 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.1344296440103256D-05 , - 0.8020578487419098D-08 , 0.1798119436604257D-10 , & - 0.1794962403341176D-13 , 0.6730880787467910D-17 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.1304366553162326D-05 , & - 0.7770820535560597D-08 , 0.1739536398397323D-10 , - 0.1733890424080910D-13 , & 0.6492130764430839D-17 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.1265611548549567D-05 , - 0.7528789840013949D-08 , & 0.1682854494722632D-10 , - 0.1674892606932305D-13 , 0.6261849406238691D-17 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.1227997223718106D-05 , - 0.7294249042519318D-08 , 0.1628012297404043D-10 , & - 0.1617898646924133D-13 , 0.6039736322201057D-17 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.1191490359782143D-05 , & - 0.7066968017093858D-08 , 0.1574950353567249D-10 , - 0.1562840616967606D-13 , & 0.5825501776738872D-17 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.1156058693620481D-05 , - 0.6846723651670323D-08 , & 0.1523611122460931D-10 , - 0.1509652887621748D-13 , 0.5618866311438628D-17 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.1121670890758343D-05 , - 0.6633299636260048D-08 , 0.1473938914286534D-10 , & - 0.1458272049558935D-13 , 0.5419560380512632D-17 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.1088296519006172D-05 , & - 0.6426486257447722D-08 , 0.1425879830973237D-10 , - 0.1408636838640010D-13 , & 0.5227323999189802D-17 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.1055906022834707D-05 , - 0.6226080199030947D-08 , & 0.1379381708836686D-10 , - 0.1360688063511389D-13 , 0.5041906404578340D-17 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.1024470698466146D-05 , - 0.6031884348623027D-08 , 0.1334394063061960D-10 , & - 0.1314368535639513D-13 , 0.4863065728557888D-17 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.9939626696617789D-06 , & - 0.5843707610042756D-08 , 0.1290868033953140D-10 , - 0.1269623001700841D-13 , & 0.4690568682274475D-17 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.9643548641869753D-06 , - 0.5661364721320050D-08 , & 0.1248756334893633D-10 , - 0.1226398078248293D-13 , 0.4524190251826700D-17 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.9356209909349376D-06 , - 0.5484676078151305D-08 , 0.1208013201963154D-10 , & - 0.1184642188577734D-13 , 0.4363713404746176D-17 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.9077355176911284D-06 , & - 0.5313467562643214D-08 , 0.1168594345158998D-10 , - 0.1144305501720603D-13 , & 0.4208928806889370D-17 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.8806736495207551D-06 , - 0.5147570377188425D-08 , & 0.1130456901170829D-10 , - 0.1105339873491299D-13 , 0.4059634549371513D-17 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.8544113077621845D-06 , - 0.4986820883321072D-08 , 0.1093559387659847D-10 , & - 0.1067698789520323D-13 , 0.3915635885186412D-17 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.8289251096096072D-06 , & - 0.4831060445404621D-08 , 0.1057861658994726D-10 , - 0.1031337310206456D-13 , & 0.3776744975168568D-17 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.8041923482687259D-06 , - 0.4680135279008729D-08 , & 0.1023324863398196D-10 , - 0.9962120175235287D-14 , 0.3642780642966238D-17 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.7801909736696809D-06 , - 0.4533896303836133D-08 , 0.9899114014596163D-11 , & - 0.9622809636194590D-14 , 0.3513568138705801D-17 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.7568995737218488D-06 , & - 0.4392199001064528D-08 , 0.9575848859702679D-11 , - 0.9295036211473470D-14 , & 0.3388938911039164D-17 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.7342973560955598D-06 , - 0.4254903274972401D-08 , & 0.9263101030394733D-11 , - 0.8978408352704202D-14 , 0.3268730387276822D-17 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.7123641305161937D-06 , - 0.4121873318721645D-08 , 0.8960529744509530D-11 , & - 0.8672547772845774D-14 , 0.3152785761319793D-17 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.6910802915565000D-06 , & - 0.3992977484173458D-08 , 0.8667805212201129D-11 , - 0.8377088998041615D-14 , & 0.3040953789113788D-17 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.6704268019133689D-06 , - 0.3868088155617691D-08 , & 0.8384608283141958D-11 , - 0.8091678934584133D-14 , 0.2933088591358783D-17 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.6503851761556565D-06 , - 0.3747081627299284D-08 , 0.8110630104984193D-11 , & - 0.7815976450478244D-14 , 0.2829049463216667D-17 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.6309374649300324D-06 , & - 0.3629837984628911D-08 , 0.7845571792723948D-11 , - 0.7549651971113002D-14 , & 0.2728700690768703D-17 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.6120662396121599D-06 , - 0.3516240988968162D-08 , & 0.7589144108622339D-11 , - 0.7292387088566973D-14 , 0.2631911373983406D-17 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.5937545773908788D-06 , - 0.3406177965882944D-08 , 0.7341067152348522D-11 , & - 0.7043874184088883D-14 , 0.2538555255963902D-17 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.5759860467733786D-06 , & - 0.3299539696761778D-08 , 0.7101070061020205D-11 , - 0.6803816063310383D-14 , & 0.2448510558252020D-17 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.5587446934996918D-06 , - 0.3196220313698805D-08 , & 0.6868890718827522D-11 , - 0.6571925603762746D-14 , 0.2361659821974295D-17 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.5420150268551420D-06 , - 0.3096117197544197D-08 , 0.6644275475935899D-11 , & - 0.6347925414283528D-14 , 0.2277889754622649D-17 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.5257820063696950D-06 , & - 0.2999130879027580D-08 , 0.6426978876373263D-11 , - 0.6131547505913260D-14 , & 0.2197091082269895D-17 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.5100310288934654D-06 , - 0.2905164942862805D-08 , & 0.6216763394616172D-11 , - 0.5922532973895515D-14 , 0.2119158407027282D-17 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.4947479160379154D-06 , - 0.2814125934745150D-08 , 0.6013399180598487D-11 , & - 0.5720631690406768D-14 , 0.2043990069558137D-17 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.4799189019725773D-06 , & - 0.2725923271154632D-08 , 0.5816663812874871D-11 , - 0.5525602007654956D-14 , & 0.1971488016468273D-17 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.4655306215673982D-06 , - 0.2640469151881631D-08 , & 0.5626342059679927D-11 , - 0.5337210470997738D-14 , 0.1901557672400155D-17 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.4515700988710845D-06 , - 0.2557678475193565D-08 , 0.5442225647631897D-11 , & - 0.5155231541743238D-14 , 0.1834107816664017D-17 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.4380247359160831D-06 , & - 0.2477468755563676D-08 , 0.5264113037837835D-11 , - 0.4979447329307298D-14 , & 0.1769050464244953D-17 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.4248823018410873D-06 , - 0.2399760043885360D-08 , & 0.5091809209164799D-11 , - 0.4809647332412252D-14 , 0.1706300751030806D-17 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.4121309223222144D-06 , - 0.2324474850097744D-08 , 0.4925125448449067D-11 , & - 0.4645628189022792D-14 , 0.1645776823111109D-17 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.3997590693042343D-06 , & - 0.2251538068150363D-08 , 0.4763879147422583D-11 , - 0.4487193434724728D-14 , & 0.1587399730002694D-17 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.3877555510234702D-06 , - 0.2180876903236970D-08 , & 0.4607893606142834D-11 , - 0.4334153269262306D-14 , 0.1531093321662671D-17 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.3761095023142219D-06 , - 0.2112420801230550D-08 , 0.4456997842719084D-11 , & - 0.4186324330959306D-14 , 0.1476784149154450D-17 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.3648103751907811D-06 , & - 0.2046101380253637D-08 , 0.4311026409134474D-11 , - 0.4043529478758371D-14 , & 0.1424401368837218D-17 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.3538479296973312D-06 , - 0.1981852364319956D-08 , & 0.4169819212969833D-11 , - 0.3905597581621951D-14 , 0.1373876649953903D-17 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.3432122250182318D-06 , - 0.1919609518985355D-08 , 0.4033221344841157D-11 , & - 0.3772363315046812D-14 , 0.1325144085497063D-17 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.3328936108413963D-06 , & - 0.1859310588947763D-08 , 0.3901082911368733D-11 , - 0.3643666964452485D-14 , & 0.1278140106236441D-17 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.3228827189676685D-06 , - 0.1800895237537762D-08 , & 0.3773258873501551D-11 , - 0.3519354235211976D-14 , 0.1232803397796036D-17 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.3131704551593041D-06 , - 0.1744304988043036D-08 , 0.3649608890026330D-11 , & - 0.3399276069100937D-14 , 0.1189074820672520D-17 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.3037479912208466D-06 , & - 0.1689483166811694D-08 , 0.3529997166095828D-11 , - 0.3283288466948959D-14 , & 0.1146897333090666D-17 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.2946067573058783D-06 , - 0.1636374848081040D-08 , & 0.3414292306616354D-11 , - 0.3171252317283933D-14 , 0.1106215916595164D-17 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.2857384344432988D-06 , - 0.1584926800480002D-08 , 0.3302367174339479D-11 , & - 0.3063033230767470D-14 , 0.1066977504281755D-17 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.2771349472769684D-06 , & - 0.1535087435154936D-08 , 0.3194098752507890D-11 , - 0.2958501380226151D-14 , & 0.1029130911574066D-17 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.2687884570127139D-06 , - 0.1486806755470020D-08 , & 0.3089368011909989D-11 , - 0.2857531346089914D-14 , 0.9926267694558543D-18 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 ], shape = [ ntx_al + 1 , npx + 1 ]) real ( kind = 8 ), public , parameter :: rfinc ( 0 : ngrd ) = [ & 0.1714080528854728D+02 , 0.1657757831011014D+02 , 0.1610985037443135D+02 , & 0.1571158409626437D+02 , 0.1536593665137801D+02 , 0.1432309939656232D+02 , & 0.1359866107222196D+02 , 0.1305016694598533D+02 ] real ( kind = 8 ), public , parameter :: rmr ( mxqt ) = [ & 0.1000000000000000D+01 , 0.3333333333333333D+00 , 0.2000000000000000D+00 , & 0.1428571428571428D+00 , 0.1111111111111111D+00 , 0.9090909090909091D-01 , & 0.7692307692307693D-01 , 0.6666666666666667D-01 , 0.5882352941176471D-01 , & 0.5263157894736842D-01 , 0.4761904761904762D-01 , 0.4347826086956522D-01 , & 0.4000000000000000D-01 , 0.3703703703703703D-01 , 0.3448275862068965D-01 , & 0.3225806451612903D-01 ] real ( kind = 8 ), public , parameter :: tlgm ( 0 : mxqt ) = [ & 0.1000000000000000D+01 , 0.1000000000000000D+01 , 0.3000000000000000D+01 , & 0.1500000000000000D+02 , 0.1050000000000000D+03 , 0.9450000000000000D+03 , & 0.1039500000000000D+05 , 0.1351350000000000D+06 , 0.2027025000000000D+07 , & 0.3445942500000000D+08 , 0.6547290750000000D+09 , 0.1374931057500000D+11 , & 0.3162341432250000D+12 , 0.7905853580625000D+13 , 0.2134580466768750D+15 , & 0.6190283353629375D+16 , 0.1918987839625106D+18 ] real ( kind = 8 ), public , parameter :: tmax = 0.2500000000000000D+02 real ( kind = 8 ), public , parameter :: rxinc = 0.2768915858120725D+02 integer , public , parameter :: nord = 4 end module boys_lut","tags":"","url":"sourcefile/boys_lut.f90.html"},{"title":"grd1.F90 – OpenQP Fortran API","text":"Source Code module grd1 use iso_c_binding , only : c_int64_t use io_constants , only : iw use precision , only : dp use types , only : information use atomic_structure_m , only : atomic_structure use basis_tools , only : basis_set , & bas_norm_matrix , bas_denorm_matrix , build_cart_density use constants , only : HARMONIC_ACTIVE use cart2sph , only : cart2sph_mat use mod_1e_primitives , only : & comp_coulomb_der1 , comp_coulomb_helfeyder1 , comp_kinetic_der1 , & comp_overlap_der1 , & comp_overlap_der2 , comp_kinetic_der2 , comp_coulomb_der2_braC , & comp_overlap_der1_block , comp_kinetic_der1_block , & comp_coulomb_der1_block , comp_coulomb_helfeyder1_block , & comp_ewaldlr_der1 use mod_shell_tools , only : shell_t , shpair_t use mathlib , only : unpack_matrix use ecp_tool , only : add_ecpder implicit none character ( len =* ), parameter :: module_name = \"grd1\" real ( kind = dp ), parameter :: tol_default = log ( 1 0.0d0 ) * 20 private public print_gradient public eijden public grad_nn public hess_nn public grad_ee_overlap public grad_ee_kinetic public hess_ee_overlap public hess_ee_kinetic public hess_en public der_overlap_matrix public der_kinetic_matrix public der_nucattr_matrix public grad_en_hellman_feynman public grad_en_pulay public grad_1e_ecp public grad_elpot contains !------------------------------------------------------------------------------- !> @brief Unpack a symmetric matrix from packed storage and fold in the basis !>        normalization factors. Shared helper for all 1e gradient/Hessian !>        contractions in this module. !> @param[in] basis  basis set (for nbf and bfnrm) !> @param[in] denab  packed symmetric matrix (density-like), unchanged !> @return    square matrix with dens(i,j) = denab_{ij} * bfnrm(i) * bfnrm(j) function normalized_density ( basis , denab ) result ( dens ) implicit none type ( basis_set ), intent ( in ) :: basis real ( kind = dp ), intent ( in ) :: denab (:) real ( kind = dp ), allocatable :: dens (:,:) allocate ( dens ( basis % nbf , basis % nbf ), source = 0.0d0 ) call unpack_matrix ( denab , dens ) call bas_norm_matrix ( dens , basis % bfnrm , basis % nbf ) end function normalized_density !------------------------------------------------------------------------------- !> @brief Reduce a Cartesian first-derivative shell-pair block to the active AO !>        dimensions for CPHF/Hessian derivative matrices. SUBROUTINE reduce_der1_shell_block ( basis , ish , jsh , raw , reduced ) type ( basis_set ), intent ( in ) :: basis integer , intent ( in ) :: ish , jsh real ( kind = dp ), intent ( in ) :: raw (:,:,:) real ( kind = dp ), allocatable , intent ( out ) :: reduced (:,:,:) real ( kind = dp ), allocatable :: blk (:) integer :: nci , ncj , nsi , nsj , c , i , j integer :: pure_i , pure_j nci = size ( raw , 1 ) ncj = size ( raw , 2 ) nsi = basis % naos ( ish ) nsj = basis % naos ( jsh ) allocate ( reduced ( nsi , nsj , 3 ), source = 0.0_dp ) pure_i = 0 pure_j = 0 if ( HARMONIC_ACTIVE ) then pure_i = basis % harmonic ( ish ) pure_j = basis % harmonic ( jsh ) end if if ( pure_i == 0 . and . pure_j == 0 ) then reduced ( 1 : nsi , 1 : nsj , 1 : 3 ) = raw ( 1 : nsi , 1 : nsj , 1 : 3 ) return end if allocate ( blk ( nci * ncj )) do c = 1 , 3 do i = 1 , nci do j = 1 , ncj blk (( i - 1 ) * ncj + j ) = raw ( i , j , c ) end do end do call cart2sph_mat ( blk , basis % am ( jsh ), pure_j , basis % am ( ish ), pure_i ) do i = 1 , nsi do j = 1 , nsj reduced ( i , j , c ) = blk (( i - 1 ) * nsj + j ) end do end do end do deallocate ( blk ) END SUBROUTINE reduce_der1_shell_block !------------------------------------------------------------------------------- !> @brief Compute \"energy weighted density matrix\" !> @note This quantity is actually the Lagrangian matrix, !   backtransformed into the AO basis. subroutine eijden ( eps , nbf , infos ) use oqp_tagarray_driver use mathlib , only : orthogonal_transform_sym , orb_to_dens use messages , only : show_message , with_abort implicit none character ( len =* ), parameter :: subroutine_name = \"eijden\" type ( information ), intent ( inout ) :: infos integer :: nbf integer :: i , ij , ne , ok real ( kind = dp ) :: eps (:) real ( kind = dp ), allocatable :: c (:,:), tempd (:) ! tagarray real ( kind = dp ), contiguous , pointer :: & mo_energy_a (:), mo_a (:,:), & fock_a (:), fock_b (:), dmat_a (:), dmat_b (:) character ( len =* ), parameter :: tags_alpha ( 2 ) = ( / character ( len = 80 ) :: & OQP_E_MO_A , OQP_VEC_MO_A / ) character ( len =* ), parameter :: tags_beta ( 4 ) = ( / character ( len = 80 ) :: & OQP_FOCK_A , OQP_DM_A , OQP_FOCK_B , OQP_DM_B / ) if ( infos % control % scftype > 1 ) then allocate ( c ( nbf , nbf ), tempd ( nbf * ( nbf + 1 ) / 2 ), stat = ok ) end if ne = infos % mol_prop % nelec / 2 select case ( infos % control % scftype ) !   RHF case case ( 1 ) call data_has_tags ( infos % dat , tags_alpha , module_name , subroutine_name , WITH_ABORT ) call tagarray_get_data ( infos % dat , OQP_E_MO_A , mo_energy_a ) call tagarray_get_data ( infos % dat , OQP_VEC_MO_A , mo_a ) !     W = -2 * C_occ * diag(eps_occ) * C_occ&#94;T, evaluated with BLAS (dsyr2k) call orb_to_dens ( eps , mo_a , - 2 * mo_energy_a ( 1 : ne ), ne , nbf , nbf ) !   U/ROHF case case ( 2 :) call data_has_tags ( infos % dat , tags_beta , module_name , subroutine_name , WITH_ABORT ) call tagarray_get_data ( infos % dat , OQP_FOCK_A , fock_a ) call tagarray_get_data ( infos % dat , OQP_FOCK_B , fock_b ) call tagarray_get_data ( infos % dat , OQP_DM_A , dmat_a ) call tagarray_get_data ( infos % dat , OQP_DM_B , dmat_b ) !     Alpha part call unpack_matrix ( dmat_a , c , nbf , 'U' ) call orthogonal_transform_sym ( nbf , nbf , fock_a , c , nbf , tempd ) !     Beta part call unpack_matrix ( dmat_b , c , nbf , 'U' ) call orthogonal_transform_sym ( nbf , nbf , fock_b , c , nbf , eps ) eps = - eps - tempd !     Half the diagonal ij = 0 do i = 1 , nbf ij = ij + i eps ( ij ) = 0.5d0 * eps ( ij ) end do end select end subroutine eijden !------------------------------------------------------------------------------- !> @brief Print energy gradient vector subroutine grad_max_rms ( n , de , gmax , grms ) implicit none !    type(information), intent(in) :: infos integer ( c_int64_t ), intent ( in ) :: n real ( kind = dp ), intent ( out ) :: gmax , grms real ( kind = dp ) :: de ( 3 , n ) integer ( c_int64_t ) :: i ! Calculate maximum value gmax = maxval ( abs ( de )) ! Calculate root mean square (RMS) grms = 0.0 do i = 1 , n grms = grms + de ( 1 , i ) ** 2 + de ( 2 , i ) ** 2 + de ( 3 , i ) ** 2 end do grms = sqrt ( grms / real ( n * 3 , kind = dp )) end subroutine grad_max_rms !------------------------------------------------------------------------------- !> @brief Print energy gradient vector subroutine print_gradient ( infos ) implicit none type ( information ), intent ( in ) :: infos real ( kind = dp ) :: gmax , grms integer :: i write ( iw , fmt = \"(& &/25X,23('=')& &/25X,'Gradient (Hartree/Bohr)'& &/25X,23('=')& &/8X,'ATOM     ZNUC',9X,'dE/dX',10X,'dE/dY',10X,'dE/dZ'& &/6X,62('-'))\" ) do i = 1 , infos % mol_prop % natom write ( iw , '(7X,I4,5X,F4.1,3X,3F15.9)' ) & i , infos % atoms % zn ( i ), infos % atoms % grad (:, i ) end do !   Compute Maximum and RMS Gradient call grad_max_rms ( infos % mol_prop % natom , infos % atoms % grad , gmax , grms ) write ( iw , fmt = \"(/10X,'Maximum Gradient =',F10.7,4X,& &'RMS Gradient =',F10.7/)\" ) gmax , grms end subroutine print_gradient !------------------------------------------------------------------------------- !> @brief Compute overlap energy derivative contribution to gradient ! !> @author Vladimir Mironov ! !   REVISION HISTORY: !> @date _Sep, 2018_ Initial release !> !> @brief Unpack + bfnrm-fold a packed density and, under HARMONIC_ACTIVE, !>        expand it to the Cartesian-effective density the derivative kernels !>        contract. Returns the (possibly Cartesian-sized) full density and !>        the matching per-shell AO offsets. With the gate off this is the !>        former inline unpack/bas_norm and off = basis%ao_offset. SUBROUTINE prepare_grad_density ( basis , denab , dens , off ) type ( basis_set ), intent ( in ) :: basis real ( kind = dp ), intent ( in ) :: denab (:) real ( kind = dp ), allocatable , intent ( out ) :: dens (:,:) integer , allocatable , intent ( out ) :: off (:) real ( kind = dp ), allocatable :: dcart (:,:) integer , allocatable :: cart_off (:) integer :: nbf_cart allocate ( dens ( basis % nbf , basis % nbf ), source = 0.0d0 ) call unpack_matrix ( denab , dens ) call bas_norm_matrix ( dens , basis % bfnrm , basis % nbf ) if ( HARMONIC_ACTIVE ) then call build_cart_density ( basis , dens , dcart , cart_off , nbf_cart ) call move_alloc ( dcart , dens ) call move_alloc ( cart_off , off ) else allocate ( off ( basis % nshell )) off = basis % ao_offset ( 1 : basis % nshell ) end if END SUBROUTINE !> @param[in,out]   denab   density matrix in packed format, remains unchanged on return SUBROUTINE grad_ee_overlap ( basis , denab , de , logtol ) implicit none type ( basis_set ), intent ( inout ) :: basis REAL ( kind = dp ), INTENT ( INOUT ) :: denab (:) real ( kind = dp ), optional :: logtol REAL ( kind = dp ) :: de (:,:) INTEGER :: ii , jj REAL ( kind = dp ) :: tol REAL ( kind = dp ) :: de_atom ( 3 ) REAL ( kind = dp ), ALLOCATABLE :: de_priv (:,:), dens (:,:) INTEGER , ALLOCATABLE :: off (:) TYPE ( shell_t ) :: shi , shj TYPE ( shpair_t ) :: cntp if ( present ( logtol )) then tol = logtol else tol = tol_default end if allocate ( de_priv , mold = de ) de_priv = 0.0d0 call prepare_grad_density ( basis , denab , dens , off ) !   Initialize parallel !$omp parallel & !$omp   private( & !$omp       ii, jj, & !$omp       shi, shj, cntp, & !$omp       de_atom & !$omp   ) & !$omp   reduction(+:de_priv) CALL cntp % alloc ( basis ) !$omp do schedule(dynamic) !   I shell DO ii = 1 , basis % nshell de_atom = 0.0 CALL shi % fetch_by_id ( basis , ii ) !       J shell DO jj = 1 , basis % nshell CALL shj % fetch_by_id ( basis , jj ) CALL cntp % shell_pair ( basis , shi , shj , tol , dup = . false .) IF ( cntp % numpairs == 0 ) CYCLE CALL comp_overlap_der1 ( cntp , dens ( off ( ii ):, off ( jj ):), de_atom ) END DO ! Update gradient de_priv (:, shi % atid ) = de_priv (:, shi % atid ) + 2 * de_atom END DO !$omp end do !   End of shell loops !$omp end parallel de = de + de_priv DEALLOCATE ( de_priv ) END SUBROUTINE !------------------------------------------------------------------------------- !> @brief Basis function derivative contributions to gradient !> @details Compute derivative integrals of type <ii'|h|jj> = <ii'|t+v|jj> !> @note No relativistic methods available ! !> @author Vladimir Mironov ! !   REVISION HISTORY: !> @date _Sep, 2018_ Initial release !> !> @param[in,out]   denab   density matrix in packed format, remains unchanged on return SUBROUTINE grad_ee_kinetic ( basis , denab , de , logtol ) REAL ( kind = dp ), INTENT ( INOUT ) :: denab (:) type ( basis_set ), intent ( inout ) :: basis REAL ( kind = dp ) :: de (:,:) INTEGER :: ii , jj REAL ( kind = dp ), optional :: logtol REAL ( kind = dp ) :: de_atom ( 3 ) REAL ( kind = dp ), ALLOCATABLE :: de_priv (:,:), dens (:,:) INTEGER , ALLOCATABLE :: off (:) REAL ( kind = dp ) :: tol TYPE ( shell_t ) :: shi , shj TYPE ( shpair_t ) :: cntp if ( present ( logtol )) then tol = logtol else tol = tol_default end if call prepare_grad_density ( basis , denab , dens , off ) !   temporary storage for 1e gradient ALLOCATE ( de_priv , mold = de ) de_priv = 0.0d0 !$omp parallel & !$omp   private( & !$omp       ii, jj, & !$omp       shi, shj, cntp, & !$omp       de_atom & !$omp   ) & !$omp   reduction(+:de_priv) CALL cntp % alloc ( basis ) !$omp do schedule(dynamic) !   I shell DO ii = 1 , basis % nshell CALL shi % fetch_by_id ( basis , ii ) de_atom = 0.0 !       J shell DO jj = 1 , basis % nshell CALL shj % fetch_by_id ( basis , jj ) CALL cntp % shell_pair ( basis , shi , shj , tol , dup = . false .) IF ( cntp % numpairs == 0 ) CYCLE CALL comp_kinetic_der1 ( cntp , dens ( off ( ii ):, off ( jj ):), de_atom ) END DO de_priv (:, shi % atid ) = de_priv (:, shi % atid ) + 2 * de_atom (:) END DO !$omp end do !   End of shell loops !$omp end parallel de = de + de_priv DEALLOCATE ( de_priv ) END SUBROUTINE !MHR START !------------------------------------------------------------------------------- !> @brief Electrostatic potential grid derivative contributions !> @details Compute derivative integrals of type <ii'|v|jj> !> @note No relativistic methods available ! !> @author Vladimir Mironov, Miquel Huix-Rotllant ! !   REVISION HISTORY: !> @date _Apr, 2024_ QMMM modifications !> !> @param[in]       coord   grid coordinates !> @param[in]       zq      grid weights !> @param[in,out]   denab   density matrix in packed format, remains unchanged on return !> @param[in]       l2      dimension of density matrix array !> @param[out]      de      integrals SUBROUTINE grad_elpot ( basis , coord , zq , denab , de , logtol ) REAL ( kind = dp ), INTENT ( INOUT ) :: denab (:) type ( basis_set ), intent ( inout ) :: basis real ( kind = dp ), contiguous , intent ( in ) :: coord (:) real ( kind = dp ), intent ( in ) :: zq REAL ( kind = dp ) :: de (:,:) INTEGER :: l2 , & ii , jj REAL ( kind = dp ), optional :: logtol REAL ( kind = dp ) :: de1 ( 3 ) REAL ( kind = dp ), ALLOCATABLE :: de_priv (:,:), dens (:,:) INTEGER , ALLOCATABLE :: off (:) REAL ( kind = dp ) :: dernuc ( 3 ), tol LOGICAL :: out , dbg , norm TYPE ( shell_t ) :: shi , shj TYPE ( shpair_t ) :: cntp INTEGER :: nat dbg = . false . out = . false . IF ( dbg ) WRITE ( iw , '(/10X,38(1H-)/10X,\"GRADIENT INCLUDING AO DERIVATIVE TERMS\"/10X,38(1H-))' ) nat = ubound ( de , 2 ) l2 = basis % nbf !IF (dbg) write(iw,*) \"OMP 1E GRD (TVDER)\", basis%nshell, nat if ( present ( logtol )) then tol = logtol else tol = tol_default end if !   Build the gradient density. Under HARMONIC_ACTIVE this expands pure-spherical !   shell blocks to the Cartesian \"effective\" density that comp_coulomb_der1 !   expects, and returns Cartesian shell offsets in `off`. Previously this routine !   sliced the raw spherical density with ao_offset, which is wrong for l>=2 pure !   spherical shells (PR #205 review, finding H1). Mirrors grad_en_pulay et al. call prepare_grad_density ( basis , denab , dens , off ) !   temporary storage for 1e gradient ALLOCATE ( de_priv , mold = de ) de_priv = 0.0d0 !$omp parallel & !$omp   private( & !$omp       ii, jj,  & !$omp       shi, shj, cntp, & !$omp       dernuc, & !$omp       de1 & !$omp   ) & !$omp   reduction(+:de_priv) CALL cntp % alloc ( basis ) !$omp do schedule(dynamic) !   I shell DO ii = 1 , basis % nshell CALL shi % fetch_by_id ( basis , ii ) de1 = 0.0 !       J shell DO jj = 1 , basis % nshell CALL shj % fetch_by_id ( basis , jj ) CALL cntp % shell_pair ( basis , shi , shj , tol , dup = . false .) IF ( cntp % numpairs == 0 ) CYCLE !           Nuclear attraction derivative CALL comp_coulomb_der1 ( cntp , coord (:), - zq , dens ( off ( ii ):, off ( jj ):), dernuc ) de1 = de1 + 2 * dernuc ( 1 : 3 ) !           End of primitive loops END DO de_priv (:, shi % atid ) = de_priv (:, shi % atid ) + de1 (:) END DO !$omp end do !   End of shell loops !$omp end parallel de = de + de_priv DEALLOCATE ( de_priv ) END SUBROUTINE !MHR END !------------------------------------------------------------------------------- !> @brief Overlap second-derivative contribution to the Cartesian Hessian. !> @details Accumulates  sum_uv M_uv d2 S_uv / dR_a dR_b  into the (3N,3N) !>   Hessian, where M is the matrix passed in packed form (the energy-weighted !>   density W for the HF Hessian). Mirrors grad_ee_overlap: it loops ordered !>   shell pairs, evaluates the bra-center second derivative (comp_overlap_der2) !>   with the same factor-2 convention as the gradient, and uses translational !>   invariance of the two-center integral (d/dB = -d/dA) for the cross block. SUBROUTINE hess_ee_overlap ( basis , denab , hess , logtol ) implicit none type ( basis_set ), intent ( inout ) :: basis REAL ( kind = dp ), INTENT ( INOUT ) :: denab (:) real ( kind = dp ), intent ( inout ) :: hess (:,:) real ( kind = dp ), optional :: logtol INTEGER :: ii , jj , a , b , ai , bi REAL ( kind = dp ) :: tol , de2 ( 3 , 3 ) REAL ( kind = dp ), ALLOCATABLE :: hess_priv (:,:), dens (:,:) INTEGER , ALLOCATABLE :: off (:) TYPE ( shell_t ) :: shi , shj TYPE ( shpair_t ) :: cntp if ( present ( logtol )) then tol = logtol else tol = tol_default end if call prepare_grad_density ( basis , denab , dens , off ) allocate ( hess_priv , mold = hess ) hess_priv = 0.0d0 !$omp parallel & !$omp   private(ii, jj, a, b, ai, bi, shi, shj, cntp, de2) & !$omp   reduction(+:hess_priv) CALL cntp % alloc ( basis ) !$omp do schedule(dynamic) DO ii = 1 , basis % nshell CALL shi % fetch_by_id ( basis , ii ) DO jj = 1 , basis % nshell CALL shj % fetch_by_id ( basis , jj ) CALL cntp % shell_pair ( basis , shi , shj , tol , dup = . false .) IF ( cntp % numpairs == 0 ) CYCLE de2 = 0.0d0 CALL comp_overlap_der2 ( cntp , & dens ( off ( ii ):, off ( jj ):), de2 ) ! d/dR_C of  G_A = 2*sum_bra-on-A ...  : C=A gives +2*de2, C=B gives -2*de2 DO a = 1 , 3 ai = 3 * ( shi % atid - 1 ) + a DO b = 1 , 3 hess_priv ( 3 * ( shi % atid - 1 ) + b , ai ) = & hess_priv ( 3 * ( shi % atid - 1 ) + b , ai ) + 2 * de2 ( b , a ) hess_priv ( 3 * ( shi % atid - 1 ) + b , 3 * ( shj % atid - 1 ) + a ) = & hess_priv ( 3 * ( shi % atid - 1 ) + b , 3 * ( shj % atid - 1 ) + a ) - 2 * de2 ( b , a ) END DO END DO END DO END DO !$omp end do !$omp end parallel hess = hess + hess_priv DEALLOCATE ( hess_priv , dens , off ) END SUBROUTINE !------------------------------------------------------------------------------- !> @brief Kinetic-energy second-derivative contribution to the Cartesian Hessian. !> @details Accumulates  sum_uv M_uv d2 T_uv / dR_a dR_b  into the (3N,3N) !>   Hessian. Same structure and conventions as hess_ee_overlap, using !>   comp_kinetic_der2. SUBROUTINE hess_ee_kinetic ( basis , denab , hess , logtol ) implicit none type ( basis_set ), intent ( inout ) :: basis REAL ( kind = dp ), INTENT ( INOUT ) :: denab (:) real ( kind = dp ), intent ( inout ) :: hess (:,:) real ( kind = dp ), optional :: logtol INTEGER :: ii , jj , a , b , ai REAL ( kind = dp ) :: tol , de2 ( 3 , 3 ) REAL ( kind = dp ), ALLOCATABLE :: hess_priv (:,:), dens (:,:) INTEGER , ALLOCATABLE :: off (:) TYPE ( shell_t ) :: shi , shj TYPE ( shpair_t ) :: cntp if ( present ( logtol )) then tol = logtol else tol = tol_default end if call prepare_grad_density ( basis , denab , dens , off ) allocate ( hess_priv , mold = hess ) hess_priv = 0.0d0 !$omp parallel & !$omp   private(ii, jj, a, b, ai, shi, shj, cntp, de2) & !$omp   reduction(+:hess_priv) CALL cntp % alloc ( basis ) !$omp do schedule(dynamic) DO ii = 1 , basis % nshell CALL shi % fetch_by_id ( basis , ii ) DO jj = 1 , basis % nshell CALL shj % fetch_by_id ( basis , jj ) CALL cntp % shell_pair ( basis , shi , shj , tol , dup = . false .) IF ( cntp % numpairs == 0 ) CYCLE de2 = 0.0d0 CALL comp_kinetic_der2 ( cntp , & dens ( off ( ii ):, off ( jj ):), de2 ) DO a = 1 , 3 ai = 3 * ( shi % atid - 1 ) + a DO b = 1 , 3 hess_priv ( 3 * ( shi % atid - 1 ) + b , ai ) = & hess_priv ( 3 * ( shi % atid - 1 ) + b , ai ) + 2 * de2 ( b , a ) hess_priv ( 3 * ( shi % atid - 1 ) + b , 3 * ( shj % atid - 1 ) + a ) = & hess_priv ( 3 * ( shi % atid - 1 ) + b , 3 * ( shj % atid - 1 ) + a ) - 2 * de2 ( b , a ) END DO END DO END DO END DO !$omp end do !$omp end parallel hess = hess + hess_priv DEALLOCATE ( hess_priv , dens , off ) END SUBROUTINE !------------------------------------------------------------------------------- !> @brief Nuclear-attraction second-derivative contribution to the Cartesian !>   Hessian (electron-nucleus 1e term), on a fully bra-validated derivative path. !> @warning WORK IN PROGRESS, not yet validated. The mixed bra-charge block !>   (p_AC, d2/dA dC) computed from the bra derivative of the Hellmann-Feynman !>   term currently disagrees with finite differences (see hess1_selftest, !>   nucattr WIP line). This routine is not wired into any production path; the !>   native hf_hessian kernel remains guarded. !> @details For each ordered shell pair (bra atom A, ket atom B) and nucleus C, !>   comp_coulomb_der2_braC is called twice -- as (A,B) giving the bra blocks !>   p_AA=d2/dA2, p_AC=d2/dA dC, and swapped as (B,A) giving p_BB=d2/dB2, !>   p_BC=d2/dB dC. Translational invariance d/dC = -(d/dA + d/dB) then yields !>     p_AB = -(p_AA + p_AC),  p_CC = p_AA + p_AB + p_AB&#94;T + p_BB, !>   and all nine atom blocks are scattered into the (3N,3N) Hessian. Summing !>   over ordered pairs reproduces the true d2E/dRdR (no extra symmetry factor). SUBROUTINE hess_en ( basis , coord , zq , denab , hess , logtol , hess_cc ) implicit none type ( basis_set ), intent ( inout ) :: basis real ( kind = dp ), contiguous , intent ( in ) :: coord (:,:), zq (:) REAL ( kind = dp ), INTENT ( INOUT ) :: denab (:) real ( kind = dp ), intent ( inout ) :: hess (:,:) real ( kind = dp ), optional :: logtol real ( kind = dp ), optional , intent ( inout ) :: hess_cc (:,:) INTEGER :: ii , jj , ic , a , b , n , nat , pat , qat REAL ( kind = dp ) :: tol REAL ( kind = dp ) :: p_AA ( 3 , 3 ), p_AC ( 3 , 3 ), p_BB ( 3 , 3 ), p_BC ( 3 , 3 ) REAL ( kind = dp ) :: bAB ( 3 , 3 ), blocks ( 3 , 3 , 9 ) INTEGER :: atP ( 9 ), atQ ( 9 ) REAL ( kind = dp ), ALLOCATABLE :: hess_priv (:,:), dens (:,:) INTEGER , ALLOCATABLE :: off (:) TYPE ( shell_t ) :: shi , shj TYPE ( shpair_t ) :: cab , cba if ( present ( logtol )) then tol = logtol else tol = tol_default end if nat = ubound ( coord , 2 ) call prepare_grad_density ( basis , denab , dens , off ) allocate ( hess_priv , mold = hess ) hess_priv = 0.0d0 !$omp parallel & !$omp   private(ii, jj, ic, a, b, n, pat, qat, shi, shj, cab, cba, & !$omp           p_AA, p_AC, p_BB, p_BC, bAB, blocks, atP, atQ) & !$omp   reduction(+:hess_priv) CALL cab % alloc ( basis ) CALL cba % alloc ( basis ) !$omp do schedule(dynamic) DO ii = 1 , basis % nshell CALL shi % fetch_by_id ( basis , ii ) DO jj = 1 , basis % nshell CALL shj % fetch_by_id ( basis , jj ) CALL cab % shell_pair ( basis , shi , shj , tol , dup = . false .) IF ( cab % numpairs == 0 ) CYCLE CALL cba % shell_pair ( basis , shj , shi , tol , dup = . false .) DO ic = 1 , nat p_AA = 0.0d0 ; p_AC = 0.0d0 ; p_BB = 0.0d0 ; p_BC = 0.0d0 CALL comp_coulomb_der2_braC ( cab , coord (:, ic ), - zq ( ic ), & dens ( off ( ii ):, off ( jj ):), p_AA , p_AC ) CALL comp_coulomb_der2_braC ( cba , coord (:, ic ), - zq ( ic ), & dens ( off ( jj ):, off ( ii ):), p_BB , p_BC ) bAB = - ( p_AA + p_AC ) atP ( 1 ) = shi % atid ; atQ ( 1 ) = shi % atid ; blocks (:,:, 1 ) = p_AA atP ( 2 ) = shj % atid ; atQ ( 2 ) = shj % atid ; blocks (:,:, 2 ) = p_BB atP ( 3 ) = shi % atid ; atQ ( 3 ) = shj % atid ; blocks (:,:, 3 ) = bAB atP ( 4 ) = shj % atid ; atQ ( 4 ) = shi % atid ; blocks (:,:, 4 ) = transpose ( bAB ) atP ( 5 ) = shi % atid ; atQ ( 5 ) = ic ; blocks (:,:, 5 ) = p_AC atP ( 6 ) = ic ; atQ ( 6 ) = shi % atid ; blocks (:,:, 6 ) = transpose ( p_AC ) atP ( 7 ) = shj % atid ; atQ ( 7 ) = ic ; blocks (:,:, 7 ) = p_BC atP ( 8 ) = ic ; atQ ( 8 ) = shj % atid ; blocks (:,:, 8 ) = transpose ( p_BC ) atP ( 9 ) = ic ; atQ ( 9 ) = ic ; blocks (:,:, 9 ) = p_AA + bAB + transpose ( bAB ) + p_BB DO n = 1 , 9 pat = atP ( n ); qat = atQ ( n ) DO a = 1 , 3 DO b = 1 , 3 hess_priv ( 3 * ( pat - 1 ) + a , 3 * ( qat - 1 ) + b ) = & hess_priv ( 3 * ( pat - 1 ) + a , 3 * ( qat - 1 ) + b ) + blocks ( a , b , n ) END DO END DO END DO END DO END DO END DO !$omp end do !$omp end parallel hess = hess + hess_priv DEALLOCATE ( hess_priv ) if ( present ( hess_cc )) then call cab % alloc ( basis ) call cba % alloc ( basis ) do ii = 1 , basis % nshell call shi % fetch_by_id ( basis , ii ) do jj = 1 , basis % nshell call shj % fetch_by_id ( basis , jj ) call cab % shell_pair ( basis , shi , shj , tol , dup = . false .) if ( cab % numpairs == 0 ) cycle call cba % shell_pair ( basis , shj , shi , tol , dup = . false .) do ic = 1 , nat p_AA = 0.0d0 ; p_AC = 0.0d0 ; p_BB = 0.0d0 ; p_BC = 0.0d0 call comp_coulomb_der2_braC ( cab , coord (:, ic ), - zq ( ic ), & dens ( off ( ii ):, off ( jj ):), p_AA , p_AC ) call comp_coulomb_der2_braC ( cba , coord (:, ic ), - zq ( ic ), & dens ( off ( jj ):, off ( ii ):), p_BB , p_BC ) bAB = - ( p_AA + p_AC ) do a = 1 , 3 do b = 1 , 3 hess_cc ( 3 * ( ic - 1 ) + a , 3 * ( ic - 1 ) + b ) = & hess_cc ( 3 * ( ic - 1 ) + a , 3 * ( ic - 1 ) + b ) + & p_AA ( a , b ) + bAB ( a , b ) + bAB ( b , a ) + p_BB ( a , b ) end do end do end do end do end do end if DEALLOCATE ( dens , off ) END SUBROUTINE !------------------------------------------------------------------------------- !> @brief Build the AO overlap first-derivative matrices dS_uv/dR for every !>   nuclear coordinate (a CPHF right-hand-side building block). !> @details Returns dS(nbf, nbf, 3, natom) where dS(:,:,c,A) = dS/dR_{A,c}. For !>   each ordered shell pair the bra-center derivative block is scattered to the !>   bra atom (+) and, by translational invariance of the two-center overlap !>   (d/dB = -d/dA), to the ket atom (-). The integrals are in the same !>   unnormalized convention as the stored overlap matrix (basis normalization !>   is applied to the contracting density, as in grad_ee_overlap), so !>   sum_uv (bfnrm_u bfnrm_v M_uv) dS(u,v,c,A) reproduces grad_ee_overlap(M). SUBROUTINE der_overlap_matrix ( basis , dS , logtol ) implicit none type ( basis_set ), intent ( inout ) :: basis real ( kind = dp ), intent ( out ) :: dS (:,:,:,:) ! (nbf, nbf, 3, natom) real ( kind = dp ), optional :: logtol INTEGER :: ii , jj , c , i , j , gi , gj , A_at , B_at , oi , oj REAL ( kind = dp ) :: tol REAL ( kind = dp ), ALLOCATABLE :: dblk (:,:,:), sblk (:,:,:) TYPE ( shell_t ) :: shi , shj TYPE ( shpair_t ) :: cntp if ( present ( logtol )) then tol = logtol else tol = tol_default end if dS = 0.0d0 CALL cntp % alloc ( basis ) DO ii = 1 , basis % nshell CALL shi % fetch_by_id ( basis , ii ) A_at = shi % atid oi = basis % ao_offset ( ii ) - 1 DO jj = 1 , basis % nshell CALL shj % fetch_by_id ( basis , jj ) B_at = shj % atid oj = basis % ao_offset ( jj ) - 1 CALL cntp % shell_pair ( basis , shi , shj , tol , dup = . false .) IF ( cntp % numpairs == 0 ) CYCLE allocate ( dblk ( cntp % inao , cntp % jnao , 3 ), source = 0.0d0 ) CALL comp_overlap_der1_block ( cntp , dblk ) CALL reduce_der1_shell_block ( basis , ii , jj , dblk , sblk ) DO c = 1 , 3 DO i = 1 , basis % naos ( ii ) gi = oi + i DO j = 1 , basis % naos ( jj ) gj = oj + j dS ( gi , gj , c , A_at ) = dS ( gi , gj , c , A_at ) + sblk ( i , j , c ) dS ( gi , gj , c , B_at ) = dS ( gi , gj , c , B_at ) - sblk ( i , j , c ) END DO END DO END DO deallocate ( dblk , sblk ) END DO END DO END SUBROUTINE !------------------------------------------------------------------------------- !> @brief Build the AO nuclear-attraction first-derivative matrices dV_uv/dR for !>   every nuclear coordinate (a CPHF right-hand-side building block). !> @details V_uv = sum_C (-Z_C) <u|1/|r-C||v> depends on three centers: bra atom !>   A, ket atom B, and each charge atom C. For every ordered shell pair and !>   nucleus C, the bra-center derivative (comp_coulomb_der1_block) is scattered !>   to A, the charge-center derivative (comp_coulomb_helfeyder1_block) to C, and !>   the ket-center derivative follows from translational invariance of the !>   integral, d/dB = -(d/dA + d/dC), scattered to B. Contracting dV with the !>   normalized density reproduces grad_en_pulay + grad_en_hellman_feynman. SUBROUTINE der_nucattr_matrix ( basis , coord , zq , dV , logtol ) implicit none type ( basis_set ), intent ( inout ) :: basis real ( kind = dp ), contiguous , intent ( in ) :: coord (:,:), zq (:) real ( kind = dp ), intent ( out ) :: dV (:,:,:,:) ! (nbf, nbf, 3, natom) real ( kind = dp ), optional :: logtol INTEGER :: ii , jj , ic , c , i , j , gi , gj , A_at , B_at , oi , oj , nat REAL ( kind = dp ) :: tol , dba , dbc REAL ( kind = dp ), ALLOCATABLE :: dA (:,:,:), dC (:,:,:), sA (:,:,:), sC (:,:,:) TYPE ( shell_t ) :: shi , shj TYPE ( shpair_t ) :: cntp if ( present ( logtol )) then tol = logtol else tol = tol_default end if nat = ubound ( coord , 2 ) dV = 0.0d0 CALL cntp % alloc ( basis ) DO ii = 1 , basis % nshell CALL shi % fetch_by_id ( basis , ii ) A_at = shi % atid oi = basis % ao_offset ( ii ) - 1 DO jj = 1 , basis % nshell CALL shj % fetch_by_id ( basis , jj ) B_at = shj % atid oj = basis % ao_offset ( jj ) - 1 CALL cntp % shell_pair ( basis , shi , shj , tol ) IF ( cntp % numpairs == 0 ) CYCLE allocate ( dA ( cntp % inao , cntp % jnao , 3 ), dC ( cntp % inao , cntp % jnao , 3 )) DO ic = 1 , nat dA = 0.0d0 ; dC = 0.0d0 CALL comp_coulomb_der1_block ( cntp , coord (:, ic ), - zq ( ic ), dA ) CALL comp_coulomb_helfeyder1_block ( cntp , coord (:, ic ), - zq ( ic ), dC ) CALL reduce_der1_shell_block ( basis , ii , jj , dA , sA ) CALL reduce_der1_shell_block ( basis , ii , jj , dC , sC ) DO c = 1 , 3 DO i = 1 , basis % naos ( ii ) gi = oi + i DO j = 1 , basis % naos ( jj ) gj = oj + j dba = sA ( i , j , c ); dbc = sC ( i , j , c ) dV ( gi , gj , c , A_at ) = dV ( gi , gj , c , A_at ) + dba dV ( gi , gj , c , ic ) = dV ( gi , gj , c , ic ) + dbc dV ( gi , gj , c , B_at ) = dV ( gi , gj , c , B_at ) - ( dba + dbc ) END DO END DO END DO deallocate ( sA , sC ) END DO deallocate ( dA , dC ) END DO END DO END SUBROUTINE !------------------------------------------------------------------------------- !> @brief Build the AO kinetic-energy first-derivative matrices dT_uv/dR for !>   every nuclear coordinate (a CPHF right-hand-side building block). Same !>   structure and conventions as der_overlap_matrix, using comp_kinetic_der1_block. SUBROUTINE der_kinetic_matrix ( basis , dT , logtol ) implicit none type ( basis_set ), intent ( inout ) :: basis real ( kind = dp ), intent ( out ) :: dT (:,:,:,:) ! (nbf, nbf, 3, natom) real ( kind = dp ), optional :: logtol INTEGER :: ii , jj , c , i , j , gi , gj , A_at , B_at , oi , oj REAL ( kind = dp ) :: tol REAL ( kind = dp ), ALLOCATABLE :: dblk (:,:,:), sblk (:,:,:) TYPE ( shell_t ) :: shi , shj TYPE ( shpair_t ) :: cntp if ( present ( logtol )) then tol = logtol else tol = tol_default end if dT = 0.0d0 CALL cntp % alloc ( basis ) DO ii = 1 , basis % nshell CALL shi % fetch_by_id ( basis , ii ) A_at = shi % atid oi = basis % ao_offset ( ii ) - 1 DO jj = 1 , basis % nshell CALL shj % fetch_by_id ( basis , jj ) B_at = shj % atid oj = basis % ao_offset ( jj ) - 1 CALL cntp % shell_pair ( basis , shi , shj , tol , dup = . false .) IF ( cntp % numpairs == 0 ) CYCLE allocate ( dblk ( cntp % inao , cntp % jnao , 3 ), source = 0.0d0 ) CALL comp_kinetic_der1_block ( cntp , dblk ) CALL reduce_der1_shell_block ( basis , ii , jj , dblk , sblk ) DO c = 1 , 3 DO i = 1 , basis % naos ( ii ) gi = oi + i DO j = 1 , basis % naos ( jj ) gj = oj + j dT ( gi , gj , c , A_at ) = dT ( gi , gj , c , A_at ) + sblk ( i , j , c ) dT ( gi , gj , c , B_at ) = dT ( gi , gj , c , B_at ) - sblk ( i , j , c ) END DO END DO END DO deallocate ( dblk , sblk ) END DO END DO END SUBROUTINE !------------------------------------------------------------------------------- !> @brief Basis function derivative contributions to gradient !> @details Compute derivative integrals of type <ii'|h|jj> = <ii'|t+v|jj> !> @note No relativistic methods available ! !> @author Vladimir Mironov ! !   REVISION HISTORY: !> @date _Sep, 2018_ Initial release !> !> @param[in,out]   denab   density matrix in packed format, remains unchanged on return SUBROUTINE grad_en_pulay ( basis , coord , zq , denab , de , logtol ) REAL ( kind = dp ), INTENT ( INOUT ) :: denab (:) type ( basis_set ), intent ( inout ) :: basis real ( kind = dp ), contiguous , intent ( in ) :: coord (:,:), zq (:) REAL ( kind = dp ) :: de (:,:) INTEGER :: ii , jj , ic REAL ( kind = dp ), optional :: logtol REAL ( kind = dp ) :: de1 ( 3 ) REAL ( kind = dp ), ALLOCATABLE :: de_priv (:,:), dens (:,:) INTEGER , ALLOCATABLE :: off (:) REAL ( kind = dp ) :: dernuc ( 3 ), tol TYPE ( shell_t ) :: shi , shj TYPE ( shpair_t ) :: cntp INTEGER :: nat nat = ubound ( de , 2 ) if ( present ( logtol )) then tol = logtol else tol = tol_default end if call prepare_grad_density ( basis , denab , dens , off ) !   temporary storage for 1e gradient ALLOCATE ( de_priv , mold = de ) de_priv = 0.0d0 !$omp parallel & !$omp   private( & !$omp       ii, jj, ic, & !$omp       shi, shj, cntp, & !$omp       dernuc, & !$omp       de1 & !$omp   ) & !$omp   reduction(+:de_priv) CALL cntp % alloc ( basis ) !$omp do schedule(dynamic) !   I shell DO ii = 1 , basis % nshell CALL shi % fetch_by_id ( basis , ii ) de1 = 0.0 !       J shell DO jj = 1 , basis % nshell CALL shj % fetch_by_id ( basis , jj ) CALL cntp % shell_pair ( basis , shi , shj , tol , dup = . false .) IF ( cntp % numpairs == 0 ) CYCLE !           Nuclear attraction derivative DO ic = 1 , nat CALL comp_coulomb_der1 ( cntp , coord (:, ic ), - zq ( ic ), dens ( off ( ii ):, off ( jj ):), dernuc ) de1 = de1 + 2 * dernuc ( 1 : 3 ) END DO !           End of primitive loops END DO de_priv (:, shi % atid ) = de_priv (:, shi % atid ) + de1 (:) END DO !$omp end do !   End of shell loops !$omp end parallel de = de + de_priv DEALLOCATE ( de_priv ) END SUBROUTINE !------------------------------------------------------------------------------- !> @brief Basis function derivative contributions to gradient from external charges !> @details Compute derivative integrals of type <ii'|h|jj> = <ii'|t+v|jj> !> @note No relativistic methods available ! !> @author Vladimir Mironov ! !   REVISION HISTORY: !> @date _Sep, 2018_ Initial release !> !> @param[in,out]   denab   density matrix in packed format, remains unchanged on return SUBROUTINE omp_extder ( basis , de , denab , ext_charges , de_mm , logtol , alpha ) type ( basis_set ), intent ( inout ) :: basis REAL ( kind = dp ), INTENT ( INOUT ) :: denab (:) REAL ( kind = dp ) :: de (:,:) REAL ( kind = dp ) :: ext_charges (:,:) REAL ( kind = dp ), optional :: de_mm (:,:) REAL ( kind = dp ), optional :: logtol REAL ( kind = dp ), optional :: alpha INTEGER :: ii , jj , ic REAL ( kind = dp ) :: tol , znuc REAL ( kind = dp ) :: de1 ( 3 ), de2 ( 3 ) REAL ( kind = dp ) :: dernuc ( 3 ), cxyz ( 3 ) TYPE ( shell_t ) :: shi , shj TYPE ( shpair_t ) :: cntp REAL ( kind = dp ), ALLOCATABLE :: de_priv (:,:), dens (:,:) INTEGER , ALLOCATABLE :: off (:) if ( present ( logtol )) then tol = logtol else tol = tol_default end if call prepare_grad_density ( basis , denab , dens , off ) !   temporary storage for 1e gradient ALLOCATE ( de_priv , mold = de ) de_priv (:,:) = 0.0 !$omp parallel & !$omp   private( & !$omp       ii, jj, ic, & !$omp       shi, shj, cntp, & !$omp       dernuc, & !$omp       znuc, cxyz, & !$omp       de1, de2 & !$omp   ) & !$omp   reduction(+:de_priv) CALL cntp % alloc ( basis ) !   I shell DO ii = 1 , basis % nshell CALL shi % fetch_by_id ( basis , ii ) de1 (:) = 0.0 de2 (:) = 0.0 !       J shell DO jj = 1 , basis % nshell CALL shj % fetch_by_id ( basis , jj ) CALL cntp % shell_pair ( basis , shi , shj , tol , dup = . false .) IF ( cntp % numpairs == 0 ) CYCLE !           External charges (QM/MM) !$omp do schedule(dynamic,4) DO ic = 1 , ubound ( ext_charges , 2 ) cxyz = ext_charges ( 1 : 3 , ic ) znuc = - ext_charges ( 4 , ic ) !                IF ( doscr & !                    .AND. (znuc**2 < scrthr**2 * sum((cxyz-shi%r)**2)) ) CYCLE CALL comp_coulomb_der1 ( cntp , cxyz , znuc , dens ( off ( ii ):, off ( jj ):), dernuc ) ! Ewald screening IF ( present ( alpha )) THEN CALL comp_ewaldlr_der1 ( cntp , cxyz , - znuc , dens ( off ( ii ):, off ( jj ):), alpha , dernuc ) END IF de1 = de1 + 2 * dernuc ( 1 : 3 ) ! Add gradient contribution to MM atoms? if ( present ( de_mm )) then de_mm (:, ic ) = de_mm (:, ic ) - 2 * dernuc ( 1 : 3 ) end if END DO !$omp end do nowait END DO de_priv ( 1 : 3 , shi % atid ) = de_priv ( 1 : 3 , shi % atid ) + de1 ( 1 : 3 ) END DO !   End of shell loops !$omp end parallel de = de + de_priv DEALLOCATE ( de_priv ) END SUBROUTINE !------------------------------------------------------------------------------- !> @brief Hellmann-Feynman force !> @details Compute derivative contributions due to the Hamiltonian !>   operator change w.r.t. shifts of nuclei. The contribution !>   of the form <i|T'+V'|j> is evaluated by Gauss-Rys quadrature. !>   This version handles spdfg and L shells. !> @note No relativistic methods available ! !> @author Vladimir Mironov ! !   REVISION HISTORY: !> @date _Sep, 2018_ Initial release !> !> @param[in,out]   denab   density matrix in packed format, remains unchanged on return SUBROUTINE grad_en_hellman_feynman ( basis , coord , zq , denab , de , logtol ) !$  use omp_lib, ONLY: omp_get_max_threads type ( basis_set ), intent ( inout ) :: basis real ( kind = dp ), contiguous , intent ( in ) :: coord (:,:), zq (:) REAL ( kind = dp ), INTENT ( INOUT ) :: denab (:) REAL ( kind = dp ) :: de (:,:) INTEGER :: ii , jj , ic REAL ( kind = dp ), optional :: logtol REAL ( kind = dp ) :: dernuc ( 3 ), tol TYPE ( shell_t ) :: shi , shj TYPE ( shpair_t ) :: cntp REAL ( kind = dp ), ALLOCATABLE :: de_priv (:,:), dens (:,:) INTEGER , ALLOCATABLE :: off (:) INTEGER :: nat nat = ubound ( de , 2 ) if ( present ( logtol )) then tol = logtol else tol = tol_default end if call prepare_grad_density ( basis , denab , dens , off ) !   temporary storage for 1e gradient ALLOCATE ( de_priv , mold = de ) de_priv = 0.0d0 !   Initialize parallel !$omp parallel & !$omp   num_threads(min(omp_get_max_threads(), nat)) & !$omp   reduction(+:de_priv) & !$omp   private( & !$omp       ii, jj, ic, & !$omp       shi, shj, cntp, & !$omp       dernuc & !$omp   ) CALL cntp % alloc ( basis ) !   I shell !$omp do schedule(dynamic) DO ii = 1 , basis % nshell CALL shi % fetch_by_id ( basis , ii ) !       J shell DO jj = 1 , basis % nshell CALL shj % fetch_by_id ( basis , jj ) CALL cntp % shell_pair ( basis , shi , shj , tol ) IF ( cntp % numpairs == 0 ) CYCLE !           Hellmann-Feynman term atoms : DO ic = 1 , nat CALL comp_coulomb_helfeyder1 ( cntp , coord (:, ic ), - zq ( ic ), dens ( off ( ii ):, off ( jj ):), dernuc ) de_priv (:, ic ) = de_priv (:, ic ) + dernuc (: 3 ) END DO atoms END DO END DO !$omp end do !   End of shell loops !$omp end parallel de (:, 1 : nat ) = de (:, 1 : nat ) + de_priv (: 3 , 1 : nat ) DEALLOCATE ( de_priv ) END SUBROUTINE !------------------------------------------------------------------------------- !> @brief Gradient of nuclear repulsion energy subroutine grad_nn ( atoms , ecp_el ) implicit none type ( atomic_structure ), intent ( inout ) :: atoms integer , intent ( in ) :: ecp_el (:) integer :: k , l real ( kind = dp ) :: pkl ( 3 ), rkl3 , de1 ( 3 ) do k = 2 , ubound ( atoms % zn , 1 ) do l = 1 , k - 1 pkl = atoms % xyz (:, k ) - atoms % xyz (:, l ) rkl3 = norm2 ( pkl ) ** 3 de1 = - ( atoms % zn ( k ) - ecp_el ( k )) * ( atoms % zn ( l ) - ecp_el ( l )) * pkl / rkl3 atoms % grad (:, k ) = atoms % grad (:, k ) + de1 atoms % grad (:, l ) = atoms % grad (:, l ) - de1 end do end do end subroutine grad_nn !------------------------------------------------------------------------------- !> @brief Nuclear-repulsion contribution to the Cartesian Hessian. !> @details Accumulates the second derivatives of the nuclear-repulsion energy !>   E_nn = sum_{k>l} Zk*Zl / r_kl into the (3N, 3N) Hessian in OpenQP !>   atom-major coordinate order (x1,y1,z1,x2,...). For each pair (k,l) the !>   3x3 block is  Zk*Zl * (3 p_a p_b / r&#94;5 - delta_ab / r&#94;3), with p = r_k-r_l; !>   it is added to the (k,k) and (l,l) diagonal blocks and subtracted from the !>   (k,l) and (l,k) off-diagonal blocks. Effective nuclear charges use the same !>   (zn - ecp_el) convention as grad_nn. The result is added in place so the !>   routine composes with the electronic Hessian terms. subroutine hess_nn ( atoms , ecp_el , hess ) implicit none type ( atomic_structure ), intent ( in ) :: atoms integer , intent ( in ) :: ecp_el (:) real ( kind = dp ), intent ( inout ) :: hess (:,:) integer :: k , l , a , b , ka , lb real ( kind = dp ) :: pkl ( 3 ), r , r2 , r3 , zz , blk ( 3 , 3 ) do k = 2 , ubound ( atoms % zn , 1 ) do l = 1 , k - 1 pkl = atoms % xyz (:, k ) - atoms % xyz (:, l ) r = norm2 ( pkl ) r2 = r * r r3 = r * r2 zz = ( atoms % zn ( k ) - ecp_el ( k )) * ( atoms % zn ( l ) - ecp_el ( l )) do a = 1 , 3 do b = 1 , 3 blk ( b , a ) = zz * 3.0_dp * pkl ( b ) * pkl ( a ) / ( r2 * r3 ) if ( a == b ) blk ( b , a ) = blk ( b , a ) - zz / r3 end do end do do a = 1 , 3 ka = 3 * ( k - 1 ) + a lb = 3 * ( l - 1 ) + a do b = 1 , 3 hess ( 3 * ( k - 1 ) + b , ka ) = hess ( 3 * ( k - 1 ) + b , ka ) + blk ( b , a ) hess ( 3 * ( l - 1 ) + b , lb ) = hess ( 3 * ( l - 1 ) + b , lb ) + blk ( b , a ) hess ( 3 * ( k - 1 ) + b , 3 * ( l - 1 ) + a ) = hess ( 3 * ( k - 1 ) + b , 3 * ( l - 1 ) + a ) - blk ( b , a ) hess ( 3 * ( l - 1 ) + b , 3 * ( k - 1 ) + a ) = hess ( 3 * ( l - 1 ) + b , 3 * ( k - 1 ) + a ) - blk ( b , a ) end do end do end do end do end subroutine hess_nn !------------------------------------------------------------------------------- !> @brief Effective core potential gradient subroutine grad_1e_ecp ( infos , basis , coord , denab , de , logtol ) use types , only : information use parallel , only : par_env_t type ( information ), target , intent ( inout ) :: infos type ( par_env_t ) :: pe REAL ( kind = dp ), INTENT ( INOUT ) :: denab (:) type ( basis_set ), intent ( inout ) :: basis real ( kind = dp ), contiguous , intent ( in ) :: coord (:,:) REAL ( kind = dp ) :: de (:,:) REAL ( kind = dp ), optional :: logtol call pe % init ( infos % mpiinfo % comm , infos % mpiinfo % usempi ) if ( pe % rank == 0 ) then call add_ecpder ( basis , coord , denab , de ) end if call pe % bcast ( de , size ( de )) end subroutine grad_1e_ecp !------------------------------------------------------------------------------- end module grd1","tags":"","url":"sourcefile/grd1.f90.html"},{"title":"libint_f.F90 – OpenQP Fortran API","text":"Source Code MODULE libint_f USE ISO_C_BINDING , ONLY : C_DOUBLE , C_PTR , C_NULL_PTR , C_INT , C_FUNPTR , C_F_POINTER , C_F_PROCPOINTER , C_SIZE_T #ifdef OQP_LIBINT_ENABLE #include \"libint2/config.h\" #include \"libint2/util/generated/libint2_params.h\" #include \"fortran_incldefs.h\" #endif IMPLICIT NONE private public :: libint_t public :: libint2_static_init public :: libint2_static_cleanup public :: libint2_init_eri public :: libint2_cleanup_eri public :: libint2_build #ifdef INCLUDE_ERI public :: libint2_build_eri #if INCLUDE_ERI >= 1 public :: libint2_build_eri1 #endif #if INCLUDE_ERI >= 2 public :: libint2_build_eri2 #endif #endif public :: libint2_active logical , parameter :: libint2_active = & #ifdef OQP_LIBINT_ENABLE . true . #else . false . #endif #ifndef OQP_LIBINT_ENABLE type , bind ( C ) :: libint_t type ( c_ptr ) :: targets ( 1 ) end type #endif #ifdef OQP_LIBINT_ENABLE #ifdef LIBINT2_MAX_AM INTEGER , PARAMETER :: libint2_max_am = LIBINT2_MAX_AM #endif #ifdef LIBINT2_MAX_AM_default INTEGER , PARAMETER :: libint2_max_am_default = LIBINT2_MAX_AM_default #else #  error \"LIBINT2_MAX_AM_default is expected to be defined, libint2_params.h is misgenerated\" #endif #ifdef LIBINT2_MAX_AM_default1 INTEGER , PARAMETER :: libint2_max_am_default1 = LIBINT2_MAX_AM_default1 #else INTEGER , PARAMETER :: libint2_max_am_default1 = LIBINT2_MAX_AM_default #endif #ifdef LIBINT2_MAX_AM_default2 INTEGER , PARAMETER :: libint2_max_am_default2 = LIBINT2_MAX_AM_default2 #else INTEGER , PARAMETER :: libint2_max_am_default2 = LIBINT2_MAX_AM_default #endif #ifdef LIBINT2_MAX_AM_eri INTEGER , PARAMETER :: libint2_max_am_eri = LIBINT2_MAX_AM_eri #endif #ifdef LIBINT2_MAX_AM_eri1 INTEGER , PARAMETER :: libint2_max_am_eri1 = LIBINT2_MAX_AM_eri1 #endif #ifdef LIBINT2_MAX_AM_eri2 INTEGER , PARAMETER :: libint2_max_am_eri2 = LIBINT2_MAX_AM_eri2 #endif #ifdef LIBINT2_MAX_AM_3eri INTEGER , PARAMETER :: libint2_max_am_3eri = LIBINT2_MAX_AM_3eri #endif #ifdef LIBINT2_MAX_AM_3eri1 INTEGER , PARAMETER :: libint2_max_am_3eri1 = LIBINT2_MAX_AM_3eri1 #endif #ifdef LIBINT2_MAX_AM_3eri2 INTEGER , PARAMETER :: libint2_max_am_3eri2 = LIBINT2_MAX_AM_3eri2 #endif #ifdef LIBINT2_MAX_AM_2eri INTEGER , PARAMETER :: libint2_max_am_2eri = LIBINT2_MAX_AM_2eri #endif #ifdef LIBINT2_MAX_AM_2eri1 INTEGER , PARAMETER :: libint2_max_am_2eri1 = LIBINT2_MAX_AM_2eri1 #endif #ifdef LIBINT2_MAX_AM_2eri2 INTEGER , PARAMETER :: libint2_max_am_2eri2 = LIBINT2_MAX_AM_2eri2 #endif INTEGER , PARAMETER :: libint2_max_veclen = LIBINT2_MAX_VECLEN #include \"libint2_types_f.h\" #ifdef INCLUDE_ERI TYPE ( C_FUNPTR ), DIMENSION ( 0 : libint2_max_am_eri , 0 : libint2_max_am_eri , 0 : libint2_max_am_eri , 0 : libint2_max_am_eri ), & BIND ( C ) :: libint2_build_eri #if INCLUDE_ERI >= 1 TYPE ( C_FUNPTR ), DIMENSION ( 0 : libint2_max_am_eri1 , 0 : libint2_max_am_eri1 , 0 : libint2_max_am_eri1 , 0 : libint2_max_am_eri1 ), & BIND ( C ) :: libint2_build_eri1 #endif #if INCLUDE_ERI >= 2 TYPE ( C_FUNPTR ), DIMENSION ( 0 : libint2_max_am_eri2 , 0 : libint2_max_am_eri2 , 0 : libint2_max_am_eri2 , 0 : libint2_max_am_eri2 ), & BIND ( C ) :: libint2_build_eri2 #endif #endif #ifdef INCLUDE_ERI2 TYPE ( C_FUNPTR ), DIMENSION ( 0 : libint2_max_am_2eri , 0 : libint2_max_am_2eri ), & BIND ( C ) :: libint2_build_2eri #if INCLUDE_ERI2 >= 1 TYPE ( C_FUNPTR ), DIMENSION ( 0 : libint2_max_am_2eri1 , 0 : libint2_max_am_2eri1 ), & BIND ( C ) :: libint2_build_2eri1 #endif #if INCLUDE_ERI2 >= 2 TYPE ( C_FUNPTR ), DIMENSION ( 0 : libint2_max_am_2eri2 , 0 : libint2_max_am_2eri2 ), & BIND ( C ) :: libint2_build_2eri2 #endif #endif #ifdef INCLUDE_ERI3 TYPE ( C_FUNPTR ), DIMENSION ( 0 : libint2_max_am_default , 0 : libint2_max_am_default , 0 : libint2_max_am_3eri ), & BIND ( C ) :: libint2_build_3eri #if INCLUDE_ERI3 >= 1 TYPE ( C_FUNPTR ), DIMENSION ( 0 : libint2_max_am_default1 , 0 : libint2_max_am_default1 , 0 : libint2_max_am_3eri1 ), & BIND ( C ) :: libint2_build_3eri1 #endif #if INCLUDE_ERI3 >= 2 TYPE ( C_FUNPTR ), DIMENSION ( 0 : libint2_max_am_default2 , 0 : libint2_max_am_default2 , 0 : libint2_max_am_3eri2 ), & BIND ( C ) :: libint2_build_3eri2 #endif #endif INTERFACE SUBROUTINE libint2_static_init () BIND ( C ) END SUBROUTINE SUBROUTINE libint2_static_cleanup () BIND ( C ) END SUBROUTINE #ifdef INCLUDE_ERI SUBROUTINE libint2_init_eri ( libint , max_am , buf ) BIND ( C ) IMPORT TYPE ( libint_t ), DIMENSION ( * ) :: libint INTEGER ( KIND = C_INT ), VALUE :: max_am TYPE ( C_PTR ), VALUE :: buf END SUBROUTINE SUBROUTINE libint2_cleanup_eri ( libint ) BIND ( C ) IMPORT TYPE ( libint_t ), DIMENSION ( * ) :: libint END SUBROUTINE FUNCTION libint2_need_memory_eri ( max_am ) BIND ( C ) IMPORT INTEGER ( KIND = C_INT ), VALUE :: max_am INTEGER ( KIND = C_SIZE_T ) :: libint2_need_memory_eri END FUNCTION #if INCLUDE_ERI >= 1 SUBROUTINE libint2_init_eri1 ( libint , max_am , buf ) BIND ( C ) IMPORT TYPE ( libint_t ), DIMENSION ( * ) :: libint INTEGER ( KIND = C_INT ), VALUE :: max_am TYPE ( C_PTR ), VALUE :: buf END SUBROUTINE SUBROUTINE libint2_cleanup_eri1 ( libint ) BIND ( C ) IMPORT TYPE ( libint_t ), DIMENSION ( * ) :: libint END SUBROUTINE FUNCTION libint2_need_memory_eri1 ( max_am ) BIND ( C ) IMPORT INTEGER ( KIND = C_INT ), VALUE :: max_am INTEGER ( KIND = C_SIZE_T ) :: libint2_need_memory_eri1 END FUNCTION #endif #if INCLUDE_ERI >= 2 SUBROUTINE libint2_init_eri2 ( libint , max_am , buf ) BIND ( C ) IMPORT TYPE ( libint_t ), DIMENSION ( * ) :: libint INTEGER ( KIND = C_INT ), VALUE :: max_am TYPE ( C_PTR ), VALUE :: buf END SUBROUTINE SUBROUTINE libint2_cleanup_eri2 ( libint ) BIND ( C ) IMPORT TYPE ( libint_t ), DIMENSION ( * ) :: libint END SUBROUTINE FUNCTION libint2_need_memory_eri2 ( max_am ) BIND ( C ) IMPORT INTEGER ( KIND = C_INT ), VALUE :: max_am INTEGER ( KIND = C_SIZE_T ) :: libint2_need_memory_eri2 END FUNCTION #endif #endif #ifdef INCLUDE_ERI2 SUBROUTINE libint2_init_2eri ( libint , max_am , buf ) BIND ( C ) IMPORT TYPE ( libint_t ), DIMENSION ( * ) :: libint INTEGER ( KIND = C_INT ), VALUE :: max_am TYPE ( C_PTR ), VALUE :: buf END SUBROUTINE SUBROUTINE libint2_cleanup_2eri ( libint ) BIND ( C ) IMPORT TYPE ( libint_t ), DIMENSION ( * ) :: libint END SUBROUTINE FUNCTION libint2_need_memory_2eri ( max_am ) BIND ( C ) IMPORT INTEGER ( KIND = C_INT ), VALUE :: max_am INTEGER ( KIND = C_SIZE_T ) :: libint2_need_memory_2eri END FUNCTION #if INCLUDE_ERI2 >= 1 SUBROUTINE libint2_init_2eri1 ( libint , max_am , buf ) BIND ( C ) IMPORT TYPE ( libint_t ), DIMENSION ( * ) :: libint INTEGER ( KIND = C_INT ), VALUE :: max_am TYPE ( C_PTR ), VALUE :: buf END SUBROUTINE SUBROUTINE libint2_cleanup_2eri1 ( libint ) BIND ( C ) IMPORT TYPE ( libint_t ), DIMENSION ( * ) :: libint END SUBROUTINE FUNCTION libint2_need_memory_2eri1 ( max_am ) BIND ( C ) IMPORT INTEGER ( KIND = C_INT ), VALUE :: max_am INTEGER ( KIND = C_SIZE_T ) :: libint2_need_memory_2eri1 END FUNCTION #endif #if INCLUDE_ERI2 >= 2 SUBROUTINE libint2_init_2eri2 ( libint , max_am , buf ) BIND ( C ) IMPORT TYPE ( libint_t ), DIMENSION ( * ) :: libint INTEGER ( KIND = C_INT ), VALUE :: max_am TYPE ( C_PTR ), VALUE :: buf END SUBROUTINE SUBROUTINE libint2_cleanup_2eri2 ( libint ) BIND ( C ) IMPORT TYPE ( libint_t ), DIMENSION ( * ) :: libint END SUBROUTINE FUNCTION libint2_need_memory_2eri2 ( max_am ) BIND ( C ) IMPORT INTEGER ( KIND = C_INT ), VALUE :: max_am INTEGER ( KIND = C_SIZE_T ) :: libint2_need_memory_2eri2 END FUNCTION #endif #endif #ifdef INCLUDE_ERI3 SUBROUTINE libint2_init_3eri ( libint , max_am , buf ) BIND ( C ) IMPORT TYPE ( libint_t ), DIMENSION ( * ) :: libint INTEGER ( KIND = C_INT ), VALUE :: max_am TYPE ( C_PTR ), VALUE :: buf END SUBROUTINE SUBROUTINE libint2_cleanup_3eri ( libint ) BIND ( C ) IMPORT TYPE ( libint_t ), DIMENSION ( * ) :: libint END SUBROUTINE FUNCTION libint2_need_memory_3eri ( max_am ) BIND ( C ) IMPORT INTEGER ( KIND = C_INT ), VALUE :: max_am INTEGER ( KIND = C_SIZE_T ) :: libint2_need_memory_3eri END FUNCTION #if INCLUDE_ERI3 >= 1 SUBROUTINE libint2_init_3eri1 ( libint , max_am , buf ) BIND ( C ) IMPORT TYPE ( libint_t ), DIMENSION ( * ) :: libint INTEGER ( KIND = C_INT ), VALUE :: max_am TYPE ( C_PTR ), VALUE :: buf END SUBROUTINE SUBROUTINE libint2_cleanup_3eri1 ( libint ) BIND ( C ) IMPORT TYPE ( libint_t ), DIMENSION ( * ) :: libint END SUBROUTINE FUNCTION libint2_need_memory_3eri1 ( max_am ) BIND ( C ) IMPORT INTEGER ( KIND = C_INT ), VALUE :: max_am INTEGER ( KIND = C_SIZE_T ) :: libint2_need_memory_3eri1 END FUNCTION #endif #if INCLUDE_ERI3 >= 2 SUBROUTINE libint2_init_3eri2 ( libint , max_am , buf ) BIND ( C ) IMPORT TYPE ( libint_t ), DIMENSION ( * ) :: libint INTEGER ( KIND = C_INT ), VALUE :: max_am TYPE ( C_PTR ), VALUE :: buf END SUBROUTINE SUBROUTINE libint2_cleanup_3eri2 ( libint ) BIND ( C ) IMPORT TYPE ( libint_t ), DIMENSION ( * ) :: libint END SUBROUTINE FUNCTION libint2_need_memory_3eri2 ( max_am ) BIND ( C ) IMPORT INTEGER ( KIND = C_INT ), VALUE :: max_am INTEGER ( KIND = C_SIZE_T ) :: libint2_need_memory_3eri2 END FUNCTION #endif #endif END INTERFACE ABSTRACT INTERFACE SUBROUTINE libint2_build ( libint ) BIND ( C ) IMPORT TYPE ( libint_t ), DIMENSION ( * ) :: libint END SUBROUTINE END INTERFACE #else CONTAINS subroutine libint2_init_eri ( libint , max_am , buf ) bind ( c ) type ( libint_t ), dimension ( * ) :: libint integer ( kind = c_int ), value :: max_am type ( c_ptr ), value :: buf end subroutine subroutine libint2_cleanup_eri ( libint ) bind ( c ) type ( libint_t ), dimension ( * ) :: libint end subroutine subroutine libint2_build ( libint ) bind ( c ) type ( libint_t ), dimension ( * ) :: libint end subroutine subroutine libint2_static_init () bind ( c ) end subroutine subroutine libint2_static_cleanup () bind ( c ) end subroutine #endif END MODULE","tags":"","url":"sourcefile/libint_f.f90.html"},{"title":"tdhf_mrsf_z_vector.F90 – OpenQP Fortran API","text":"Source Code module tdhf_mrsf_z_vector_mod use precision , only : dp use , intrinsic :: ieee_arithmetic , only : ieee_is_finite , ieee_value , ieee_quiet_nan use zvector_common , only : sanitize_zvector_preconditioner implicit none character ( len =* ), parameter :: module_name = \"tdhf_mrsf_z_vector_mod\" real ( kind = dp ), parameter :: GMRES_DENOMINATOR_FLOOR = 1.0d-14 real ( kind = dp ), parameter :: MRSF_ZVEC_DENOMINATOR_FLOOR = 1.0d-14 ! Module-level work arrays for GMRES to avoid repeated allocation real ( kind = 8 ), allocatable :: gmres_wrk1 (:,:), gmres_wrk2 (:,:), gmres_wrk3 (:,:) real ( kind = 8 ), allocatable , target :: gmres_pa (:,:,:) real ( kind = 8 ), allocatable :: gmres_ab1_mo_a (:,:), gmres_ab1_mo_b (:,:) logical :: gmres_work_allocated = . false . integer :: gmres_nbf = 0 integer :: gmres_nocca = 0 integer :: gmres_noccb = 0 ! ---------------------------------------------------------------------------- ! Optional per-iteration profiling of the MRSF z-vector (CPHF/CPKS) solve. ! Default OFF; enabled by setting env OQP_MRSF_ZV_TIMERS to a non-empty value. ! Wall-clock seconds are accumulated per section and reported at the end of ! each tdhf_mrsf_z_vector call (reset at the start of every call). ! ---------------------------------------------------------------------------- logical , save :: zv_tmr_on = . false . logical , save :: zv_tmr_init = . false . real ( kind = dp ), save :: zv_t_rhs = 0.0_dp !< RHS assembly real ( kind = dp ), save :: zv_t_int2 = 0.0_dp !< per-iter 2e digestion (int2_driver%run) real ( kind = dp ), save :: zv_t_xc = 0.0_dp !< per-iter XC kernel (utddft_fxc) real ( kind = dp ), save :: zv_t_trans = 0.0_dp !< per-iter AO/MO transforms + operator apply real ( kind = dp ), save :: zv_t_cg = 0.0_dp !< per-iter linear-solver vector algebra real ( kind = dp ), save :: zv_t_back = 0.0_dp !< relaxed-density / W back-projection integer , save :: zv_n_iter = 0 !< iterations performed by the chosen solver ! ---------------------------------------------------------------------------- ! Performance controls for the MRSF z-vector solve (read once from env). !   OQP_MRSF_ZV_WARMSTART  : seed from the previous step's solution. DEFAULT ON !                            (=0/n/f to disable). Cannot change a converged !                            result -- only the iteration count. !   OQP_MRSF_ZV_PROG       : progressive (iteration-dependent) screening. !                            DEFAULT ON (=0/n/f to disable). Perturbs the !                            gradient by <~1e-8 (small systems) to ~7e-6 (large), !                            within the gradient gate but NOT bit-identical. !   OQP_MRSF_ZV_CONV       : override the convergence tol (default 1e-10 kept). !   OQP_MRSF_ZV_CUTOFF     : static loose 2e cutoff (off; superseded by _PROG). ! ---------------------------------------------------------------------------- logical , save :: zv_cfg_init = . false . logical , save :: zv_warm_on = . false . real ( kind = dp ), save :: zv_conv_user = - 1.0_dp !< <0 => not set real ( kind = dp ), save :: zv_cutoff_user = - 1.0_dp !< <0 => not set ! Progressive (iteration-dependent) integral screening for the CG solve. ! Loose cutoff while the residual is large (the search direction is inexact ! anyway), tightened toward the tight floor and PINNED exact once the residual ! is small, so the converged z-vector / gradient matches the all-tight run. ! tau(k) = clamp(prog_k * ||r_{k-1}||, tight_floor, prog_cap); tau=tight once ! ||r||&#94;2 < prog_pin. Same coupling idea as feat/progressive-screening-scf. logical , save :: zv_prog_on = . false . real ( kind = dp ), save :: zv_prog_k = 1.0e-2_dp !< tau = k*residual_norm real ( kind = dp ), save :: zv_prog_cap = 1.0e-6_dp !< loosest tau (upper clamp) real ( kind = dp ), save :: zv_prog_pin = 1.0e-6_dp !< pin tau=tight once error(=||r||&#94;2) < this ! Cold-start initial guess: Jacobi x0 = M&#94;-1 rhs instead of x0 = 0. The cold CG ! already spends one sigma build on A*x0 (=0 when x0=0), so this is free and ! puts the solve ~1 iteration ahead. DEFAULT ON; disable with OQP_MRSF_ZV_DIAGGUESS=0. ! Accuracy-safe (linear solve converges to the same A&#94;-1 rhs) and protected by ! the CG safeguard (falls back to zero if it doesn't reduce the residual). logical , save :: zv_diag_guess = . false . ! Coarser DFT grid for the z-vector XC kernel than the SCF grid (the response ! tolerates a coarser grid). Shrinks the dominant per-iteration utddft_fxc cost. ! The grid is selected by the pruned-grid NAME (SG0 < SG1 < SG2(default) < SG3); ! the lever swaps to a coarser named grid for the z-vector only. DEFAULT OFF ! (env OQP_MRSF_ZV_COARSEGRID=1); grid choice via OQP_MRSF_ZV_GRID (default SG1). logical , save :: zv_coarse_on = . false . character ( len = 8 ), save :: zv_grid_name = 'SG1' ! Warm-start store (module-level; persists across the geometry/MD steps that ! share one process). The converged z-vector varies smoothly along a path, so ! the previous step's solution is a strong initial guess for the LINEAR CPHF ! solve. Correctness is unconditional: the iterative solver still converges to ! the same residual tolerance, so only the iteration count changes -- the ! guess can never bias the gradient. Keyed by target state; reset when the ! problem dimension (basis/occupation) changes. real ( kind = dp ), allocatable , save :: zv_warm (:,:) logical , allocatable , save :: zv_warm_has (:) integer , save :: zv_warm_lzdim = 0 ! Old MO coefficients from the step that filled the cache, for MO-basis ! projection of the warm guess (handles MO rotation between steps so warm-start ! also helps large optimizer steps, not just small MD steps). real ( kind = dp ), allocatable , save :: zv_warm_moa (:,:), zv_warm_mob (:,:) logical , save :: zv_warm_have_mo = . false . integer , save :: zv_warm_nbf = 0 contains ! Wall-clock seconds (monotonic), for the optional z-vector profiler. function zv_wtime () result ( t ) real ( kind = dp ) :: t integer ( kind = 8 ) :: c , r call system_clock ( c , r ) if ( r > 0_8 ) then t = real ( c , dp ) / real ( r , dp ) else t = 0.0_dp end if end function zv_wtime ! Read the OQP_MRSF_ZV_TIMERS opt-in once and reset the accumulators. subroutine zv_timers_begin () character ( len = 8 ) :: e_ if (. not . zv_tmr_init ) then call get_environment_variable ( 'OQP_MRSF_ZV_TIMERS' , e_ ) zv_tmr_on = len_trim ( e_ ) > 0 zv_tmr_init = . true . end if zv_t_rhs = 0.0_dp ; zv_t_int2 = 0.0_dp ; zv_t_xc = 0.0_dp zv_t_trans = 0.0_dp ; zv_t_cg = 0.0_dp ; zv_t_back = 0.0_dp zv_n_iter = 0 end subroutine zv_timers_begin ! Emit the accumulated per-section breakdown (no-op unless timers are on). subroutine zv_timers_report ( log_unit , solver_name ) integer , intent ( in ) :: log_unit character ( len =* ), intent ( in ) :: solver_name real ( kind = dp ) :: tot , sigma if (. not . zv_tmr_on ) return sigma = zv_t_int2 + zv_t_xc + zv_t_trans tot = zv_t_rhs + sigma + zv_t_cg + zv_t_back write ( log_unit , '(/1x,\"==== MRSF Z-VECTOR PROFILE (\",a,\") ====\")' ) trim ( solver_name ) write ( log_unit , '(1x,\"Iterations                 : \",i8)' ) zv_n_iter write ( log_unit , '(1x,\"RHS build            (s)   : \",f12.4)' ) zv_t_rhs write ( log_unit , '(1x,\"Per-iter 2e digestion(s)   : \",f12.4)' ) zv_t_int2 write ( log_unit , '(1x,\"Per-iter XC kernel   (s)   : \",f12.4)' ) zv_t_xc write ( log_unit , '(1x,\"Per-iter transforms  (s)   : \",f12.4)' ) zv_t_trans write ( log_unit , '(1x,\"  -> sigma/Fock build(s)   : \",f12.4)' ) sigma write ( log_unit , '(1x,\"Per-iter CG algebra  (s)   : \",f12.4)' ) zv_t_cg write ( log_unit , '(1x,\"Back-projection      (s)   : \",f12.4)' ) zv_t_back write ( log_unit , '(1x,\"Sum of sections      (s)   : \",f12.4)' ) tot if ( zv_n_iter > 0 ) & write ( log_unit , '(1x,\"Avg sigma / iteration(s)   : \",f12.4)' ) sigma / real ( zv_n_iter , dp ) write ( log_unit , '(1x,\"=========================================\")' ) call flush ( log_unit ) end subroutine zv_timers_report ! Read the z-vector config once: warm-start from the control struct ([tdhf] ! zv_warmstart); the remaining opt-in levers from their env vars (advanced). subroutine zv_read_config ( infos ) use types , only : information type ( information ), intent ( in ) :: infos character ( len = 32 ) :: e_ integer :: ios ! Warm-start is control-backed ([tdhf] zv_warmstart): refresh it on EVERY call so a ! per-calculation override applies in long-lived (e.g. Python) workflows. It is ! result-neutral (a CG initial guess only; the solve still converges to the same ! tolerance), so it cannot change a converged single-point gradient. zv_warm_on = ( infos % control % mrsf_zv_warmstart /= 0 ) ! The remaining levers are env-only and read once. if ( zv_cfg_init ) return call get_environment_variable ( 'OQP_MRSF_ZV_CONV' , e_ ) if ( len_trim ( e_ ) > 0 ) then read ( e_ , * , iostat = ios ) zv_conv_user if ( ios /= 0 ) zv_conv_user = - 1.0_dp end if call get_environment_variable ( 'OQP_MRSF_ZV_CUTOFF' , e_ ) if ( len_trim ( e_ ) > 0 ) then read ( e_ , * , iostat = ios ) zv_cutoff_user if ( ios /= 0 ) zv_cutoff_user = - 1.0_dp end if ! Opt-in, DEFAULT OFF (upstream convention; enable with OQP_MRSF_ZV_PROG=1). call get_environment_variable ( 'OQP_MRSF_ZV_PROG' , e_ ) zv_prog_on = len_trim ( e_ ) > 0 . and . ( e_ ( 1 : 1 ) == '1' . or . e_ ( 1 : 1 ) == 'y' . or . & e_ ( 1 : 1 ) == 'Y' . or . e_ ( 1 : 1 ) == 't' . or . e_ ( 1 : 1 ) == 'T' ) call get_environment_variable ( 'OQP_MRSF_ZV_PROG_K' , e_ ) if ( len_trim ( e_ ) > 0 ) read ( e_ , * , iostat = ios ) zv_prog_k call get_environment_variable ( 'OQP_MRSF_ZV_PROG_CAP' , e_ ) if ( len_trim ( e_ ) > 0 ) read ( e_ , * , iostat = ios ) zv_prog_cap call get_environment_variable ( 'OQP_MRSF_ZV_PROG_PIN' , e_ ) if ( len_trim ( e_ ) > 0 ) read ( e_ , * , iostat = ios ) zv_prog_pin ! Jacobi cold-start guess: opt-in, DEFAULT OFF (enable with OQP_MRSF_ZV_DIAGGUESS=1). call get_environment_variable ( 'OQP_MRSF_ZV_DIAGGUESS' , e_ ) zv_diag_guess = len_trim ( e_ ) > 0 . and . ( e_ ( 1 : 1 ) == '1' . or . e_ ( 1 : 1 ) == 'y' . or . & e_ ( 1 : 1 ) == 'Y' . or . e_ ( 1 : 1 ) == 't' . or . e_ ( 1 : 1 ) == 'T' ) ! Coarser response grid (default OFF; new feature, validate before defaulting). call get_environment_variable ( 'OQP_MRSF_ZV_COARSEGRID' , e_ ) zv_coarse_on = len_trim ( e_ ) > 0 . and . ( e_ ( 1 : 1 ) == '1' . or . e_ ( 1 : 1 ) == 'y' . or . & e_ ( 1 : 1 ) == 'Y' . or . e_ ( 1 : 1 ) == 't' . or . e_ ( 1 : 1 ) == 'T' ) call get_environment_variable ( 'OQP_MRSF_ZV_GRID' , e_ ) if ( len_trim ( e_ ) > 0 ) zv_grid_name = trim ( adjustl ( e_ )) zv_cfg_init = . true . end subroutine zv_read_config ! Progressive screening threshold for a CG step given the current squared ! residual `error` and the tight floor. Returns the tight floor once pinned. function zv_prog_tau ( error , tight ) result ( tau ) real ( kind = dp ), intent ( in ) :: error , tight real ( kind = dp ) :: tau , resid if (. not . ieee_is_finite ( error ) . or . error < zv_prog_pin ) then tau = tight return end if resid = sqrt ( max ( error , 0.0_dp )) tau = zv_prog_k * resid if ( tau < tight ) tau = tight if ( tau > zv_prog_cap ) tau = zv_prog_cap end function zv_prog_tau ! Store a converged xk (and the current MOs, for later MO-basis projection) ! into the warm-start store for `state`. Reallocates if the problem dimension ! changed (e.g. a different basis/molecule). subroutine zv_store_guess ( xk , lzdim , state , nstate , mo_a , mo_b , nbf ) real ( kind = dp ), intent ( in ) :: xk (:) integer , intent ( in ) :: lzdim , state , nstate , nbf real ( kind = dp ), intent ( in ) :: mo_a (:,:), mo_b (:,:) integer :: ncol if (. not . zv_warm_on ) return if ( any (. not . ieee_is_finite ( xk ))) return ncol = max ( nstate , state ) if ( zv_warm_lzdim /= lzdim . or . . not . allocated ( zv_warm ) . or . & . not . allocated ( zv_warm_has )) then if ( allocated ( zv_warm )) deallocate ( zv_warm ) if ( allocated ( zv_warm_has )) deallocate ( zv_warm_has ) allocate ( zv_warm ( lzdim , ncol ), source = 0.0_dp ) allocate ( zv_warm_has ( ncol ), source = . false .) zv_warm_lzdim = lzdim else if ( size ( zv_warm_has ) < state ) then return end if zv_warm (:, state ) = xk zv_warm_has ( state ) = . true . ! Cache the current MOs (shared across states this step) for MO projection. if ( zv_warm_nbf /= nbf . or . . not . allocated ( zv_warm_moa )) then if ( allocated ( zv_warm_moa )) deallocate ( zv_warm_moa ) if ( allocated ( zv_warm_mob )) deallocate ( zv_warm_mob ) allocate ( zv_warm_moa ( nbf , nbf ), zv_warm_mob ( nbf , nbf )) zv_warm_nbf = nbf end if zv_warm_moa (:,:) = mo_a ( 1 : nbf , 1 : nbf ) zv_warm_mob (:,:) = mo_b ( 1 : nbf , 1 : nbf ) zv_warm_have_mo = . true . end subroutine zv_store_guess ! Inverse of sfrogen: gather the z-vector amplitudes from MO-basis matrices ! ava (alpha) / avb (beta) at the same index positions sfrogen scatters to. ! The doc-virt block (which sfrogen writes to both spins) is averaged. subroutine zv_sfrogen_gather ( ava , avb , xk , nocca , noccb ) real ( kind = dp ), intent ( in ) :: ava (:,:), avb (:,:) real ( kind = dp ), intent ( out ) :: xk (:) integer , intent ( in ) :: nocca , noccb integer :: ij , i , j , k , nbf nbf = ubound ( ava , 1 ) ij = 0 do i = noccb + 1 , nocca ! doc-socc  (beta) do j = 1 , noccb ij = ij + 1 ; xk ( ij ) = avb ( j , i ) end do end do do k = nocca + 1 , nbf ! doc-virt  (sfrogen wrote both spins) do j = 1 , noccb ij = ij + 1 ; xk ( ij ) = 0.5_dp * ( ava ( j , k ) + avb ( j , k )) end do end do do k = nocca + 1 , nbf ! socc-virt (alpha) do i = noccb + 1 , nocca ij = ij + 1 ; xk ( ij ) = ava ( i , k ) end do end do end subroutine zv_sfrogen_gather ! Initialize GMRES work arrays subroutine init_gmres_work ( nbf , nocca , noccb ) use messages , only : show_message , with_abort implicit none integer , intent ( in ) :: nbf , nocca , noccb integer :: nvira , nvirb , ok if ( nbf <= 0 . or . nocca < 0 . or . noccb < 0 ) then call show_message ( 'Invalid GMRES work dimensions before allocation' , with_abort ) end if nvira = nbf - nocca nvirb = nbf - noccb if ( nvira <= 0 . or . nvirb <= 0 ) then call show_message ( 'Invalid GMRES occupied/virtual dimensions before allocation' , with_abort ) end if if ( gmres_work_allocated ) then ! Check if dimensions match and every reusable array is still allocated. if ( gmres_nbf == nbf . and . gmres_nocca == nocca . and . gmres_noccb == noccb ) then if ( gmres_work_arrays_allocated ()) then return ! Arrays already allocated with correct size end if call cleanup_gmres_work () else ! Deallocate old arrays before reallocating call cleanup_gmres_work () end if end if allocate ( gmres_wrk1 ( nbf , nbf ), & gmres_wrk2 ( nbf , nbf ), & gmres_wrk3 ( nbf , nbf ), & gmres_pa ( nbf , nbf , 2 ), & gmres_ab1_mo_a ( nocca , nvira ), & gmres_ab1_mo_b ( noccb , nvirb ), & stat = ok ) if ( ok /= 0 ) then call show_message ( 'Cannot allocate GMRES work arrays' , with_abort ) end if gmres_work_allocated = . true . gmres_nbf = nbf gmres_nocca = nocca gmres_noccb = noccb end subroutine init_gmres_work ! Return true only when every reusable GMRES work array is allocated. logical function gmres_work_arrays_allocated () implicit none gmres_work_arrays_allocated = allocated ( gmres_wrk1 ) . and . & allocated ( gmres_wrk2 ) . and . & allocated ( gmres_wrk3 ) . and . & allocated ( gmres_pa ) . and . & allocated ( gmres_ab1_mo_a ) . and . & allocated ( gmres_ab1_mo_b ) end function gmres_work_arrays_allocated ! Cleanup GMRES work arrays subroutine cleanup_gmres_work () implicit none if ( allocated ( gmres_wrk1 )) deallocate ( gmres_wrk1 ) if ( allocated ( gmres_wrk2 )) deallocate ( gmres_wrk2 ) if ( allocated ( gmres_wrk3 )) deallocate ( gmres_wrk3 ) if ( allocated ( gmres_pa )) deallocate ( gmres_pa ) if ( allocated ( gmres_ab1_mo_a )) deallocate ( gmres_ab1_mo_a ) if ( allocated ( gmres_ab1_mo_b )) deallocate ( gmres_ab1_mo_b ) gmres_work_allocated = . false . gmres_nbf = 0 gmres_nocca = 0 gmres_noccb = 0 end subroutine cleanup_gmres_work ! GMRES solver for the z-vector equation subroutine gmres_solve ( apply_operator , apply_precond , b , x , n , restart , max_iter , tol , & infos , basis , molGrid , int2_driver , & nocca , noccb , nbf , mo_a , mo_b , mo_energy_a , & fa , fb , scale_exch , dft , error_out , iter_out , iw ) use precision , only : dp use types , only : information use basis_tools , only : basis_set use int2_compute , only : int2_compute_t use mod_dft_molgrid , only : dft_grid_t implicit none interface subroutine apply_operator ( x_in , x_out , infos , basis , molGrid , int2_driver , & nocca , noccb , nbf , mo_a , mo_b , mo_energy_a , & fa , fb , scale_exch , dft ) use precision , only : dp use types , only : information use basis_tools , only : basis_set use int2_compute , only : int2_compute_t use mod_dft_molgrid , only : dft_grid_t real ( kind = dp ), intent ( in ) :: x_in (:) real ( kind = dp ), intent ( out ) :: x_out (:) type ( information ), intent ( inout ) :: infos type ( basis_set ), pointer :: basis type ( dft_grid_t ), intent ( inout ) :: molGrid type ( int2_compute_t ), intent ( inout ) :: int2_driver integer , intent ( in ) :: nocca , noccb , nbf real ( kind = dp ), intent ( in ) :: mo_a (:,:), mo_b (:,:), mo_energy_a (:) real ( kind = dp ), intent ( in ) :: fa (:,:), fb (:,:), scale_exch logical , intent ( in ) :: dft end subroutine subroutine apply_precond ( x_in , x_out ) use precision , only : dp real ( kind = dp ), intent ( in ) :: x_in (:) real ( kind = dp ), intent ( out ) :: x_out (:) end subroutine end interface real ( kind = dp ), intent ( in ) :: b (:) real ( kind = dp ), intent ( inout ) :: x (:) integer , intent ( in ) :: n , restart , max_iter , iw real ( kind = dp ), intent ( in ) :: tol type ( information ), intent ( inout ) :: infos type ( basis_set ), pointer :: basis type ( dft_grid_t ), intent ( inout ) :: molGrid type ( int2_compute_t ), intent ( inout ) :: int2_driver integer , intent ( in ) :: nocca , noccb , nbf real ( kind = dp ), intent ( in ) :: mo_a (:,:), mo_b (:,:), mo_energy_a (:) real ( kind = dp ), intent ( in ) :: fa (:,:), fb (:,:), scale_exch logical , intent ( in ) :: dft real ( kind = dp ), intent ( out ) :: error_out integer , intent ( out ) :: iter_out ! Local variables real ( kind = dp ), allocatable :: V (:,:) ! Krylov basis real ( kind = dp ), allocatable :: H (:,:) ! Hessenberg matrix real ( kind = dp ), allocatable :: c (:), s (:) ! Givens rotation coefficients real ( kind = dp ), allocatable :: g (:) ! RHS for least squares real ( kind = dp ), allocatable :: y (:) ! Solution of least squares real ( kind = dp ), allocatable :: r (:) ! Residual real ( kind = dp ), allocatable :: w (:) ! Work vector real ( kind = dp ), allocatable :: Ax (:) ! A*x real ( kind = dp ) :: beta , h_ij , temp , error , error_initial , true_residual real ( kind = dp ) :: max_abs_overlap real ( kind = dp ), parameter :: gmres_reorth_threshold = 1.0d-10 integer :: i , j , k , iter , m , restart_count , inner_iter logical :: converged , unstable , happy_breakdown ! Initialize GMRES work arrays ONCE at the beginning if ( n <= 0 . or . restart <= 0 ) then write ( iw , '(\" GMRES: invalid dimensions provided (n/restart)\")' ) error_out = huge ( 1.0_dp ) iter_out = 0 return end if if ( size ( b ) /= n . or . size ( x ) /= n ) then write ( iw , '(\" GMRES: vector size does not match problem size\")' ) error_out = huge ( 1.0_dp ) iter_out = 0 return end if if ( size ( mo_a , 1 ) /= nbf . or . size ( mo_b , 1 ) /= nbf ) then write ( iw , '(\" GMRES: invalid basis-size arguments\")' ) error_out = huge ( 1.0_dp ) iter_out = 0 return end if call init_gmres_work ( nbf , nocca , noccb ) ! Allocate workspace m = min ( restart , n ) allocate ( V ( n , m + 1 )) allocate ( H ( m + 1 , m )) allocate ( c ( m )) allocate ( s ( m )) allocate ( g ( m + 1 )) allocate ( y ( m )) allocate ( r ( n )) allocate ( w ( n )) allocate ( Ax ( n )) iter_out = 0 restart_count = 0 converged = . false . unstable = . false . happy_breakdown = . false . write ( iw , '(/,\" GMRES Solver Parameters:\")' ) write ( iw , '(\"   Problem size        : \", I8)' ) n write ( iw , '(\"   Restart dimension   : \", I4)' ) m write ( iw , '(\"   Max iterations      : \", I4)' ) max_iter write ( iw , '(\"   Convergence tol     : \", 1p,e10.3)' ) tol write ( iw , '(/,\" Iteration   Inner  Residual Norm   Reduction\")' ) write ( iw , '(\" ---------   -----  -------------   ---------\")' ) call flush ( iw ) ! Compute initial residual call apply_operator ( x , Ax , infos , basis , molGrid , int2_driver , & nocca , noccb , nbf , mo_a , mo_b , mo_energy_a , & fa , fb , scale_exch , dft ) if ( any (. not . ieee_is_finite ( Ax )) . or . any (. not . ieee_is_finite ( x )) . or . any (. not . ieee_is_finite ( b ))) then write ( iw , '(\" GMRES: initial residual has non-finite input\")' ) call flush ( iw ) error_out = huge ( 1.0_dp ) error_initial = huge ( 1.0_dp ) iter_out = 0 unstable = . true . else r = b - Ax error_initial = sqrt ( dot_product ( r , r )) if ( error_initial == 0.0_dp ) then write ( iw , '(\" GMRES: initial residual is exactly zero\")' ) call flush ( iw ) error_out = error_initial iter_out = 0 converged = . true . else if (. not . ieee_is_finite ( error_initial )) then write ( iw , '(\" GMRES: initial residual is non-finite; aborting iterative safety\")' ) call flush ( iw ) error_out = huge ( 1.0_dp ) iter_out = 0 unstable = . true . else if ( error_initial < GMRES_DENOMINATOR_FLOOR ) then write ( iw , '(\" GMRES: initial residual is already below denominator floor\")' ) call flush ( iw ) error_out = error_initial iter_out = 0 converged = . true . end if end if end if if ( unstable . or . converged ) then ! Safety fallback or exact-zero residual handled above; skip GMRES iterations else do iter = 1 , max_iter restart_count = restart_count + 1 ! Compute initial residual r = b - A*x call apply_operator ( x , Ax , infos , basis , molGrid , int2_driver , & nocca , noccb , nbf , mo_a , mo_b , mo_energy_a , & fa , fb , scale_exch , dft ) if ( any (. not . ieee_is_finite ( Ax )) . or . any (. not . ieee_is_finite ( x )) . or . any (. not . ieee_is_finite ( b ))) then write ( iw , '(\" GMRES: non-finite values during restart residual setup\")' ) unstable = . true . exit end if r = b - Ax if ( any (. not . ieee_is_finite ( r ))) then write ( iw , '(\" GMRES: non-finite residual during restart\")' ) unstable = . true . exit end if true_residual = sqrt ( dot_product ( r , r )) if (. not . ieee_is_finite ( true_residual )) then write ( iw , '(\" GMRES: non-finite true residual during restart\")' ) unstable = . true . exit end if if ( true_residual < tol ) then error_out = true_residual error = true_residual converged = . true . exit end if ! Apply preconditioner to residual call apply_precond ( r , V (:, 1 )) if ( any (. not . ieee_is_finite ( V (:, 1 ))) . or . any (. not . ieee_is_finite ( r ))) then write ( iw , '(\" GMRES: non-finite preconditioned residual\")' ) unstable = . true . exit end if beta = sqrt ( dot_product ( V (:, 1 ), V (:, 1 ))) if ( any (. not . ieee_is_finite ( V (:, 1 )))) then write ( iw , '(\" GMRES: non-finite basis vector prior to scaling\")' ) unstable = . true . exit end if if (. not . ieee_is_finite ( beta ) . or . beta < GMRES_DENOMINATOR_FLOOR ) then write ( iw , '(\" GMRES: degenerate residual norm at restart \", I3)' ) restart_count unstable = . true . exit end if ! Report the true residual; beta is only the preconditioned Arnoldi seed norm. error = true_residual if ( iter == 1 ) then write ( iw , '(I6,8x,\"  0\",2x,1p,F13.8,1x,F13.8)' ) & restart_count , error , error / error_initial end if V (:, 1 ) = V (:, 1 ) / beta g = 0.0_dp g ( 1 ) = beta ! Reset H matrix for this restart H = 0.0_dp ! Arnoldi process inner_iter = 0 happy_breakdown = . false . do j = 1 , m inner_iter = j ! Apply operator to V_j call apply_operator ( V (:, j ), w , infos , basis , molGrid , int2_driver , & nocca , noccb , nbf , mo_a , mo_b , mo_energy_a , & fa , fb , scale_exch , dft ) if ( any (. not . ieee_is_finite ( w )) . or . any (. not . ieee_is_finite ( V (:, j )))) then write ( iw , '(\" GMRES: non-finite basis/operator values at inner step\", I3)' ) j unstable = . true . exit end if ! Apply preconditioner call apply_precond ( w , V (:, j + 1 )) if ( any (. not . ieee_is_finite ( V (:, j + 1 ))) . or . any (. not . ieee_is_finite ( w ))) then write ( iw , '(\" GMRES: non-finite preconditioned vector at inner step\", I3)' ) j unstable = . true . exit end if ! Modified Gram-Schmidt orthogonalization do i = 1 , j H ( i , j ) = dot_product ( V (:, j + 1 ), V (:, i )) if (. not . ieee_is_finite ( H ( i , j ))) then unstable = . true . exit end if V (:, j + 1 ) = V (:, j + 1 ) - H ( i , j ) * V (:, i ) end do if ( unstable ) then write ( iw , '(\" GMRES: non-finite H entry during orthogonalization\")' ) exit end if ! Reorthogonalize only when residual overlap drift is measurable. max_abs_overlap = 0.0_dp do i = 1 , j temp = dot_product ( V (:, j + 1 ), V (:, i )) if (. not . ieee_is_finite ( temp )) then unstable = . true . exit end if max_abs_overlap = max ( max_abs_overlap , abs ( temp )) end do if ( unstable ) then write ( iw , '(\" GMRES: non-finite overlap during re-orthogonalization check\")' ) exit end if if ( max_abs_overlap > gmres_reorth_threshold ) then ! GMRES MGS reorthogonalization pass do i = 1 , j temp = dot_product ( V (:, j + 1 ), V (:, i )) H ( i , j ) = H ( i , j ) + temp if (. not . ieee_is_finite ( temp ) . or . . not . ieee_is_finite ( H ( i , j ))) then unstable = . true . exit end if V (:, j + 1 ) = V (:, j + 1 ) - temp * V (:, i ) end do if ( unstable ) then write ( iw , '(\" GMRES: non-finite H entry during re-orthogonalization\")' ) exit end if end if H ( j + 1 , j ) = sqrt ( dot_product ( V (:, j + 1 ), V (:, j + 1 ))) if ( any (. not . ieee_is_finite ( V (:, j + 1 )))) then unstable = . true . exit end if ! Check for breakdown if (. not . ieee_is_finite ( H ( j + 1 , j ))) then write ( iw , '(\" GMRES: non-finite Arnoldi norm at iteration \", I3)' ) j inner_iter = j unstable = . true . exit else if ( abs ( H ( j + 1 , j )) < GMRES_DENOMINATOR_FLOOR ) then write ( iw , '(\" GMRES: happy breakdown at iteration \", I3, \"; recomputing true residual\")' ) j inner_iter = j H ( j + 1 , j ) = 0.0_dp happy_breakdown = . true . else V (:, j + 1 ) = V (:, j + 1 ) / H ( j + 1 , j ) end if ! Apply previous Givens rotations do i = 1 , j - 1 temp = c ( i ) * H ( i , j ) + s ( i ) * H ( i + 1 , j ) H ( i + 1 , j ) = - s ( i ) * H ( i , j ) + c ( i ) * H ( i + 1 , j ) H ( i , j ) = temp end do if (. not . ieee_is_finite ( H ( j , j )) . or . . not . ieee_is_finite ( H ( j + 1 , j ))) then unstable = . true . exit end if ! Compute new Givens rotation call givens_rotation ( H ( j , j ), H ( j + 1 , j ), c ( j ), s ( j )) ! Apply new Givens rotation H ( j , j ) = c ( j ) * H ( j , j ) + s ( j ) * H ( j + 1 , j ) H ( j + 1 , j ) = 0.0_dp temp = c ( j ) * g ( j ) + s ( j ) * g ( j + 1 ) g ( j + 1 ) = - s ( j ) * g ( j ) + c ( j ) * g ( j + 1 ) g ( j ) = temp ! Check convergence error = abs ( g ( j + 1 )) iter_out = iter_out + 1 ! Print progress every 5 inner iterations or at convergence if ( mod ( j , 5 ) == 0 . or . error < tol . or . j == m ) then write ( iw , '(I6,8x,I3,2x,1p,F13.8,1x,F13.8)' ) & restart_count , j , error , error / error_initial call flush ( iw ) end if if ( error < tol ) then converged = . true . inner_iter = j exit end if if ( happy_breakdown ) then inner_iter = j exit end if if ( iter_out >= max_iter ) then inner_iter = j exit end if end do if ( inner_iter > 0 . and . . not . unstable ) then ! Solve upper triangular system for y call back_substitution ( H ( 1 : inner_iter , 1 : inner_iter ), g ( 1 : inner_iter ), & y ( 1 : inner_iter ), inner_iter , unstable ) end if if ( unstable ) then error_out = huge ( 1.0_dp ) exit end if ! Update solution: x = x + V*y do i = 1 , inner_iter x = x + y ( i ) * V (:, i ) end do if ( any (. not . ieee_is_finite ( x ))) then write ( iw , '(\" GMRES: non-finite solution update\")' ) unstable = . true . error_out = huge ( 1.0_dp ) exit end if call recompute_gmres_true_residual ( true_residual , unstable ) if ( unstable ) then error_out = huge ( 1.0_dp ) exit end if error_out = true_residual converged = true_residual < tol error = true_residual if ( converged . or . iter_out >= max_iter ) exit ! Print restart information if (. not . converged . and . inner_iter == m ) then write ( iw , '(\" GMRES: Restarting (restart #\", I3, \")\")' ) restart_count call flush ( iw ) end if end do end if ! Final status write ( iw , '(\" ---------   -----  -------------   ---------\")' ) if ( converged ) then write ( iw , '(\" GMRES converged in \", I4, \" iterations (\", I3, \" restarts)\")' ) & iter_out , restart_count - 1 write ( iw , '(\" Final residual norm: \", 1p,e13.6)' ) error_out else if ( unstable ) then write ( iw , '(\" GMRES terminated due to numerical instability\")' ) else write ( iw , '(\" GMRES did not converge within \", I4, \" iterations\")' ) max_iter end if write ( iw , '(\" Final residual norm: \", 1p,e13.6)' ) error_out end if if ( ieee_is_finite ( error_initial ) . and . abs ( error_initial ) >= GMRES_DENOMINATOR_FLOOR ) then write ( iw , '(\" Relative reduction : \", 1p,e13.6)' ) error_out / error_initial else write ( iw , '(\" Relative reduction : not available\")' ) end if call flush ( iw ) ! Clean up local arrays deallocate ( V , H , c , s , g , y , r , w , Ax ) ! NOTE: Do NOT clean up GMRES work arrays here - they will be cleaned in main routine contains subroutine recompute_gmres_true_residual ( true_residual , unstable ) real ( kind = dp ), intent ( out ) :: true_residual logical , intent ( out ) :: unstable call apply_operator ( x , Ax , infos , basis , molGrid , int2_driver , & nocca , noccb , nbf , mo_a , mo_b , mo_energy_a , & fa , fb , scale_exch , dft ) if ( any (. not . ieee_is_finite ( Ax )) . or . any (. not . ieee_is_finite ( x )) . or . & any (. not . ieee_is_finite ( b ))) then write ( iw , '(\" GMRES: non-finite values during true residual recomputation\")' ) true_residual = huge ( 1.0_dp ) unstable = . true . return end if r = b - Ax if ( any (. not . ieee_is_finite ( r ))) then write ( iw , '(\" GMRES: non-finite true residual vector\")' ) true_residual = huge ( 1.0_dp ) unstable = . true . return end if true_residual = sqrt ( dot_product ( r , r )) if (. not . ieee_is_finite ( true_residual )) then write ( iw , '(\" GMRES: non-finite true residual norm\")' ) true_residual = huge ( 1.0_dp ) unstable = . true . return end if unstable = . false . end subroutine recompute_gmres_true_residual subroutine givens_rotation ( a , b , c , s ) real ( kind = dp ), intent ( in ) :: a , b real ( kind = dp ), intent ( out ) :: c , s real ( kind = dp ) :: r , scale if (. not . ieee_is_finite ( a ) . or . . not . ieee_is_finite ( b ) . or . & ( abs ( a ) < GMRES_DENOMINATOR_FLOOR . and . abs ( b ) < GMRES_DENOMINATOR_FLOOR )) then c = 1.0_dp s = 0.0_dp else scale = max ( abs ( a ), abs ( b )) r = scale * sqrt (( a / scale ) ** 2 + ( b / scale ) ** 2 ) c = a / r s = b / r end if end subroutine givens_rotation subroutine back_substitution ( A , b , x , n , unstable ) integer , intent ( in ) :: n real ( kind = dp ), intent ( in ) :: A ( n , n ), b ( n ) real ( kind = dp ), intent ( out ) :: x ( n ) logical , intent ( out ) :: unstable integer :: i , j real ( kind = dp ) :: rhs if ( n <= 0 ) then unstable = . true . return end if if (. not . ieee_is_finite ( A ( n , n )) . or . abs ( A ( n , n )) < GMRES_DENOMINATOR_FLOOR ) then unstable = . true . return end if if (. not . ieee_is_finite ( b ( n ))) then unstable = . true . return end if x ( n ) = b ( n ) / A ( n , n ) if (. not . ieee_is_finite ( x ( n ))) then unstable = . true . return end if do i = n - 1 , 1 , - 1 if (. not . ieee_is_finite ( A ( i , i )) . or . abs ( A ( i , i )) < GMRES_DENOMINATOR_FLOOR ) then unstable = . true . return end if if (. not . ieee_is_finite ( b ( i ))) then unstable = . true . return end if rhs = b ( i ) do j = i + 1 , n if (. not . ieee_is_finite ( A ( i , j ))) then unstable = . true . return end if rhs = rhs - A ( i , j ) * x ( j ) end do if (. not . ieee_is_finite ( rhs )) then unstable = . true . return end if x ( i ) = rhs / A ( i , i ) if (. not . ieee_is_finite ( x ( i ))) then unstable = . true . return end if end do unstable = . false . end subroutine back_substitution end subroutine gmres_solve ! Apply the z-vector operator (A*x) - Modified to use module-level arrays subroutine apply_z_operator ( x_in , x_out , infos , basis , molGrid , int2_driver , & nocca , noccb , nbf , mo_a , mo_b , mo_energy_a , & fa , fb , scale_exch , dft ) use precision , only : dp use types , only : information use basis_tools , only : basis_set use int2_compute , only : int2_compute_t use tdhf_lib , only : int2_tdgrd_data_t use tdhf_sf_lib , only : sfrogen , sfrolhs use mod_dft_gridint_fxc , only : utddft_fxc use mathlib , only : symmetrize_matrix , orthogonal_transform use mod_dft_molgrid , only : dft_grid_t use tdhf_lib , only : mntoia implicit none real ( kind = dp ), intent ( in ) :: x_in (:) real ( kind = dp ), intent ( out ) :: x_out (:) type ( information ), intent ( inout ) :: infos type ( basis_set ), pointer :: basis type ( dft_grid_t ), intent ( inout ) :: molGrid type ( int2_compute_t ), intent ( inout ) :: int2_driver integer , intent ( in ) :: nocca , noccb , nbf real ( kind = dp ), intent ( in ) :: mo_a (:,:), mo_b (:,:), mo_energy_a (:) real ( kind = dp ), intent ( in ) :: fa (:,:), fb (:,:), scale_exch logical , intent ( in ) :: dft ! Local variables real ( kind = dp ), pointer :: ab1 (:,:,:) type ( int2_tdgrd_data_t ), allocatable , target :: int2_data integer :: nvira , nvirb real ( kind = dp ) :: t0_op nvira = nbf - nocca nvirb = nbf - noccb if ( any (. not . ieee_is_finite ( x_in ))) then x_out = ieee_value ( 0.0_dp , ieee_quiet_nan ) write ( * , '(\" MRSF z-vector operator rejected non-finite input\")' ) return end if ! Ensure work arrays are initialized and have correct dimensions if (. not . gmres_work_allocated . or . & gmres_nbf /= nbf . or . & gmres_nocca /= nocca . or . & gmres_noccb /= noccb ) then call init_gmres_work ( nbf , nocca , noccb ) end if ! Clear work arrays gmres_wrk1 = 0.0_dp gmres_wrk2 = 0.0_dp gmres_wrk3 = 0.0_dp gmres_pa = 0.0_dp gmres_ab1_mo_a = 0.0_dp gmres_ab1_mo_b = 0.0_dp ! Generate density matrices from x_in if ( zv_tmr_on ) then t0_op = zv_wtime () zv_n_iter = zv_n_iter + 1 end if call sfrogen ( gmres_wrk1 , gmres_wrk2 , x_in , nocca , noccb ) ! Transform to AO basis call orthogonal_transform ( 't' , nbf , mo_a , gmres_wrk1 , gmres_pa (:,:, 1 ), gmres_wrk3 ) call orthogonal_transform ( 't' , nbf , mo_b , gmres_wrk2 , gmres_pa (:,:, 2 ), gmres_wrk3 ) if ( zv_tmr_on ) zv_t_trans = zv_t_trans + ( zv_wtime () - t0_op ) ! Initialize ERI calculation with proper allocation allocate ( int2_data ) int2_data = int2_tdgrd_data_t ( & d2 = gmres_pa , & int_apb = . true ., & int_amb = . false ., & tamm_dancoff = . false ., & scale_exchange = scale_exch ) if ( zv_tmr_on ) t0_op = zv_wtime () call int2_driver % run ( int2_data , & cam = dft . and . infos % dft % cam_flag , & alpha = infos % dft % cam_alpha , & beta = infos % dft % cam_beta ,& mu = infos % dft % cam_mu ) if ( zv_tmr_on ) zv_t_int2 = zv_t_int2 + ( zv_wtime () - t0_op ) ab1 => int2_data % apb (:,:,:, 1 ) call symmetrize_matrix ( gmres_pa (:,:, 1 ), nbf ) call symmetrize_matrix ( gmres_pa (:,:, 2 ), nbf ) if ( dft ) then if ( zv_tmr_on ) t0_op = zv_wtime () call utddft_fxc ( & basis = basis , & molGrid = molGrid , & isVecs = . true ., & wfa = mo_a , & wfb = mo_b , & fxa = ab1 (:,:, 1 : 1 ), & fxb = ab1 (:,:, 2 : 2 ), & dxa = gmres_pa (:,:, 1 : 1 ), & dxb = gmres_pa (:,:, 2 : 2 ), & nmtx = 1 , & threshold = 1.0d-15 , & infos = infos ) if ( zv_tmr_on ) zv_t_xc = zv_t_xc + ( zv_wtime () - t0_op ) end if if ( any (. not . ieee_is_finite ( ab1 ))) then x_out = ieee_value ( 0.0_dp , ieee_quiet_nan ) write ( * , '(\" MRSF z-vector operator rejected non-finite response\")' ) call int2_data % clean () deallocate ( int2_data ) return end if ! Transform to MO basis - Fixed to use correct mo_b for beta if ( zv_tmr_on ) t0_op = zv_wtime () call mntoia ( ab1 (:,:, 1 ), gmres_ab1_mo_a , mo_a , mo_a , nocca , nocca ) call mntoia ( ab1 (:,:, 2 ), gmres_ab1_mo_b , mo_b , mo_b , noccb , noccb ) ! Apply the operator call sfrolhs ( x_out , x_in , mo_energy_a , fa , fb , gmres_ab1_mo_a , gmres_ab1_mo_b , & nocca , noccb ) if ( zv_tmr_on ) zv_t_trans = zv_t_trans + ( zv_wtime () - t0_op ) call int2_data % clean () deallocate ( int2_data ) end subroutine apply_z_operator ! Apply preconditioner (simple diagonal preconditioner) subroutine apply_z_precond ( x_in , x_out , xminv ) use precision , only : dp implicit none real ( kind = dp ), intent ( in ) :: x_in (:), xminv (:) real ( kind = dp ), intent ( out ) :: x_out (:) if ( any (. not . ieee_is_finite ( x_in )) . or . any (. not . ieee_is_finite ( xminv ))) then x_out = ieee_value ( 0.0_dp , ieee_quiet_nan ) return end if x_out = xminv * x_in end subroutine apply_z_precond subroutine tdhf_mrsf_z_vector_C ( c_handle ) bind ( C , name = \"tdhf_mrsf_z_vector\" ) use c_interop , only : oqp_handle_t , oqp_handle_get_info use types , only : information type ( oqp_handle_t ) :: c_handle type ( information ), pointer :: inf inf => oqp_handle_get_info ( c_handle ) call tdhf_mrsf_z_vector ( inf ) end subroutine tdhf_mrsf_z_vector_C subroutine tdhf_mrsf_z_vector ( infos ) use precision , only : dp use io_constants , only : iw use oqp_tagarray_driver use types , only : information use strings , only : Cstring , fstring use basis_tools , only : basis_set use messages , only : show_message , with_abort use util , only : measure_time use int2_compute , only : int2_compute_t use tdhf_lib , only : int2_td_data_t use tdhf_lib , only : int2_tdgrd_data_t use tdhf_mrsf_lib , only : int2_mrsf_data_t use tdhf_lib , only : iatogen , mntoia use tdhf_sf_lib , only : sfrorhs , mrsf_state_label , & sfromcal , sfrogen , sfrolhs , pcgrbpini , & pcgb , sfropcal , sfdmat use dft , only : dft_initialize , dftclean use mod_dft_gridint_fxc , only : utddft_fxc use mathlib , only : symmetrize_matrix , orthogonal_transform , & orthogonal_transform_sym use mod_dft_molgrid , only : dft_grid_t use mathlib , only : pack_matrix , unpack_matrix use tdhf_mrsf_lib , only : & mrinivec , mrsfcbc , mrsfxvec , mrsfsp , mrsfrowcal , & mrsfqrorhs , mrsfqropcal , mrsfqrowcal use oqp_linalg use printing , only : print_module_info use minres_mod , only : minres_t , MINRES_OK , MINRES_CONVERGED use population_analysis , only : mulliken_excited use qmmm_mod , only : form_esp_charges_excited implicit none character ( len =* ), parameter :: subroutine_name = \"tdhf_mrsf_z_vector\" type ( basis_set ), pointer :: basis type ( information ), target , intent ( inout ) :: infos integer :: ok real ( kind = dp ), allocatable :: ab1_mo_a (:,:) real ( kind = dp ), allocatable :: ab1_mo_b (:,:) real ( kind = dp ), allocatable :: xm (:) real ( kind = dp ), pointer :: ab1 (:,:,:) real ( kind = dp ), allocatable :: fa (:,:), fb (:,:) real ( kind = dp ), pointer :: bvec (:,:,:) real ( kind = dp ), pointer :: wmo (:,:) real ( kind = dp ), allocatable :: bvec_mo_d (:,:) real ( kind = dp ), allocatable , target :: & fmrst1 (:,:,:,:) real ( kind = dp ), pointer :: fmrst2 (:,:,:,:) integer :: nocca , nvira , noccb , nvirb integer :: nbf , nbf_tri integer :: iter , gmres_iter type ( minres_t ) :: mr integer :: minres_iter integer , target :: minres_dummy real ( kind = dp ) :: cnvtol , scale_exch , scale_exch2 logical :: roref = . false . integer :: mrst type ( int2_compute_t ) :: int2_driver type ( int2_mrsf_data_t ), allocatable , target :: int2_data_st type ( int2_td_data_t ), allocatable , target :: int2_data_q class ( int2_td_data_t ), allocatable , target :: int2_data type ( dft_grid_t ) :: molGrid ! scr data real ( kind = dp ), allocatable , target :: wrk1 (:,:), wrk2 (:,:), wrk3 (:,:) real ( kind = dp ), pointer :: wrk1t (:) ! SF-TD Gradient data real ( kind = dp ), allocatable :: & rhs (:), lhs (:), xminv (:), xk (:), pk (:), errv (:), & hxa (:,:), hxb (:,:), tij (:,:), ppija (:,:), ppijb (:,:), tab (:,:) real ( kind = dp ), allocatable , target :: pa (:,:,:) integer :: nsocc , lzdim , xvec_dim ! General data real ( kind = dp ) :: alpha , error , pap real ( kind = dp ) :: t0_zv real ( kind = dp ) :: zv_rc_save logical :: zv_rc_loosen character :: zv_gname_save ( 16 ) integer :: ig character ( len = 10 ) :: solver_name character ( len = 12 ) :: target_label character ( len = 16 ) :: method_name logical :: dft , mrsf_zvector_breakdown integer :: scf_type , mol_mult , target_state ! tagarray real ( kind = dp ), contiguous , pointer :: & fock_a (:), mo_a (:,:), mo_energy_a (:), & fock_b (:), mo_b (:,:), & td_p (:,:), td_t (:,:), ta (:), tb (:), td_abxc (:,:), & td_mrsf_den (:,:,:), bvec_mo (:,:), wao (:), mrsf_energies (:) character ( len =* ), parameter :: tags_alloc ( 4 ) = ( / character ( len = 80 ) :: & OQP_WAO , OQP_td_mrsf_density , OQP_td_p , OQP_td_abxc / ) character ( len =* ), parameter :: tags_required ( 8 ) = ( / character ( len = 80 ) :: & OQP_FOCK_A , OQP_E_MO_A , OQP_VEC_MO_A , OQP_FOCK_B , OQP_VEC_MO_B , OQP_td_bvec_mo , OQP_td_t , & OQP_td_energies / ) dft = infos % control % hamilton == 20 if ( dft ) then method_name = 'MRSF-TDDFT' else method_name = 'MRSF-TDHF' end if mol_mult = infos % mol_prop % mult if ( mol_mult /= 3 ) call show_message (& 'MRSF requires a triplet ROHF/UHF internal reference (mult=3).' , with_abort ) scf_type = infos % control % scftype if ( scf_type == 3 ) roref = . true . mrsf_zvector_breakdown = . false . ! Optional per-iteration profiler (env OQP_MRSF_ZV_TIMERS; default off) call zv_timers_begin () ! Warm-start from [tdhf] zv_warmstart; remaining levers env-gated (advanced) call zv_read_config ( infos ) ! Files open ! 3. LOG: Write: Main output file open ( unit = iw , file = infos % log_filename , position = \"append\" ) ! call print_module_info ( 'MRSF_TDHF_Z_Vector' , 'Solving Z-Vector for ' // trim ( method_name )) ! Readings ! Load basis set basis => infos % basis basis % atoms => infos % atoms nbf = basis % nbf nbf_tri = nbf * ( nbf + 1 ) / 2 ! Build the z-vector's DFT grid -- optionally coarser than the SCF grid ! (env OQP_MRSF_ZV_COARSEGRID). The grid params are restored immediately; the ! built molGrid carries the coarse grid through all of the z-vector's XC calls. if ( dft ) then zv_gname_save = infos % dft % grid_pruned_name if ( zv_coarse_on ) then infos % dft % grid_pruned = . true . infos % dft % grid_pruned_name = ' ' do ig = 1 , min ( len_trim ( zv_grid_name ), 16 ) infos % dft % grid_pruned_name ( ig ) = zv_grid_name ( ig : ig ) end do write ( iw , '(\" MRSF z-vector coarse response grid: \",a)' ) trim ( zv_grid_name ) end if call dft_initialize ( infos , basis , molGrid ) if ( zv_coarse_on ) infos % dft % grid_pruned_name = zv_gname_save end if ! Parameter it should be inputed later mrst = infos % tddft % mult cnvtol = infos % tddft % zvconv ! Opt-in: override the z-vector convergence tolerance (env OQP_MRSF_ZV_CONV). ! Default 1e-10 is on the SQUARED residual and is typically over-converged for ! gradients; right-sizing it cuts iterations. Default unset = input zvconv. if ( zv_conv_user > 0.0_dp ) cnvtol = zv_conv_user nocca = infos % mol_prop % nelec_A nvira = nbf - noccA noccb = infos % mol_prop % nelec_B nvirb = nbf - noccb nsocc = nocca - noccb lzdim = noccb * ( nsocc + nvira ) + nsocc * nvira if ( mrst == 1 . or . mrst == 3 ) then xvec_dim = nocca * nvirb allocate (& ! for Z-vector fmrst1 ( 1 , 7 , nbf , nbf ), & bvec_mo_d ( xvec_dim , 1 ), & hxa ( nbf , nocca ), & hxb ( nbf , nbf ), & ! for gradient tij ( nocca , nocca ), & tab ( nvirb , nvirb ), & stat = ok , & source = 0.0_dp ) else if ( mrst == 5 ) then xvec_dim = noccb * nvira allocate (& ! for Z-vector hxa ( nbf , nbf ), & hxb ( nbf , noccb ), & ! for gradient tij ( noccb , noccb ), & tab ( nvira , nvira ), & stat = ok , & source = 0.0_dp ) endif if ( ok /= 0 ) call show_message ( 'Cannot allocate memory' , with_abort ) allocate (& ! for Z-vector xminv ( lzdim ), & rhs ( lzdim ), & lhs ( lzdim ), & xm ( lzdim ), & xk ( lzdim ), & pk ( lzdim ), & errv ( lzdim ), & ! For gradient pa ( nbf , nbf , 2 ), & ppija ( nocca , nocca ), & ppijb ( noccb , noccb ), & ! Allocate TDDFT variables fa ( nbf , nbf ), & ! Temporary matrix for diagonalization fb ( nbf , nbf ), & ! Temporary matrix for diagonalization ab1_mo_a ( nocca , nvira ), & ab1_mo_b ( noccb , nvirb ), & !   For scratch wrk1 ( nbf , nbf ), & wrk2 ( nbf , nbf ), & wrk3 ( nbf , nbf ), & stat = ok , & source = 0.0_dp ) if ( ok /= 0 ) call show_message ( 'Cannot allocate memory' , with_abort ) call infos % dat % alloc_or_die ( OQP_WAO , ( / nbf_tri / ), wao , description = OQP_WAO_comment ) call infos % dat % alloc_or_die ( OQP_td_mrsf_density , ( / 7 , nbf , nbf / ), td_mrsf_den , description = OQP_td_mrsf_density ) call infos % dat % alloc_or_die ( OQP_td_p , ( / nbf_tri , 2 / ), td_p , description = OQP_td_p ) call infos % dat % alloc_or_die ( OQP_td_abxc , ( / nbf , nbf / ), td_abxc , description = OQP_td_abxc ) call data_has_tags ( infos % dat , tags_required , module_name , subroutine_name , WITH_ABORT ) call tagarray_get_data ( infos % dat , OQP_FOCK_A , fock_a ) call tagarray_get_data ( infos % dat , OQP_FOCK_B , fock_b ) call tagarray_get_data ( infos % dat , OQP_E_MO_A , mo_energy_a ) call tagarray_get_data ( infos % dat , OQP_VEC_MO_A , mo_a ) call tagarray_get_data ( infos % dat , OQP_VEC_MO_B , mo_b ) call tagarray_get_data ( infos % dat , OQP_td_bvec_mo , bvec_mo ) call tagarray_get_data ( infos % dat , OQP_td_t , td_t ) call tagarray_get_data ( infos % dat , OQP_td_energies , mrsf_energies ) ta => td_t (:, 1 ) tb => td_t (:, 2 ) target_state = min ( infos % tddft % target_state , infos % tddft % nstate ) target_label = mrsf_state_label ( infos % tddft % mult , target_state ) if ( target_state /= infos % tddft % target_state ) then write ( * , '(/1x,66(\"-\")& &/1x,\"WARNING: Target state has been changed to the max available nstates\"/& &/1x,66(\"-\")/)' ) end if ! Determine solver name for output (0=CG, 1=GMRES legacy, 2=MINRES, 3=AUTO) select case ( infos % tddft % z_solver ) case ( 3 ) solver_name = \"AUTO\" case ( 2 ) solver_name = \"MINRES\" case ( 1 ) solver_name = \"GMRES\" case default solver_name = \"CG\" end select ! Save unrelaxed density matrices and the `b=A*x` vector for target state if ( mrst == 1 . or . mrst == 3 ) then call mrsfxvec ( infos , bvec_mo (:, target_state ), bvec_mo_d (:, 1 )) call sfdmat ( bvec_mo_d (:, 1 ), td_abxc , mo_a , ta , tb , nocca , noccb ) else if ( mrst == 5 ) then call sfdmat ( bvec_mo (:, target_state ), td_abxc , mo_a , tb , ta , noccb , nocca ) end if bvec ( 1 : nbf , 1 : nbf , 1 : 1 ) => td_abxc ! Initialize ERI calculations ! Opt-in: loosen the 2e integral cutoff for the WHOLE z-vector build (RHS, ! per-iteration sigma, and relaxed-density tail) via env OQP_MRSF_ZV_CUTOFF. ! Gradients are more cutoff-sensitive than energies, so the safe value is ! tighter than the response's; find it empirically. Restored before return so ! the next step's SCF/response is unaffected. Default unset = exact (unchanged). zv_rc_save = infos % control % int2e_cutoff ! Progressive screening (below) keeps init at the TIGHT cutoff so the pair ! list is a full superset; it ramps the run-time threshold per iteration. ! The static loosen and progressive are therefore mutually exclusive. zv_rc_loosen = zv_cutoff_user > 0.0_dp . and . . not . zv_prog_on if ( zv_rc_loosen ) infos % control % int2e_cutoff = max ( zv_rc_save , zv_cutoff_user ) call int2_driver % init ( basis , infos ) call int2_driver % set_screening () if ( zv_prog_on ) write ( iw , '(\" MRSF z-vector progressive screening ON: \", & &\"tau=clamp(\",1p,e8.1,\"*||r||, \",e8.1,\" , \",e8.1,\"), pin@||r||&#94;2<\",e8.1)' ) & zv_prog_k , zv_rc_save , zv_prog_cap , zv_prog_pin write ( * , '(/1x,71(\"-\")& &/18x,A,\" ENERGY GRADIENT CALCULATION\"& &/1x,71(\"-\")/)' ) trim ( method_name ) write ( iw , fmt = '(5x,a/& &5x,16(\"-\")/& &5x,a,x,a,x,f17.10,x,\"Hartree\"/& &5x,a,x,i0/& &5x,a,x,i0/& &5x,a,x,e10.4/& &5x,a,x,i0/& &5x,a,x,a)' ) & 'Z-vector options' & , 'Physical target state is' , trim ( target_label ), infos % mol_energy % energy + mrsf_energies ( target_state ) & , 'Internal response root is' , target_state & , 'Target spin multiplicity is' , infos % tddft % mult & , 'Convergence        is' , infos % tddft % zvconv & , 'Maximum iterations is' , infos % control % maxit_zv & , 'Solver method      is' , trim ( solver_name ) call flush ( iw ) ! ====================================================================== ! Step 1: assemble the z-vector right-hand side and Fock/density pieces. ! ====================================================================== if ( zv_tmr_on ) t0_zv = zv_wtime () call build_mrsf_zvector_rhs () if ( zv_tmr_on ) zv_t_rhs = zv_t_rhs + ( zv_wtime () - t0_zv ) write ( * , '(/3x,25(\"-\")& &/6x,\"START Z-VECTOR LOOP (\",A,\")\"& &/3x,25(\"-\")/)' ) trim ( solver_name ) call flush ( iw ) call sfromcal ( xm , xminv , mo_energy_a , fa , fb , nocca , noccb ) call sanitize_zvector_preconditioner ( xm , xminv , iw , MRSF_ZVEC_DENOMINATOR_FLOOR , \"MRSF\" ) ! ====================================================================== ! Step 2: solve the z-vector linear system. !   0 = CG (default)   1 = GMRES (legacy)   2 = MINRES   3 = AUTO (CG->MINRES->GMRES) ! ====================================================================== select case ( infos % tddft % z_solver ) case ( 2 ) call run_mrsf_minres_zvector () case ( 1 ) call run_mrsf_gmres_zvector () case ( 3 ) call run_mrsf_zvector_auto () case default call run_mrsf_cg_zvector () end select ! Progressive screening ramps the cutoff during the CG loop; restore the ! tight floor so the relaxed-density/W back-projection (which sets the ! gradient) is computed exactly. if ( zv_prog_on ) call int2_driver % set_cutoff ( zv_rc_save ) ! ----------------------------------------------- if ( mrsf_zvector_breakdown ) then infos % mol_energy % Z_Vector_converged = . false . write ( * , '(/3x,24(\"-\")& &/6x,\"Z-Vector breakdown\"& &/3x,24(\"-\")/)' ) call flush ( iw ) call int2_data % clean () call int2_driver % clean () if ( zv_rc_loosen ) infos % control % int2e_cutoff = zv_rc_save if ( dft ) call dftclean ( infos ) call measure_time ( print_total = 1 , log_unit = iw ) call cleanup_gmres_work () close ( iw ) return end if if ( error > cnvtol ) then infos % mol_energy % Z_Vector_converged = . false . write ( * , '(/3x,24(\"-\")& &/6x,\"Z-Vector not converged\"& &/3x,24(\"-\")/)' ) write ( iw , '(\" MRSF z-vector solver reached the maximum iterations; solver = \",A)' ) trim ( solver_name ) write ( iw , '(\" final residual = \",1p,e13.6)' ) error else infos % mol_energy % Z_Vector_converged = . true . write ( * , '(/3x,24(\"-\")& &/6x,\"Z-Vector converged\"& &/3x,24(\"-\")/)' ) ! Cache the converged solution for warm-starting the next step (no-op ! unless OQP_MRSF_ZV_WARMSTART is set). call zv_store_guess ( xk , lzdim , target_state , int ( infos % tddft % nstate ), & mo_a , mo_b , nbf ) endif call flush ( iw ) ! ====================================================================== ! Step 3: build the relaxed density (td_p) and energy-weighted density (wao). ! ====================================================================== if ( zv_tmr_on ) t0_zv = zv_wtime () call build_mrsf_relaxed_density_and_w () if ( zv_tmr_on ) zv_t_back = zv_t_back + ( zv_wtime () - t0_zv ) call zv_timers_report ( iw , solver_name ) ! QM/MM (ESPF): excited-state Mulliken population and ESP charges for the ! relaxed density, needed for the MM electrostatic embedding gradient. if ( infos % control % qmmm_flag ) then call mulliken_excited ( infos ) call form_esp_charges_excited ( infos ) end if call int2_driver % clean () if ( zv_rc_loosen ) infos % control % int2e_cutoff = zv_rc_save if ( dft ) call dftclean ( infos ) call measure_time ( print_total = 1 , log_unit = iw ) ! Clean up GMRES work arrays call cleanup_gmres_work () close ( iw ) contains ! GMRES z-vector solve.  Reports breakdown via mrsf_zvector_breakdown so the ! auto driver can detect failure uniformly across solvers. subroutine run_mrsf_gmres_zvector () call zv_warm_seed () call gmres_solve ( & apply_operator = apply_z_operator , & apply_precond = lambda_precond , & b = rhs , & x = xk , & n = lzdim , & restart = min ( int ( infos % tddft % gmres_dim ), lzdim ), & max_iter = int ( infos % control % maxit_zv ), & tol = cnvtol , & infos = infos , basis = basis , molGrid = molGrid , & int2_driver = int2_driver , & nocca = nocca , noccb = noccb , nbf = nbf , & mo_a = mo_a , mo_b = mo_b , mo_energy_a = mo_energy_a , & fa = fa , fb = fb , scale_exch = scale_exch , dft = dft , & error_out = error , iter_out = gmres_iter , iw = iw ) if (. not . ieee_is_finite ( error ) . or . error > cnvtol ) then if (. not . ieee_is_finite ( error )) mrsf_zvector_breakdown = . true . end if write ( iw , '(/,\" Final Summary:\")' ) write ( iw , '(\" GMRES total iterations: \", I4)' ) gmres_iter write ( iw , '(\" Final error norm      : \", 1p,e13.6)' ) error write ( iw , '(\" Convergence criterion : \", 1p,e13.6)' ) cnvtol call flush ( iw ) call cleanup_gmres_work () end subroutine run_mrsf_gmres_zvector ! MINRES z-vector solve: symmetric short-recurrence solver (Paige-Saunders) ! that stays stable when (A+B) turns indefinite, at CG-like cost.  Uses the ! same apply_z_operator / apply_z_precond as CG and GMRES. subroutine run_mrsf_minres_zvector () ! NOTE: this MINRES wrapper solves A x = rhs starting from the zero vector ! (mr%init seeds from rhs), so warm-start has no effect here; seeding is a ! no-op kept for uniformity. Warm-start benefits CG (default) and GMRES. call zv_warm_seed () call mr % init ( b = rhs , update = minres_apply_op , precond = minres_apply_pc , & dat = minres_dummy , tol = cnvtol ) minres_iter = 0 if ( mr % errcode == MINRES_OK ) then do iter = 1 , infos % control % maxit_zv call mr % step () minres_iter = iter if ( mr % errcode /= MINRES_OK ) exit end do end if if ( mr % errcode == MINRES_CONVERGED . or . mr % errcode == MINRES_OK ) then xk = mr % x error = mr % error else write ( iw , '(\" MRSF MINRES Z-Vector breakdown (errcode=\",I0,\")\")' ) int ( mr % errcode ) mrsf_zvector_breakdown = . true . error = huge ( 1.0_dp ) end if call mr % clean () write ( iw , '(/,\" Final Summary:\")' ) write ( iw , '(\" MINRES total iterations: \", I4)' ) minres_iter write ( iw , '(\" Final error norm       : \", 1p,e13.6)' ) error write ( iw , '(\" Convergence criterion  : \", 1p,e13.6)' ) cnvtol call flush ( iw ) end subroutine run_mrsf_minres_zvector ! AUTO driver: try CG (cheap, needs SPD), fall back to MINRES (CG-cost, ! robust on indefinite operators), then GMRES (general, priciest).  rhs and ! the preconditioner xminv are solver-independent and reused; only xk and ! the breakdown flag reset between attempts.  solver_name is updated to the ! solver that actually converged so the summary reflects reality. subroutine run_mrsf_zvector_auto () call run_mrsf_cg_zvector () if (. not . mrsf_zvector_breakdown . and . ieee_is_finite ( error ) & . and . error <= cnvtol ) then solver_name = \"AUTO(CG)\" return end if write ( iw , '(/,\" [AUTO] CG did not converge (breakdown/maxit); \", & &\"falling back to MINRES\")' ) call flush ( iw ) mrsf_zvector_breakdown = . false . call run_mrsf_minres_zvector () if (. not . mrsf_zvector_breakdown . and . ieee_is_finite ( error ) & . and . error <= cnvtol ) then solver_name = \"AUTO(MINRES)\" return end if write ( iw , '(/,\" [AUTO] MINRES did not converge; falling back to GMRES\")' ) call flush ( iw ) mrsf_zvector_breakdown = . false . call run_mrsf_gmres_zvector () if (. not . mrsf_zvector_breakdown . and . ieee_is_finite ( error ) & . and . error <= cnvtol ) then solver_name = \"AUTO(GMRES)\" else solver_name = \"AUTO(failed)\" end if end subroutine run_mrsf_zvector_auto ! Preconditioned CG z-vector solve (default path).  All state is ! reached by host association, matching the inline version exactly. subroutine run_mrsf_cg_zvector () real ( kind = dp ) :: t0 , rhs_norm2 logical :: warm_used ! ============================================ ! ORIGINAL CONJUGATE GRADIENT SOLVER ! ============================================ ! Initial guess: zero (cold) or the previous step's solution (warm-start). ! With a warm xk the initial residual machinery below stays correct -- it ! builds A*xk and r0 = rhs - A*xk exactly as for the cold start. call zv_warm_seed ( warm_used ) if ( zv_tmr_on ) t0 = zv_wtime () call sfrogen ( wrk1 , wrk2 , xk , nocca , noccb ) ! Alpha call orthogonal_transform ( 't' , nbf , mo_a , wrk1 , pa (:,:, 1 ), wrk3 ) ! Beta call orthogonal_transform ( 't' , nbf , mo_b , wrk2 , pa (:,:, 2 ), wrk3 ) if ( zv_tmr_on ) zv_t_trans = zv_t_trans + ( zv_wtime () - t0 ) !****** INITIAL (A+B)*xk : residual r0 = rhs - A*xk ********************** ! IMPORTANT: this MUST apply the SAME operator the CG loop iterates with ! (int2_tdgrd_data_t, int_amb=.false., beta channel = apb(:,:,2)), or the ! recurrence residual `errv` drifts from the true residual and CG converges ! to the wrong xk. For the cold start (xk=0) the density and hence lhs are ! zero regardless, so this is bit-identical to the previous code; it only ! matters once a warm-start guess (xk/=0) is used. call int2_data % clean () deallocate ( int2_data ) int2_data = int2_tdgrd_data_t ( & d2 = pa , & int_apb = . true ., & int_amb = . false ., & tamm_dancoff = . false ., & scale_exchange = scale_exch ) if ( zv_tmr_on ) t0 = zv_wtime () call int2_driver % run ( int2_data , & cam = dft . and . infos % dft % cam_flag , & alpha = infos % dft % cam_alpha , & beta = infos % dft % cam_beta ,& mu = infos % dft % cam_mu ) if ( zv_tmr_on ) zv_t_int2 = zv_t_int2 + ( zv_wtime () - t0 ) ab1 => int2_data % apb (:,:,:, 1 ) if ( zv_tmr_on ) t0 = zv_wtime () call symmetrize_matrix ( pa (:,:, 1 ), nbf ) call symmetrize_matrix ( pa (:,:, 2 ), nbf ) call utddft_fxc ( & basis = basis , & molGrid = molGrid , & isVecs = . true ., & wfa = mo_a , & wfb = mo_b , & fxa = ab1 (:,:, 1 : 1 ), & fxb = ab1 (:,:, 2 : 2 ), & dxa = pa (:,:, 1 : 1 ), & dxb = pa (:,:, 2 : 2 ), & nmtx = 1 , & threshold = 1.0d-15 , & infos = infos ) if ( zv_tmr_on ) zv_t_xc = zv_t_xc + ( zv_wtime () - t0 ) if ( zv_tmr_on ) t0 = zv_wtime () !   ALPHA: AO(M,N) -> MO(IA+) ... LPTMOA call mntoia ( ab1 (:,:, 1 ), ab1_mo_a , mo_a , mo_a , nocca , nocca ) call mntoia ( ab1 (:,:, 2 ), ab1_mo_b , mo_b , mo_b , noccb , noccb ) call sfrolhs ( lhs , xk , mo_energy_a , fa , fb , ab1_mo_a , ab1_mo_b , & nocca , noccb ) if ( zv_tmr_on ) zv_t_trans = zv_t_trans + ( zv_wtime () - t0 ) call pcgrbpini ( errv , pk , error , rhs , xminv , lhs ) ! Warm-start safeguard: if the seeded guess did not reduce the residual ! below the cold-start value ||rhs||&#94;2 (e.g. large MO rotation between ! steps, as in degenerate systems), discard it and restart from zero. The ! cold residual is exact (A*0 = 0 => r0 = rhs), so the fallback needs no ! extra Fock build -- it just reuses rhs. if ( warm_used ) then rhs_norm2 = dot_product ( rhs , rhs ) if (. not . ieee_is_finite ( error ) . or . error >= rhs_norm2 ) then write ( iw , '(\" MRSF z-vector warm-start: guess rejected (r0&#94;2 \",1p,e10.3, & &\" >= cold \",e10.3,\"); restarting from zero\")' ) error , rhs_norm2 call flush ( iw ) xk = 0.0_dp lhs = 0.0_dp call pcgrbpini ( errv , pk , error , rhs , xminv , lhs ) end if end if if (. not . ieee_is_finite ( error ) . or . any (. not . ieee_is_finite ( errv )) . or . & any (. not . ieee_is_finite ( pk )) . or . any (. not . ieee_is_finite ( lhs ))) then write ( iw , '(\" MRSF CG Z-Vector breakdown: non-finite initial PCG state\")' ) mrsf_zvector_breakdown = . true . error = huge ( 1.0_dp ) end if write ( iw , '(\" Initial error =\",3x,1p,e10.3,1x,\"/\",1p,e10.3)' ) error , cnvtol call flush ( iw ) ! ----------------------------------------------- do iter = 1 , infos % control % maxit_zv zv_n_iter = iter if ( zv_tmr_on ) t0 = zv_wtime () call sfrogen ( wrk1 , wrk2 , pk , nocca , noccb ) !     Alpha call orthogonal_transform ( 't' , nbf , mo_a , wrk1 , pa (:,:, 1 ), wrk3 ) !     Beta call orthogonal_transform ( 't' , nbf , mo_b , wrk2 , pa (:,:, 2 ), wrk3 ) if ( zv_tmr_on ) zv_t_trans = zv_t_trans + ( zv_wtime () - t0 ) ! Progressive screening: loosen the cutoff for this sigma build based on ! the residual carried in from the previous step (the initial residual on ! iter 1). Pinned to the tight floor once the residual is small, so the ! converged solution is exact. if ( zv_prog_on ) call int2_driver % set_cutoff ( zv_prog_tau ( error , zv_rc_save )) !     (A+B)*PK call int2_data % clean () deallocate ( int2_data ) int2_data = int2_tdgrd_data_t ( & d2 = pa , & int_apb = . true ., & int_amb = . false ., & tamm_dancoff = . false ., & scale_exchange = scale_exch ) if ( zv_tmr_on ) t0 = zv_wtime () call int2_driver % run ( int2_data , & cam = dft . and . infos % dft % cam_flag , & alpha = infos % dft % cam_alpha , & beta = infos % dft % cam_beta ,& mu = infos % dft % cam_mu ) if ( zv_tmr_on ) zv_t_int2 = zv_t_int2 + ( zv_wtime () - t0 ) ab1 => int2_data % apb (:,:,:, 1 ) !ab1 = ab1/2 call symmetrize_matrix ( pa (:,:, 1 ), nbf ) call symmetrize_matrix ( pa (:,:, 2 ), nbf ) if ( zv_tmr_on ) t0 = zv_wtime () call utddft_fxc ( & basis = basis , & molGrid = molGrid , & isVecs = . true ., & wfa = mo_a , & wfb = mo_b , & fxa = ab1 (:,:, 1 : 1 ), & fxb = ab1 (:,:, 2 : 2 ), & dxa = pa (:,:, 1 : 1 ), & dxb = pa (:,:, 2 : 2 ), & nmtx = 1 , & threshold = 1.0d-15 , & infos = infos ) if ( zv_tmr_on ) zv_t_xc = zv_t_xc + ( zv_wtime () - t0 ) if ( zv_tmr_on ) t0 = zv_wtime () !     ALPHA: AO(M,N) -> MO(IA+) ... LPTMOA call mntoia ( ab1 (:,:, 1 ), ab1_mo_a , mo_a , mo_a , nocca , nocca ) call mntoia ( ab1 (:,:, 2 ), ab1_mo_b , mo_b , mo_b , noccb , noccb ) call sfrolhs ( lhs , pk , mo_energy_a , fa , fb , ab1_mo_a , ab1_mo_b , & nocca , noccb ) if ( zv_tmr_on ) zv_t_trans = zv_t_trans + ( zv_wtime () - t0 ) if ( any (. not . ieee_is_finite ( lhs )) . or . any (. not . ieee_is_finite ( pk ))) then write ( iw , '(\" MRSF CG Z-Vector breakdown: non-finite lhs/search direction\")' ) mrsf_zvector_breakdown = . true . error = huge ( 1.0_dp ) exit end if if ( zv_tmr_on ) t0 = zv_wtime () pap = dot_product ( pk , lhs ) if (. not . ieee_is_finite ( pap ) . or . abs ( pap ) < MRSF_ZVEC_DENOMINATOR_FLOOR ) then write ( iw , '(\" MRSF CG Z-Vector breakdown: unsafe p&#94;T A p denominator\")' ) mrsf_zvector_breakdown = . true . error = huge ( 1.0_dp ) exit end if alpha = 1.0_dp / pap if (. not . ieee_is_finite ( alpha )) then write ( iw , '(\" MRSF CG Z-Vector breakdown: non-finite alpha\")' ) mrsf_zvector_breakdown = . true . error = huge ( 1.0_dp ) exit end if xk = xk + pk * alpha errv = errv - alpha * lhs if ( any (. not . ieee_is_finite ( xk )) . or . any (. not . ieee_is_finite ( errv ))) then write ( iw , '(\" MRSF CG Z-Vector breakdown: non-finite solution/residual update\")' ) mrsf_zvector_breakdown = . true . error = huge ( 1.0_dp ) exit end if error = dot_product ( errv , errv ) if (. not . ieee_is_finite ( error )) then write ( iw , '(\" MRSF CG Z-Vector breakdown: non-finite residual norm\")' ) mrsf_zvector_breakdown = . true . error = huge ( 1.0_dp ) exit end if write ( iw , '(\" Iter#\",I2,\" Error =\",& &3x,1p,e10.3,1x,\"/\",1p,e10.3)' ) & iter , error , cnvtol call flush ( iw ) if ( error < cnvtol ) then if ( zv_tmr_on ) zv_t_cg = zv_t_cg + ( zv_wtime () - t0 ) exit end if call pcgb ( pk , errv , xminv ) if ( any (. not . ieee_is_finite ( pk ))) then write ( iw , '(\" MRSF CG Z-Vector breakdown: non-finite search direction after preconditioner\")' ) mrsf_zvector_breakdown = . true . error = huge ( 1.0_dp ) exit end if if ( zv_tmr_on ) zv_t_cg = zv_t_cg + ( zv_wtime () - t0 ) end do ! Always leave int2_driver at the tight cutoff on exit. Progressive ! screening ramps it during the loop; if CG exits UNCONVERGED (e.g. the ! AUTO solver then falls back to MINRES/GMRES, which reuse int2_driver via ! apply_z_operator and do not ramp), the fallback must see the tight ! operator -- otherwise it would solve/check convergence against the ! screened one. (On convergence the last step is already pinned tight.) if ( zv_prog_on ) call int2_driver % set_cutoff ( zv_rc_save ) end subroutine run_mrsf_cg_zvector ! Lambda wrapper for preconditioner subroutine lambda_precond ( x_in , x_out ) real ( kind = dp ), intent ( in ) :: x_in (:) real ( kind = dp ), intent ( out ) :: x_out (:) call apply_z_precond ( x_in , x_out , xminv ) end subroutine lambda_precond ! Seed xk for the solver: zero (cold), the raw previous solution, or — when ! the MOs have rotated between steps — the previous solution PROJECTED into ! the current MO basis via the geometry-stable AO z-density: !   xk_old -> av_old(MO,old) -> Pz = C_old av_old C_old&#94;T (AO) !          -> C_new&#94;T S Pz S C_new (MO,new) -> gather -> xk. ! Same-geometry round-trip is exact (C&#94;T S C = I). The CG safeguard still ! rejects the guess if it doesn't beat the cold residual, so this can only ! help (large steps) or be ignored — never corrupt the gradient. subroutine zv_warm_seed ( used ) use mathlib , only : unpack_matrix logical , intent ( out ), optional :: used real ( kind = dp ), contiguous , pointer :: smptr (:) real ( kind = dp ), allocatable :: smat (:,:), ava (:,:), avb (:,:), pz (:,:), & tmp (:,:), avn1 (:,:), avn2 (:,:) integer :: st , ok logical :: have , got_warm if ( present ( used )) used = . false . xk = 0.0_dp got_warm = . false . st = target_state ! ---- try a warm-start guess from the previous step (short-circuit guards) ---- have = zv_warm_on . and . allocated ( zv_warm ) . and . allocated ( zv_warm_has ) & . and . zv_warm_lzdim == lzdim if ( have ) have = ( st >= 1 . and . st <= size ( zv_warm_has )) if ( have ) have = zv_warm_has ( st ) if ( have ) have = . not . any (. not . ieee_is_finite ( zv_warm (:, st ))) if ( have ) then if ( zv_warm_have_mo . and . zv_warm_nbf == nbf ) then ! MO-projected seed: xk_old -> Pz(AO,old) -> C_new&#94;T S Pz S C_new -> gather allocate ( smat ( nbf , nbf ), ava ( nbf , nbf ), avb ( nbf , nbf ), pz ( nbf , nbf ), & tmp ( nbf , nbf ), avn1 ( nbf , nbf ), avn2 ( nbf , nbf ), stat = ok ) if ( ok == 0 ) then call tagarray_get_data ( infos % dat , OQP_SM , smptr ) call unpack_matrix ( smptr , smat , nbf , 'U' ) call sfrogen ( ava , avb , zv_warm (:, st ), nocca , noccb ) call orthogonal_transform ( 't' , nbf , zv_warm_moa , ava , pz , wrk3 ) call dgemm ( 'n' , 'n' , nbf , nbf , nbf , 1.0_dp , smat , nbf , pz , nbf , 0.0_dp , tmp , nbf ) call dgemm ( 'n' , 'n' , nbf , nbf , nbf , 1.0_dp , tmp , nbf , smat , nbf , 0.0_dp , pz , nbf ) call orthogonal_transform ( 'n' , nbf , mo_a , pz , avn1 , wrk3 ) call orthogonal_transform ( 't' , nbf , zv_warm_mob , avb , pz , wrk3 ) call dgemm ( 'n' , 'n' , nbf , nbf , nbf , 1.0_dp , smat , nbf , pz , nbf , 0.0_dp , tmp , nbf ) call dgemm ( 'n' , 'n' , nbf , nbf , nbf , 1.0_dp , tmp , nbf , smat , nbf , 0.0_dp , pz , nbf ) call orthogonal_transform ( 'n' , nbf , mo_b , pz , avn2 , wrk3 ) call zv_sfrogen_gather ( avn1 , avn2 , xk , nocca , noccb ) if ( any (. not . ieee_is_finite ( xk ))) xk = zv_warm (:, st ) deallocate ( smat , ava , avb , pz , tmp , avn1 , avn2 ) got_warm = . true . write ( iw , '(\" MRSF z-vector warm-start: MO-projected seed (state \",i0,\")\")' ) st end if else xk = zv_warm (:, st ); got_warm = . true . write ( iw , '(\" MRSF z-vector warm-start: raw seed (state \",i0,\")\")' ) st end if end if if ( got_warm ) then if ( present ( used )) used = . true . call flush ( iw ) return end if ! ---- cold start: Jacobi (diagonal) guess x0 = M&#94;-1 rhs, else zero ---- ! Free (the cold initial Fock build runs regardless) and ~1 iteration ahead. ! Marked \"used\" so the CG safeguard validates it and falls back to zero if ! it does not reduce the residual. if ( zv_diag_guess ) then xk = xminv * rhs if ( any (. not . ieee_is_finite ( xk ))) then xk = 0.0_dp else if ( present ( used )) used = . true . write ( iw , '(\" MRSF z-vector: Jacobi (diagonal) initial guess\")' ) call flush ( iw ) end if end if end subroutine zv_warm_seed ! minres_matvec(y, x, dat) wrappers: y is the output, x the input, dat is ! unused (the solver context is reached by host association). subroutine minres_apply_op ( y , x , dat ) use iso_c_binding , only : c_ptr real ( kind = dp ) :: x (:) real ( kind = dp ) :: y (:) type ( c_ptr ) :: dat call apply_z_operator ( x , y , infos , basis , molGrid , int2_driver , & nocca , noccb , nbf , mo_a , mo_b , mo_energy_a , & fa , fb , scale_exch , dft ) end subroutine minres_apply_op subroutine minres_apply_pc ( y , x , dat ) use iso_c_binding , only : c_ptr real ( kind = dp ) :: x (:) real ( kind = dp ) :: y (:) type ( c_ptr ) :: dat call apply_z_precond ( x , y , xminv ) end subroutine minres_apply_pc ! Build the relaxed (z-vector) density (-> td_p) and energy-weighted ! density W (-> wao) from the converged z-vector xk.  Host association ! preserves behavior versus the previous inline tail. subroutine build_mrsf_relaxed_density_and_w () if ( mrst == 1 . or . mrst == 3 ) then call sfropcal ( wrk1 , wrk2 , tij , tab , xk , nocca , noccb ) else if ( mrst == 5 ) then call mrsfqropcal ( wrk1 , wrk2 , tab , tij , xk , nocca , noccb ) end if !  Update density for alpha call orthogonal_transform ( 't' , nbf , mo_a , wrk1 , pa (:,:, 1 ), wrk3 ) !  Update density for beta call orthogonal_transform ( 't' , nbf , mo_b , wrk2 , pa (:,:, 2 ), wrk3 ) call int2_data % clean () deallocate ( int2_data ) int2_data = int2_tdgrd_data_t ( & d2 = pa , & int_apb = . true ., & int_amb = . false ., & tamm_dancoff = . false ., & scale_exchange = scale_exch ) call int2_driver % run ( int2_data , & cam = dft . and . infos % dft % cam_flag , & alpha = infos % dft % cam_alpha , & beta = infos % dft % cam_beta ,& mu = infos % dft % cam_mu ) ab1 => int2_data % apb (:,:,:, 1 ) call symmetrize_matrix ( pa (:,:, 1 ), nbf ) call symmetrize_matrix ( pa (:,:, 2 ), nbf ) call pack_matrix ( pa (:,:, 1 ), td_p (:, 1 )) call pack_matrix ( pa (:,:, 2 ), td_p (:, 2 )) td_p = 0.5_dp * td_p call utddft_fxc ( & basis = basis , & molGrid = molGrid , & isVecs = . true ., & wfa = mo_a , & wfb = mo_b , & fxa = ab1 (:,:, 1 : 1 ), & fxb = ab1 (:,:, 2 : 2 ), & dxa = pa (:,:, 1 : 1 ), & dxb = pa (:,:, 2 : 2 ), & nmtx = 1 , & threshold = 1.0d-15 , & infos = infos ) !   ALPHA AO(M,N) -> MO(I-,J-) ... LPPIJA call dgemm ( 'n' , 'n' , nbf , nocca , nbf , & 1.0_dp , ab1 (:,:, 1 ), nbf , & mo_a , nbf , & 0.0_dp , wrk2 , nbf ) call dgemm ( 't' , 'n' , nocca , nocca , nbf , & 1.0_dp , mo_a , nbf , & wrk2 , nbf , & 0.0_dp , ppija , nocca ) !   BETA: AO(M,N) -> MO(I-,J-) ... LPPIJB call dgemm ( 'n' , 'n' , nbf , noccb , nbf , & 1.0_dp , ab1 (:,:, 2 ), nbf , & mo_b , nbf , & 0.0_dp , wrk2 , nbf ) call dgemm ( 't' , 'n' , noccb , noccb , nbf , & 1.0_dp , mo_b , nbf , & wrk2 , nbf , & 0.0_dp , ppijb , noccb ) !   Calculate W (in MO basis) wmo => wrk3 wmo = 0 if ( mrst == 1 . or . mrst == 3 ) then call mrsfrowcal ( wmo , mo_energy_a , fa , fb , xk , & hxa , hxb , ppija , ppijb , & nocca , noccb ) else if ( mrst == 5 ) then call mrsfqrowcal ( wmo , mo_energy_a , fa , fb , xk , & hxa , hxb , ppija , ppijb , & nocca , noccb ) end if call orthogonal_transform ( 't' , nbf , mo_a , wmo , wrk2 , wrk1 ) call symmetrize_matrix ( wrk2 , nbf ) call pack_matrix ( wrk2 , wao ) wao = wao * 0.5_dp !   ROHF, half one more time: wao = wao * 0.5_dp end subroutine build_mrsf_relaxed_density_and_w ! Assemble the z-vector right-hand side (rhs) and the ROHF Fock/density ! intermediates it needs.  Host association preserves behavior versus the ! previous inline RHS construction. subroutine build_mrsf_zvector_rhs () ! Prepare for ROHF ! Fock matrices A and B if ( roref ) then wrk1t ( 1 : nbf * nbf ) => wrk1 !   Alapha call orthogonal_transform_sym ( nbf , nbf , fock_a , mo_a , nbf , wrk1 ) call unpack_matrix ( wrk1t , fa ) !   Beta call orthogonal_transform_sym ( nbf , nbf , fock_b , mo_b , nbf , wrk1 ) call unpack_matrix ( wrk1t , fb ) end if ! Make density like part call unpack_matrix ( ta , pa (:,:, 1 )) call unpack_matrix ( tb , pa (:,:, 2 )) ! Initialize ERI calculations scale_exch = 1.0_dp scale_exch2 = 1.0_dp if ( dft ) then scale_exch = infos % dft % HFscale ! Reference HF exchange scale_exch2 = infos % tddft % HFscale ! Response HF exchange end if if ( mrst == 1 . or . mrst == 3 ) then int2_data_st = int2_mrsf_data_t ( & d3 = fmrst1 , & tamm_dancoff = . true ., & scale_exchange = scale_exch2 , & scale_coulomb = scale_exch2 ) else if ( mrst == 5 ) then int2_data_q = int2_td_data_t ( & d2 = bvec , & int_apb = . false ., & int_amb = . false ., & tamm_dancoff = . true ., & scale_exchange = scale_exch2 ) end if int2_data = int2_tdgrd_data_t ( & d2 = pa , & int_apb = . true ., & int_amb = . false ., & tamm_dancoff = . false ., & scale_exchange = scale_exch ) call int2_driver % run ( int2_data , & cam = dft . and . infos % dft % cam_flag , & alpha = infos % dft % cam_alpha , & beta = infos % dft % cam_beta ,& mu = infos % dft % cam_mu ) ab1 => int2_data % apb (:,:,:, 1 ) pa = pa * 2 call utddft_fxc ( & basis = basis , & molGrid = molGrid , & isVecs = . true ., & wfa = mo_a , & wfb = mo_b , & fxa = ab1 (:,:, 1 : 1 ), & fxb = ab1 (:,:, 2 : 2 ), & dxa = pa (:,:, 1 : 1 ), & dxb = pa (:,:, 2 : 2 ), & nmtx = 1 , & threshold = 1.0d-15 , & infos = infos ) !   ALPHA: AO(M,N) -> MO(IA+) call mntoia ( ab1 (:,:, 1 ), ab1_mo_a , mo_a , mo_a , nocca , nocca ) call mntoia ( ab1 (:,:, 2 ), ab1_mo_b , mo_b , mo_b , noccb , noccb ) if ( mrst == 1 . or . mrst == 3 ) then call iatogen ( bvec_mo (:, target_state ), wrk1 , nocca , noccb ) call mrsfcbc ( infos , mo_a , mo_a , wrk1 , fmrst1 ( 1 ,:,:,:)) fmrst1 ( 1 , 7 ,:,:) = td_abxc td_mrsf_den ( 1 : 7 ,:,:) = fmrst1 ( 1 , 1 : 7 ,:,:) ! Initialize ERI calculations call int2_driver % run ( int2_data_st , & cam = dft . and . infos % dft % cam_flag , & alpha = infos % tddft % cam_alpha , & alpha_coulomb = infos % tddft % cam_alpha , & beta = infos % tddft % cam_beta ,& beta_coulomb = infos % tddft % cam_beta , & mu = infos % tddft % cam_mu ) fmrst2 => int2_data_st % f3 (:,:,:,:, 1 ) ! ado2v, ado1v, adco1, adco2, ao21v, aco12, agdlr ! Scaling factor if triplet if ( mrst == 3 ) fmrst2 (:, 1 : 6 ,:,:) = - 1.0_dp * fmrst2 (:, 1 : 6 ,:,:) ! Spin pair coupling if ( infos % tddft % spc_coco /= infos % tddft % hfscale ) & fmrst2 (:, 6 ,:,:) = fmrst2 (:, 6 ,:,:) * infos % tddft % spc_coco / infos % tddft % hfscale if ( infos % tddft % spc_ovov /= infos % tddft % hfscale ) & fmrst2 (:, 5 ,:,:) = fmrst2 (:, 5 ,:,:) * infos % tddft % spc_ovov / infos % tddft % hfscale if ( infos % tddft % spc_coov /= infos % tddft % hfscale ) & fmrst2 (:, 1 : 4 ,:,:) = fmrst2 (:, 1 : 4 ,:,:) * infos % tddft % spc_coov / infos % tddft % hfscale call orthogonal_transform ( 'n' , nbf , mo_a , fmrst2 ( 1 , 7 ,:,:), wrk2 , wrk1 ) call mrsfxvec ( infos , bvec_mo (:, target_state ), bvec_mo_d (:, 1 )) call iatogen ( bvec_mo_d (:, 1 ), wrk3 , nocca , noccb ) call dgemm ( 'n' , 't' , nbf , nocca , nbf , & 2.0_dp , wrk2 , nbf , & wrk3 , nbf , & 0.0_dp , hxa , nbf ) call dgemm ( 't' , 'n' , nbf , nbf , nocca , & 2.0_dp , wrk2 , nbf , & wrk3 , nbf , & 0.0_dp , hxb , nbf ) ! spin pair ov-ov, co-co, co-ov coupling call mrsfsp ( hxa , hxb , mo_a , mo_a , wrk3 , fmrst2 ( 1 ,:,:,:), nocca , noccb ) !  Unrelaxed difference density matries T_ij and T_ab !  Ta(i+,j+):= -X(i+,a-)*X(j+,a-) for singlet and triplet call dgemm ( 'n' , 't' , nocca , nocca , nvirb , & - 1.0_dp , bvec_mo_d , nocca , & bvec_mo_d , nocca , & 0.0_dp , tij , nocca ) !  Tb(a-,b-):= X(i+,a-)*X(i+,b-) for singlet and triplet call dgemm ( 't' , 'n' , nvirb , nvirb , nocca , & 1.0_dp , bvec_mo_d , nocca , & bvec_mo_d , nocca , & 0.0_dp , tab , nvirb ) call sfrorhs ( rhs , hxa , hxb , ab1_mo_a , ab1_mo_b , & Tij , Tab , Fa , Fb , nocca , noccb ) else if ( mrst == 5 ) then !  Initialize ERI calculations call int2_driver % run ( int2_data_q , & cam = dft . and . infos % dft % cam_flag , & alpha = infos % tddft % cam_alpha , & beta = infos % tddft % cam_beta ,& mu = infos % tddft % cam_mu ) call orthogonal_transform ( 'n' , nbf , mo_a , int2_data_q % amb (:,:, 1 , 1 ), wrk2 , wrk1 ) call iatogen ( bvec_mo (:, target_state ), wrk3 , noccb , nocca ) call dgemm ( 't' , 'n' , nbf , nbf , noccb , & 2.0_dp , wrk2 , nbf , & wrk3 , nbf , & 0.0_dp , hxa , nbf ) call dgemm ( 'n' , 't' , nbf , noccb , nbf , & 2.0_dp , wrk2 , nbf , & wrk3 , nbf , & 0.0_dp , hxb , nbf ) !  Unrelaxed difference density matries T_ij and T_ab !  Ta(i+,j+):= -X(i+,a-)*X(j+,a-) for singlet and triplet call dgemm ( 'n' , 't' , noccb , noccb , nvira , & - 1.0_dp , bvec_mo (:, target_state ), noccb , & bvec_mo (:, target_state ), noccb , & 0.0_dp , tij , noccb ) !  Tb(a-,b-):= X(i+,a-)*X(i+,b-) for singlet and triplet call dgemm ( 't' , 'n' , nvira , nvira , noccb , & 1.0_dp , bvec_mo (:, target_state ), noccb , & bvec_mo (:, target_state ), noccb , & 0.0_dp , tab , nvira ) call mrsfqrorhs ( rhs , hxa , hxb , ab1_mo_a , ab1_mo_b , & tab , tij , fa , fb , nocca , noccb ) end if end subroutine build_mrsf_zvector_rhs end subroutine tdhf_mrsf_z_vector end module tdhf_mrsf_z_vector_mod","tags":"","url":"sourcefile/tdhf_mrsf_z_vector.f90.html"},{"title":"dft_gridint_tdxc_grad.F90 – OpenQP Fortran API","text":"Source Code module mod_dft_gridint_tdxc_grad use precision , only : fp use mod_dft_gridint , only : xc_engine_t , xc_consumer_t use mod_dft_gridint , only : OQP_FUNTYP_LDA , OQP_FUNTYP_GGA , OQP_FUNTYP_MGGA use mod_dft_gridint , only : compAtGradRho , compAtGradDRho , compAtGradTau implicit none !------------------------------------------------------------------------------- type , extends ( xc_consumer_t ) :: xc_consumer_tdg_t integer :: nMtx = 1 logical :: do_fxc = . true . !< Whether to compute dF_xc / dR_i logical :: do_ground_state = . true . !< Whether to add g.s. XC gradient contribution real ( kind = fp ), pointer :: pa (:,:,:) real ( kind = fp ), pointer :: pb (:,:,:) real ( kind = fp ), pointer :: xa (:,:,:) real ( kind = fp ), pointer :: xb (:,:,:) real ( kind = fp ), allocatable :: rrho (:,:,:,:) real ( kind = fp ), allocatable :: drrho (:,:,:,:,:) real ( kind = fp ), allocatable :: rtau (:,:,:,:) real ( kind = fp ), allocatable :: bfgrad (:,:,:) real ( kind = fp ), allocatable :: grad_d (:,:,:,:) !< density gradient real ( kind = fp ), allocatable :: grad_p (:,:,:,:) !< diff. density gradient real ( kind = fp ), allocatable :: grad_x (:,:,:,:) !< transition (X+Y) gradient !   Temporary storage real ( kind = fp ), allocatable :: tmpGrad_ (:,:) real ( kind = fp ), allocatable :: tmp_ (:,:,:,:) real ( kind = fp ), allocatable :: tmpV_ (:,:,:) real ( kind = fp ), allocatable :: tmpG1_ (:,:,:) contains procedure :: parallel_start procedure :: parallel_stop procedure :: resetGradPointers procedure :: resetPointers procedure :: update procedure :: postUpdate procedure :: clean end type !------------------------------------------------------------------------------- private public tddft_xc_gradient public utddft_xc_gradient !------------------------------------------------------------------------------- contains !------------------------------------------------------------------------------- subroutine parallel_start ( self , xce , nthreads ) implicit none class ( xc_consumer_tdg_t ), target , intent ( inout ) :: self class ( xc_engine_t ), intent ( in ) :: xce integer , intent ( in ) :: nthreads integer :: nspin , nterms , nDeriv call self % clean () nterms = 1 if ( xce % funTyp /= OQP_FUNTYP_LDA ) nterms = nterms + 3 if ( xce % funTyp == OQP_FUNTYP_MGGA ) nterms = nterms + 1 nspin = merge ( 2 , 1 , xce % hasBeta ) nDeriv = merge ( 2 , 1 , self % do_fxc ) allocate ( & self % bfgrad ( xce % numAOs , 3 , nthreads ) & , self % rrho ( nspin , xce % maxPts , self % nMtx , nthreads ) & , self % drrho ( 3 , nspin , xce % maxPts , self % nMtx , nthreads ) & , self % grad_d ( xce % maxPts , nterms , nspin , nthreads ) & , self % grad_p ( xce % maxPts , nterms , nspin , nthreads ) & !   Temporary storage , self % tmpGrad_ ( xce % numAOs * 3 , nthreads ) & , self % tmp_ ( xce % numAOs * xce % numAOs * self % nMtx , nspin , nDeriv , nthreads ) & , self % tmpV_ ( xce % numAOs * xce % maxPts * self % nMtx * nspin , nDeriv , nthreads ) & , self % tmpG1_ ( xce % numAOs * xce % maxPts * 3 * self % nMtx * nspin , nDeriv , nthreads ) & , source = 0.0d0 ) if ( self % do_fxc ) then allocate ( & self % grad_x ( xce % maxPts , nterms , nspin , nthreads ) & , source = 0.0d0 ) end if if ( xce % funTyp == OQP_FUNTYP_MGGA ) then allocate ( & self % rtau ( nSpin , xce % maxPts , self % nMtx , nthreads ) & , source = 0.0d0 ) end if end subroutine !------------------------------------------------------------------------------- subroutine parallel_stop ( self ) implicit none class ( xc_consumer_tdg_t ), intent ( inout ) :: self if ( ubound ( self % bfGrad , 3 ) /= 1 ) then self % bfGrad (:,:, lbound ( self % bfGrad , 3 )) = sum ( self % bfGrad , dim = 3 ) end if call self % pe % allreduce ( self % bfGrad (:,:, 1 ), & size ( self % bfGrad (:,:, 1 ))) end subroutine !------------------------------------------------------------------------------- subroutine clean ( self ) implicit none class ( xc_consumer_tdg_t ), intent ( inout ) :: self if ( allocated ( self % bfgrad )) deallocate ( self % bfgrad ) if ( allocated ( self % rrho )) deallocate ( self % rrho ) if ( allocated ( self % drrho )) deallocate ( self % drrho ) if ( allocated ( self % rtau )) deallocate ( self % rtau ) if ( allocated ( self % tmpGrad_ )) deallocate ( self % tmpGrad_ ) if ( allocated ( self % tmp_ )) deallocate ( self % tmp_ ) if ( allocated ( self % tmpV_ )) deallocate ( self % tmpV_ ) if ( allocated ( self % tmpG1_ )) deallocate ( self % tmpG1_ ) end subroutine !------------------------------------------------------------------------------- !> @brief Adjust internal memory storage for a given !>  number of pruned grid points !> @author Konstantin Komarov subroutine resetGradPointers ( self , xce , tmpGrad , tmpV , tmpG1 , myThread ) class ( xc_consumer_tdg_t ), target , intent ( inout ) :: self class ( xc_engine_t ), intent ( in ) :: xce real ( kind = fp ), intent ( out ), pointer :: tmpGrad (:,:) real ( kind = fp ), intent ( out ), pointer , optional :: tmpV (:,:,:,:,:) real ( kind = fp ), intent ( out ), pointer , optional :: tmpG1 (:,:,:,:,:,:) integer , intent ( in ) :: myThread integer :: nSpin nspin = merge ( 2 , 1 , xce % hasBeta ) associate ( numAOs => xce % numAOs_p & ! number of pruned AOs , numPts => xce % numPts & , nMtx => self % nMtx & ) tmpGrad ( 1 : numAOs , 1 : 3 ) => self % tmpGrad_ ( 1 : numAOs * 3 , myThread ) if ( present ( tmpV )) & tmpV ( 1 : numAOs , 1 : numPts , 1 : nMtx , 1 : nSpin , 1 : 1 ) => & self % tmpV_ ( 1 : numAOs * numPts * nMtx * nspin , 1 , myThread ) if ( present ( tmpG1 )) & tmpG1 ( 1 : numAOs , 1 : numPts , 1 : 3 , 1 : nMtx , 1 : nSpin , 1 : 1 ) => & self % tmpG1_ ( 1 : numAOs * numPts * 3 * nMtx * nspin , 1 , mythread ) if ( present ( tmpV ) . and . self % do_fxc ) & tmpV ( 1 : numAOs , 1 : numPts , 1 : nMtx , 1 : nSpin , 2 : 2 ) => & self % tmpV_ ( 1 : numAOs * numPts * nMtx * nspin , 2 , myThread ) if ( present ( tmpG1 ) . and . self % do_fxc ) & tmpG1 ( 1 : numAOs , 1 : numPts , 1 : 3 , 1 : nMtx , 1 : nSpin , 2 : 2 ) => & self % tmpG1_ ( 1 : numAOs * numPts * 3 * nMtx * nspin , 2 , mythread ) end associate end subroutine subroutine resetPointers ( self , xce , Pa , Pb , Xa , Xb , & Pa_p , Pb_p , Xa_p , Xb_p , myThread ) class ( xc_consumer_tdg_t ), target , intent ( inout ) :: self class ( xc_engine_t ), intent ( in ) :: xce real ( kind = fp ), intent ( in ), target :: Pa (:,:,:) real ( kind = fp ), intent ( in ), target :: Pb (:,:,:) real ( kind = fp ), intent ( in ), target :: Xa (:,:,:) real ( kind = fp ), intent ( in ), target :: Xb (:,:,:) real ( kind = fp ), intent ( out ), pointer :: Pa_p (:,:,:) ! pruned real ( kind = fp ), intent ( out ), pointer :: Pb_p (:,:,:) ! pruned real ( kind = fp ), intent ( out ), pointer :: Xa_p (:,:,:) ! pruned real ( kind = fp ), intent ( out ), pointer :: Xb_p (:,:,:) ! pruned integer , intent ( in ) :: myThread integer :: nSpin nspin = merge ( 2 , 1 , xce % hasBeta ) associate ( indices => xce % indices_p & , numAOs => xce % numAOs_p & ! number of pruned numAOs , numPts => xce % numPts & , nMtx => self % nMtx & ) if ( xce % skip_p ) then !       no pruned AOs Pa_p => Pa if ( xce % hasBeta ) Pb_p => Pb if ( self % do_fxc ) Xa_p => Xa if ( self % do_fxc . and . xce % hasBeta ) Xb_p => Xb else !       pruned AOs Pa_p ( 1 : numAOs , 1 : numAOs , 1 : nMtx ) => self % tmp_ ( 1 : numAOs * numAOs * nMtx , 1 , 1 , myThread ) !       Compress matrix Pa_p ( 1 : numAOs , 1 : numAOs ,:) = Pa ( indices ( 1 : numAOs ), indices ( 1 : numAOs ),:) ! if do dF_xc / dR_i if ( self % do_fxc ) then Xa_p ( 1 : numAOs , 1 : numAOs , 1 : nMtx ) => self % tmp_ ( 1 : numAOs * numAOs * nMtx , 1 , 2 , myThread ) Xa_p ( 1 : numAOs , 1 : numAOs ,:) = Xa ( indices ( 1 : numAOs ), indices ( 1 : numAOs ),:) end if if ( xce % hasBeta ) then Pb_p ( 1 : numAOs , 1 : numAOs , 1 : nMtx ) => self % tmp_ ( 1 : numAOs * numAOs * nMtx , 2 , 1 , myThread ) Pb_p ( 1 : numAOs , 1 : numAOs ,:) = Pb ( indices ( 1 : numAOs ), indices ( 1 : numAOs ),:) if ( self % do_fxc ) then Xb_p ( 1 : numAOs , 1 : numAOs , 1 : nMtx ) => self % tmp_ ( 1 : numAOs * numAOs * nMtx , 2 , 2 , myThread ) Xb_p ( 1 : numAOs , 1 : numAOs ,:) = Xb ( indices ( 1 : numAOs ), indices ( 1 : numAOs ),:) end if end if end if end associate end subroutine subroutine update ( self , xce , mythread ) class ( xc_consumer_tdg_t ), intent ( inout ) :: self class ( xc_engine_t ), intent ( in ) :: xce integer :: mythread real ( kind = fp ), pointer :: tmpGrad (:,:) real ( kind = fp ), pointer :: Pa (:,:,:) real ( kind = fp ), pointer :: Pb (:,:,:) real ( kind = fp ), pointer :: Xa (:,:,:) real ( kind = fp ), pointer :: Xb (:,:,:) real ( kind = fp ), pointer :: tmpV (:,:,:,:,:) real ( kind = fp ), pointer :: tmpG1 (:,:,:,:,:,:) call self % resetGradPointers ( xce , tmpGrad , tmpV , tmpG1 , myThread ) ! Needs to nullify it for each update tmpGrad = 0.0d0 associate ( bfgrad => self % bfgrad (:,:, mythread ) & , grad_d => self % grad_d (:,:,:, mythread ) & , grad_p => self % grad_p (:,:,:, mythread ) & , grad_x => self % grad_x (:,:,:, mythread ) & , aoV => xce % aoV & , aoG1 => xce % aoG1 & , aoG2 => xce % aoG2 & , moVA => xce % moVA & , moVB => xce % moVB & , moG1A => xce % moG1A & , moG1B => xce % moG1B & , rrho => self % rrho (:,:,:, mythread ) & , drrho => self % drrho (:,:,:,:, mythread ) & , rtau => self % rtau (:,:,:, mythread ) & , drho => xce % xclib % drho & , numPts => xce % numPts & , xc => xce % XCLib & , ids => xce % XCLib % ids & ) ! Compute \"MOs\" which correspond to the ground ! state and the relaxed difference density matrices ! They are basically right sides of ! \\Phi (A \\Phi), and \\Phi (A \\nabla\\Psi) ! where A is some density-like matrix call self % resetPointers ( xce , self % pa , self % pb , self % xa , self % xb , & Pa , Pb , Xa , Xb , myThread ) call xce % compRMOs ( Pa , tmpV (:,:,:, 1 , 1 )) call xce % compRMOGs ( Pa , tmpG1 (:,:,:,:, 1 , 1 )) if ( xce % hasBeta ) then call xce % compRMOs ( Pb , tmpV (:,:,:, 2 , 1 )) call xce % compRMOGs ( Pb , tmpG1 (:,:,:,:, 2 , 1 )) end if ! d V_xc / d R_i ! Compute difference densities: \\rho, \\nabla\\rho, and \\tau call xce % compRRho ( tmpV (:,:,:,:, 1 ), rRho ) call xce % compRDRho ( tmpV (:,:,:,:, 1 ), drRho ) if ( xce % funTyp == OQP_FUNTYP_MGGA ) then call xce % compRTau ( tmpG1 (:,:,:,:,:, 1 ), rTau ) end if ! Compute XC 1st and 2nd derivative and compute terms for contraction ! with g.s. density (`grad_d`) and difference density (`grad_p`) if ( xce % hasBeta ) then call grad_v_xc ( self , xce , mythread ) else call grad_v_xc_np ( self , xce , mythread ) end if ! d F_xc / dR_i if ( self % do_fxc ) then ! Compute \"MOs\" which correspond to the `X+Y` transition density call xce % compRMOs ( Xa , tmpV (:,:,:, 1 , 2 )) call xce % compRMOGs ( Xa , tmpG1 (:,:,:,:, 1 , 2 )) if ( xce % hasBeta ) then call xce % compRMOs ( Xb , tmpV (:,:,:, 2 , 2 )) call xce % compRMOGs ( Xb , tmpG1 (:,:,:,:, 2 , 2 )) end if ! Compute transition densities: \\rho, \\nabla\\rho, and \\tau call xce % compRRho ( tmpV (:,:,:,:, 2 ), rrho ) call xce % compRDRho ( tmpV (:,:,:,:, 2 ), drrho ) if ( xce % funTyp == OQP_FUNTYP_MGGA ) then call xce % compRTau ( tmpG1 (:,:,:,:,:, 2 ), rtau ) end if ! Compute XC 1st-3rd derivatives and compute terms for contraction ! with g.s. density (`grad_d`) and transition density (`grad_x`) if ( xce % hasBeta ) then call grad_f_xc ( self , xce , mythread ) else call grad_f_xc_np ( self , xce , mythread ) end if end if if ( self % do_ground_state ) then ! `grad_p` also contains functional derivative terms ! required to compute ground state contribution to the gradient. ! We can do it here instead of separate G.S. DFT gradient run ! To contract them with the ground state density ! we add it here to the `grad_d` grad_d = grad_d + grad_p end if ! In RHF case g.s. density is twice the alpha density ! TODO: make it consistent if (. not . xce % hasBeta ) grad_d = 0.5 * grad_d ! Compute contribution to the AO gradient from all `grad_P` terms call compAtGradAll ( tmpGrad , grad_D (:,:, 1 ), xce % funTyp , & moVA , moG1A , aoG1 , aoG2 , numPts ) call compAtGradAll ( tmpGrad , grad_P (:,:, 1 ), xce % funTyp , & tmpV (:,:, 1 , 1 , 1 ), tmpG1 (:,:,:, 1 , 1 , 1 ), aoG1 , aoG2 , numPts ) if ( xce % hasBeta ) then call compAtGradAll ( tmpGrad , grad_D (:,:, 2 ), xce % funTyp , & moVB , moG1B , aoG1 , aoG2 , numPts ) call compAtGradAll ( tmpGrad , grad_P (:,:, 2 ), xce % funTyp , & tmpV (:,:, 1 , 2 , 1 ), tmpG1 (:,:,:, 1 , 2 , 1 ), aoG1 , aoG2 , numPts ) end if ! d F_xc / dR_i if ( self % do_fxc ) then ! Compute contribution to the AO gradient from all `grad_X` terms call compAtGradAll ( tmpGrad , grad_X (:,:, 1 ), xce % funTyp , & tmpV (:,:, 1 , 1 , 2 ), tmpG1 (:,:,:, 1 , 1 , 2 ), aoG1 , aoG2 , numPts ) if ( xce % hasBeta ) & call compAtGradAll ( tmpGrad , grad_X (:,:, 2 ), xce % funTyp , & tmpV (:,:, 1 , 2 , 2 ), tmpG1 (:,:,:, 1 , 2 , 2 ), aoG1 , aoG2 , numPts ) end if end associate end subroutine subroutine postUpdate ( self , xce , mythread ) class ( xc_consumer_tdg_t ), intent ( inout ) :: self class ( xc_engine_t ), intent ( in ) :: xce integer :: mythread real ( kind = fp ), pointer :: tmpGrad (:,:) call self % resetGradPointers ( xce , tmpGrad , myThread = myThread ) associate ( numAOs => xce % numAOs_p & ! number of pruned AOs , indices => xce % indices_p & ) if ( xce % skip_p ) then self % bfGrad (:,:, myThread ) = self % bfGrad (:,:, myThread ) + tmpGrad else self % bfGrad ( indices ( 1 : numAOs ), :, mythread ) = & self % bfGrad ( indices ( 1 : numAOs ), :, mythread ) + tmpGrad ( 1 : numAOs , :) end if end associate end subroutine !> @brief Compute contribution to the AO gradient from !>   LDA, GGA and metaGGA functional derivatives !> @param[inout] bfGrad   array of gradient contributions per AO !> @param[in]    fgrad    XC gradient !> @param[in]    funTyp   type of the XC functional !> @param[in]    moV      MO-like orbital values !> @param[in]    moG1     MO-like orbital gradients !> @param[in]    aoG1     AO orbital gradients !> @param[in]    aoG2     AO orbital 2nd derivatives !> @param[in]    npts     number of grid points in a chunk !> @author Vladimir Mironov subroutine compAtGradAll ( bfGrad , fgrad , funTyp , moV , moG1 , aoG1 , aoG2 , npts ) integer , intent ( in ) :: funTyp real ( kind = fp ), intent ( in ) :: fgrad (:,:) real ( kind = fp ), intent ( inout ) :: bfGrad (:,:) real ( kind = fp ), contiguous , intent ( in ) :: moV (:,:), aoG1 (:,:,:) real ( kind = fp ), contiguous , intent ( in ) :: moG1 (:,:,:) real ( kind = fp ), contiguous , intent ( in ) :: aoG2 (:,:,:) integer , intent ( in ) :: npts !   LDA gradient call compAtGradRho ( bfGrad , fgrad (:, 1 ), moV (:,:), aoG1 , npts ) !   GGA gradient if ( funTyp /= OQP_FUNTYP_LDA ) then call compAtGradDRho ( bfGrad , fgrad (:, 2 : 4 ), & moV , moG1 , aoG1 , aoG2 , npts ) end if if ( funTyp == OQP_FUNTYP_MGGA ) then call compAtGradTau ( bfGrad , fgrad (:, 5 ), & moG1 (:,:,:), aoG2 , npts ) end if end subroutine !> @brief Compute derivative terms of \\sum_ij V&#94;xc_ij P_ij !>  w.r.t. atomic coordinates !> @detail this subroutine update terms which should be contracted with !>  ground state (`grad_d`) and relaxed difference densities (`grad_p`) !> @note For further details see: !>  [1] F.Furche, R.Ahlrichs, J.Chem.Phys. 117, p. 7433 (2002) !>  [2] G.Scalmani et al., J.Chem.Phys. 124, 094107 (2006) !> @author Vladimir Mironov subroutine grad_v_xc_np ( dat , xce , mythread ) use mod_dft_gridint , only : xc_der1 , xc_der2_contr class ( xc_engine_t ) :: xce type ( xc_consumer_tdg_t ) :: dat integer :: mythread integer :: i , j real ( kind = fp ) :: d_r ( 2 ), d_s ( 3 ), d_t ( 2 ) real ( kind = fp ) :: f_r ( 2 ), f_s ( 3 ), f_t ( 2 ) real ( kind = fp ) :: rhoab ( 2 ), tauab ( 2 ), sigma ( 3 ) associate ( grad_d => dat % grad_d (:,:,:, mythread ) & , grad_p => dat % grad_p (:,:,:, mythread ) & , aoG1 => xce % aoG1 & , aoV => xce % aoV & , rrho => dat % rrho (:,:,:, mythread ) & , drrho => dat % drrho (:,:,:,:, mythread ) & , rtau => dat % rtau (:,:,:, mythread ) & , drho => xce % xclib % drho & , numAOs => xce % numAOs & , numPts => xce % numPts & , nMtx => dat % nMtx & , xc => xce % XCLib & , ids => xce % XCLib % ids & ) do j = 1 , nMtx do i = 1 , numPts rhoab = rrho ( 1 , i , j ) sigma = 0 tauab = 0 if ( xce % funTyp /= OQP_FUNTYP_LDA ) then ! Compute sigma terms: ! \\nabla\\rho(D) \\dot \\nabla\\rho(P) sigma = 2 * dot_product ( drrho (:, 1 , i , j ), drho ( 1 : 3 , i )) end if if ( xce % funTyp == OQP_FUNTYP_MGGA ) tauab = rtau ( 1 , i , j ) call xc_der1 ( xce , . false ., i , d_r , d_s , d_t ) call xc_der2_contr ( xce , . false ., i , & rhoab , sigma , tauab , & f_r , f_s , f_t ) !        if (maxval(abs([dsaa,dsbb,dsab,dsba]))<xce%threshold) then !          d_s = 0 !          f_s = 0 !        end if !        if (maxval(abs(tauab))<xce%threshold) then !          d_t = 0 !          f_t = 0 !        end if grad_d ( i , 1 , 1 ) = f_r ( 1 ) grad_p ( i , 1 , 1 ) = d_r ( 1 ) if ( xce % funTyp /= OQP_FUNTYP_LDA ) then grad_d ( i , 2 : 4 , 1 ) = & ( 2 * f_s ( 1 ) + f_s ( 3 )) * drho ( 1 : 3 , i ) & + ( 2 * d_s ( 1 ) + d_s ( 3 )) * drrho (:, 1 , i , j ) grad_p ( i , 2 : 4 , 1 ) = & ( 2 * d_s ( 1 ) + d_s ( 3 )) * drho ( 1 : 3 , i ) end if if ( xce % funTyp == OQP_FUNTYP_MGGA ) then grad_d ( i , 5 , 1 ) = f_t ( 1 ) grad_p ( i , 5 , 1 ) = d_t ( 1 ) end if end do end do end associate end subroutine !> @brief Compute derivative terms of \\sum_ij V&#94;xc_ij P_ij !>  w.r.t. atomic coordinates !> @detail this subroutine update terms which should be contracted with !>  ground state (`grad_d`) and relaxed difference densities (`grad_p`) !> @note For further details see: !>  [1] F.Furche, R.Ahlrichs, J.Chem.Phys. 117, p. 7433 (2002) !>  [2] G.Scalmani et al., J.Chem.Phys. 124, 094107 (2006) !> @author Vladimir Mironov subroutine grad_v_xc ( dat , xce , mythread ) use mod_dft_gridint , only : xc_der1 , xc_der2_contr class ( xc_engine_t ) :: xce type ( xc_consumer_tdg_t ) :: dat integer :: mythread integer :: i , j real ( kind = fp ) :: d_r ( 2 ), d_s ( 3 ), d_t ( 2 ) real ( kind = fp ) :: f_r ( 2 ), f_s ( 3 ), f_t ( 2 ) real ( kind = fp ) :: rhoab ( 2 ), tauab ( 2 ), sigma ( 3 ), dsaa , dsab , dsba , dsbb associate ( grad_d => dat % grad_d (:,:,:, mythread ) & , grad_p => dat % grad_p (:,:,:, mythread ) & , aoG1 => xce % aoG1 & , aoV => xce % aoV & , rrho => dat % rrho (:,:,:, mythread ) & , drrho => dat % drrho (:,:,:,:, mythread ) & , rtau => dat % rtau (:,:,:, mythread ) & , drho => xce % xclib % drho & , numAOs => xce % numAOs & , numPts => xce % numPts & , nMtx => dat % nMtx & , xc => xce % XCLib & , ids => xce % XCLib % ids & ) do j = 1 , nMtx do i = 1 , numPts rhoab = rrho ( 1 : 2 , i , j ) sigma = 0 tauab = 0 if ( xce % funTyp /= OQP_FUNTYP_LDA ) then ! Compute sigma terms: ! \\nabla\\rho(D) \\dot \\nabla\\rho(P) dsaa = dot_product ( drrho (:, 1 , i , j ), drho ( 1 : 3 , i )) dsab = dot_product ( drrho (:, 1 , i , j ), drho ( 4 : 6 , i )) dsbb = dot_product ( drrho (:, 2 , i , j ), drho ( 4 : 6 , i )) dsba = dot_product ( drrho (:, 2 , i , j ), drho ( 1 : 3 , i )) sigma = [ 2 * dsaa , 2 * dsbb , ( dsba + dsab )] end if if ( xce % funTyp == OQP_FUNTYP_MGGA ) tauab = rtau ( 1 : 2 , i , j ) call xc_der1 ( xce , xce % hasBeta , i , d_r , d_s , d_t ) call xc_der2_contr ( xce , xce % hasBeta , i , & rhoab , sigma , tauab , & f_r , f_s , f_t ) !        if (maxval(abs([dsaa,dsbb,dsab,dsba]))<xce%threshold) then !          d_s = 0 !          f_s = 0 !        end if !        if (maxval(abs(tauab))<xce%threshold) then !          d_t = 0 !          f_t = 0 !        end if grad_d ( i , 1 , 1 ) = f_r ( 1 ) grad_p ( i , 1 , 1 ) = d_r ( 1 ) if ( xce % funTyp /= OQP_FUNTYP_LDA ) then grad_d ( i , 2 : 4 , 1 ) = & 2 * f_s ( 1 ) * drho ( 1 : 3 , i ) & + f_s ( 3 ) * drho ( 4 : 6 , i ) & + 2 * d_s ( 1 ) * drrho (:, 1 , i , j ) & + d_s ( 3 ) * drrho (:, 2 , i , j ) grad_p ( i , 2 : 4 , 1 ) = & 2 * d_s ( 1 ) * drho ( 1 : 3 , i ) & + d_s ( 3 ) * drho ( 4 : 6 , i ) end if if ( xce % funTyp == OQP_FUNTYP_MGGA ) then grad_d ( i , 5 , 1 ) = f_t ( 1 ) grad_p ( i , 5 , 1 ) = d_t ( 1 ) end if if (. not . xce % hasBeta ) cycle grad_d ( i , 1 , 2 ) = f_r ( 2 ) grad_p ( i , 1 , 2 ) = d_r ( 2 ) if ( xce % funTyp /= OQP_FUNTYP_LDA ) then grad_d ( i , 2 : 4 , 2 ) = & 2 * f_s ( 2 ) * drho ( 4 : 6 , i ) & + f_s ( 3 ) * drho ( 1 : 3 , i ) & + 2 * d_s ( 2 ) * drrho (:, 2 , i , j ) & + d_s ( 3 ) * drrho (:, 1 , i , j ) grad_p ( i , 2 : 4 , 2 ) = & 2 * d_s ( 2 ) * drho ( 4 : 6 , i ) & + d_s ( 3 ) * drho ( 1 : 3 , i ) end if if ( xce % funTyp == OQP_FUNTYP_MGGA ) then grad_d ( i , 5 , 2 ) = f_t ( 2 ) grad_p ( i , 5 , 2 ) = d_t ( 2 ) end if end do end do end associate end subroutine !> @brief Compute derivative terms of \\sum_ijkl f&#94;xc_ij,kl (X+Y)_ij (X+Y)_kl !>  w.r.t. atomic coordinates !> @detail this subroutine update terms which should be contracted with !>  ground state (`grad_d`) and transition densities (`grad_x`) !> @note For further details see: !>  [1] F.Furche, R.Ahlrichs, J.Chem.Phys. 117, p. 7433 (2002) !>  [2] G.Scalmani et al., J.Chem.Phys. 124, 094107 (2006) !> @author Vladimir Mironov subroutine grad_f_xc_np ( dat , xce , mythread ) use mod_dft_gridint , only : xc_der1 , xc_der2_contr , xc_der3_contr class ( xc_engine_t ) :: xce type ( xc_consumer_tdg_t ) :: dat integer :: mythread integer :: i , j real ( kind = fp ) :: d_r ( 2 ), d_s ( 3 ), d_t ( 2 ) real ( kind = fp ) :: f_r ( 2 ), f_s ( 3 ), f_t ( 2 ) real ( kind = fp ) :: ff_s ( 3 ), g_r ( 2 ), g_s ( 3 ), g_t ( 2 ) real ( kind = fp ) :: c ( 3 ) real ( kind = fp ) :: rhoab ( 2 ), tauab ( 2 ), sigma ( 3 ), ssigma ( 3 ) associate ( grad_d => dat % grad_d (:,:,:, mythread ) & , grad_x => dat % grad_x (:,:,:, mythread ) & , aoG1 => xce % aoG1 & , aoV => xce % aoV & , rrho => dat % rrho (:,:,:, mythread ) & , drrho => dat % drrho (:,:,:,:, mythread ) & , rtau => dat % rtau (:,:,:, mythread ) & , drho => xce % xclib % drho & , numAOs => xce % numAOs & , numPts => xce % numPts & , nMtx => dat % nMtx & , xc => xce % XCLib & , ids => xce % XCLib % ids & ) do j = 1 , nMtx do i = 1 , numPts rhoab = rrho ( 1 , i , j ) sigma = 0 ssigma = 0 tauab = 0 if ( xce % funTyp /= OQP_FUNTYP_LDA ) then ! Compute sigma terms for 3rd derivative contraction: ! \\nabla\\rho(D) \\dot \\nabla\\rho(X+Y) sigma = 2 * dot_product ( drrho (:, 1 , i , j ), drho ( 1 : 3 , i )) ! \\nabla\\rho(X+Y) \\dot \\nabla\\rho(X+Y) ssigma = 2 * dot_product ( drrho (:, 1 , i , j ), drrho (:, 1 , i , j )) end if if ( xce % funTyp == OQP_FUNTYP_MGGA ) tauab = rtau ( 1 , i , j ) call xc_der1 ( xce , . false ., i , d_r , d_s , d_t ) call xc_der2_contr ( xce , . false ., i , & rhoab , sigma , tauab , & f_r , f_s , f_t ) call xc_der3_contr ( xce , i , & rhoab , sigma , tauab , & ssigma , & ff_s , & g_r , g_s , g_t ) !        if (maxval(abs([dsaa,dsbb,dsab,dsba]))<xce%threshold) then !          f_s = 0 !          g_s = 0 !          ff_s = 0 !        end if !        if (maxval(abs(tauab))<xce%threshold) then !          f_t = 0 !          g_t = 0 !        end if grad_x ( i , 1 , 1 ) = 2 * f_r ( 1 ) grad_d ( i , 1 , 1 ) = grad_d ( i , 1 , 1 ) + g_r ( 1 ) if ( xce % funTyp /= OQP_FUNTYP_LDA ) then c = & ( 2 * f_s ( 1 ) + f_s ( 3 )) * drho ( 1 : 3 , i ) & + ( 2 * d_s ( 1 ) + d_s ( 3 )) * drrho (:, 1 , i , j ) grad_x ( i , 2 : 4 , 1 ) = 2 * c grad_d ( i , 2 : 4 , 1 ) = grad_d ( i , 2 : 4 , 1 ) & + 2 * ( 2 * f_s ( 1 ) + f_s ( 3 )) * drrho (:, 1 , i , j ) & + ( 2 * g_s ( 1 ) + g_s ( 3 )) * drho ( 1 : 3 , i ) end if if ( xce % funTyp == OQP_FUNTYP_MGGA ) then grad_x ( i , 5 , 1 ) = 2 * f_t ( 1 ) grad_d ( i , 5 , 1 ) = grad_d ( i , 5 , 1 ) + g_t ( 1 ) end if end do end do end associate end subroutine !> @brief Compute derivative terms of \\sum_ijkl f&#94;xc_ij,kl (X+Y)_ij (X+Y)_kl !>  w.r.t. atomic coordinates !> @detail this subroutine update terms which should be contracted with !>  ground state (`grad_d`) and transition densities (`grad_x`) !> @note For further details see: !>  [1] F.Furche, R.Ahlrichs, J.Chem.Phys. 117, p. 7433 (2002) !>  [2] G.Scalmani et al., J.Chem.Phys. 124, 094107 (2006) !> @author Vladimir Mironov subroutine grad_f_xc ( dat , xce , mythread ) use mod_dft_gridint , only : xc_der1 , xc_der2_contr , xc_der3_contr class ( xc_engine_t ) :: xce type ( xc_consumer_tdg_t ) :: dat integer :: mythread integer :: i , j real ( kind = fp ) :: d_r ( 2 ), d_s ( 3 ), d_t ( 2 ) real ( kind = fp ) :: f_r ( 2 ), f_s ( 3 ), f_t ( 2 ) real ( kind = fp ) :: ff_s ( 3 ), g_r ( 2 ), g_s ( 3 ), g_t ( 2 ) real ( kind = fp ) :: c ( 3 ) real ( kind = fp ) :: rhoab ( 2 ), tauab ( 2 ), sigma ( 3 ), ssigma ( 3 ), dsaa , dsab , dsba , dsbb real ( kind = fp ) :: ssaa , ssab , ssbb associate ( grad_d => dat % grad_d (:,:,:, mythread ) & , grad_x => dat % grad_x (:,:,:, mythread ) & , aoG1 => xce % aoG1 & , aoV => xce % aoV & , rrho => dat % rrho (:,:,:, mythread ) & , drrho => dat % drrho (:,:,:,:, mythread ) & , rtau => dat % rtau (:,:,:, mythread ) & , drho => xce % xclib % drho & , numAOs => xce % numAOs & , numPts => xce % numPts & , nMtx => dat % nMtx & , xc => xce % XCLib & , ids => xce % XCLib % ids & ) do j = 1 , nMtx do i = 1 , numPts rhoab = rrho ( 1 : 2 , i , j ) sigma = 0 ssigma = 0 tauab = 0 if ( xce % funTyp /= OQP_FUNTYP_LDA ) then ! Compute sigma terms for 3rd derivative contraction: ! \\nabla\\rho(D) \\dot \\nabla\\rho(X+Y) dsaa = dot_product ( drrho (:, 1 , i , j ), drho ( 1 : 3 , i )) dsab = dot_product ( drrho (:, 1 , i , j ), drho ( 4 : 6 , i )) dsbb = dot_product ( drrho (:, 2 , i , j ), drho ( 4 : 6 , i )) dsba = dot_product ( drrho (:, 2 , i , j ), drho ( 1 : 3 , i )) ! \\nabla\\rho(X+Y) \\dot \\nabla\\rho(X+Y) ssaa = dot_product ( drrho (:, 1 , i , j ), drrho (:, 1 , i , j )) ssab = dot_product ( drrho (:, 1 , i , j ), drrho (:, 2 , i , j )) ssbb = dot_product ( drrho (:, 2 , i , j ), drrho (:, 2 , i , j )) ! Compute \\sigma_aa, \\sigma_bb, \\sigma_ab for the above: sigma = [ 2 * dsaa , 2 * dsbb , ( dsab + dsba )] ssigma = [ 2 * ssaa , 2 * ssbb , 2 * ssab ] end if if ( xce % funTyp == OQP_FUNTYP_MGGA ) tauab = rtau ( 1 : 2 , i , j ) call xc_der1 ( xce , xce % hasBeta , i , d_r , d_s , d_t ) call xc_der2_contr ( xce , xce % hasBeta , i , & rhoab , sigma , tauab , & f_r , f_s , f_t ) call xc_der3_contr ( xce , i , & rhoab , sigma , tauab , & ssigma , & ff_s , & g_r , g_s , g_t ) !        if (maxval(abs([dsaa,dsbb,dsab,dsba]))<xce%threshold) then !          f_s = 0 !          g_s = 0 !          ff_s = 0 !        end if !        if (maxval(abs(tauab))<xce%threshold) then !          f_t = 0 !          g_t = 0 !        end if grad_x ( i , 1 , 1 ) = 2 * f_r ( 1 ) grad_d ( i , 1 , 1 ) = grad_d ( i , 1 , 1 ) + g_r ( 1 ) if ( xce % funTyp /= OQP_FUNTYP_LDA ) then c = & 2 * f_s ( 1 ) * drho ( 1 : 3 , i ) & + f_s ( 3 ) * drho ( 4 : 6 , i ) & + 2 * d_s ( 1 ) * drrho (:, 1 , i , j ) & + d_s ( 3 ) * drrho (:, 2 , i , j ) grad_x ( i , 2 : 4 , 1 ) = 2 * c c = & + 2 * f_s ( 1 ) * drrho (:, 1 , i , j ) & + f_s ( 3 ) * drrho (:, 2 , i , j ) grad_d ( i , 2 : 4 , 1 ) = grad_d ( i , 2 : 4 , 1 ) & + 2 * c & + 2 * g_s ( 1 ) * drho ( 1 : 3 , i ) & + g_s ( 3 ) * drho ( 4 : 6 , i ) end if if ( xce % funTyp == OQP_FUNTYP_MGGA ) then grad_x ( i , 5 , 1 ) = 2 * f_t ( 1 ) grad_d ( i , 5 , 1 ) = grad_d ( i , 5 , 1 ) + g_t ( 1 ) end if if (. not . xce % hasBeta ) cycle grad_x ( i , 1 , 2 ) = 2 * f_r ( 2 ) grad_d ( i , 1 , 2 ) = grad_d ( i , 1 , 2 ) + g_r ( 2 ) if ( xce % funTyp /= OQP_FUNTYP_LDA ) then c = & 2 * f_s ( 2 ) * drho ( 4 : 6 , i ) & + f_s ( 3 ) * drho ( 1 : 3 , i ) & + 2 * d_s ( 2 ) * drrho (:, 2 , i , j ) & + d_s ( 3 ) * drrho (:, 1 , i , j ) grad_x ( i , 2 : 4 , 2 ) = 2 * c c = & + 2 * f_s ( 2 ) * drrho (:, 2 , i , j ) & + f_s ( 3 ) * drrho (:, 1 , i , j ) grad_d ( i , 2 : 4 , 2 ) = grad_d ( i , 2 : 4 , 2 ) & + 2 * c & + 2 * g_s ( 2 ) * drho ( 4 : 6 , i ) & + g_s ( 3 ) * drho ( 1 : 3 , i ) end if if ( xce % funTyp == OQP_FUNTYP_MGGA ) then grad_x ( i , 5 , 2 ) = 2 * f_t ( 2 ) grad_d ( i , 5 , 2 ) = grad_d ( i , 5 , 2 ) + g_t ( 2 ) end if end do end do end associate end subroutine !> @brief Compute derivative XC contribution to the TD-DFT KS-like matrices !> @param[in]    basis     basis set !> @param[in]    wf        density matrix/orbitals !> @param[inout] fx        fock-like matrices !> @param[inout] dx        densities !> @param[in]    nMtx      number of density/Fock-like matrices !> @param[in]    threshold tolerance !> @param[in]    isGGA     .TRUE. if GGA/mGGA functional used !> @param[in]    infos     OQP metadata !> @author Vladimir Mironov subroutine utddft_xc_gradient ( basis , molGrid , dedft , & da , db , pa , pb , xa , xb , & nMtx , threshold , infos ) !$  use omp_lib, only: omp_get_num_threads, omp_get_thread_num use basis_tools , only : basis_set use mod_dft_gridint , only : xc_options_t , run_xc use types , only : information use mod_dft_molgrid , only : dft_grid_t implicit none type ( information ), target , intent ( in ) :: infos type ( dft_grid_t ), target , intent ( in ) :: molGrid real ( kind = fp ), intent ( out ) :: dedft (:,:) type ( basis_set ) :: basis integer , intent ( in ) :: nMtx real ( kind = fp ), intent ( inout ), contiguous , target :: da (:,:), db (:,:) real ( kind = fp ), intent ( inout ), target :: pa (:,:,:), pb (:,:,:) real ( kind = fp ), intent ( inout ), optional , target :: & xa (:,:,:), xb (:,:,:) real ( kind = fp ), intent ( in ) :: threshold type ( xc_consumer_tdg_t ) :: dat type ( xc_options_t ) :: xc_opts integer :: i , j , nbf , nxcder logical :: doFxc nbf = ubound ( da , 1 ) ! Scale densities by B.F. norms do i = 1 , nbf da (:, i ) = da (:, i ) & * basis % bfnrm ( i ) & * basis % bfnrm (:) db (:, i ) = db (:, i ) & * basis % bfnrm ( i ) & * basis % bfnrm (:) end do do j = 1 , nMtx do i = 1 , nbf pa (:, i , j ) = pa (:, i , j ) & * basis % bfnrm ( i ) & * basis % bfnrm (:) pb (:, i , j ) = pb (:, i , j ) & * basis % bfnrm ( i ) & * basis % bfnrm (:) end do end do doFxc = present ( xa ) if ( doFxc ) then do j = 1 , nMtx do i = 1 , nbf xa (:, i , j ) = xa (:, i , j ) & * basis % bfnrm ( i ) & * basis % bfnrm (:) xb (:, i , j ) = xb (:, i , j ) & * basis % bfnrm ( i ) & * basis % bfnrm (:) end do end do end if nxcder = 2 if ( doFxc ) nxcder = 3 xc_opts % isGGA = infos % functional % needGrd xc_opts % needTau = infos % functional % needTau xc_opts % hasBeta = . true . xc_opts % isWFVecs = . false . xc_opts % numAOs = nbf xc_opts % maxPts = molGrid % maxSlicePts xc_opts % limPts = molGrid % maxNRadTimesNAng xc_opts % numAtoms = infos % mol_prop % natom xc_opts % maxAngMom = basis % mxam xc_opts % functional => infos % functional xc_opts % nDer = 1 xc_opts % nXCDer = nxcder xc_opts % numOccAlpha = infos % mol_prop % nelec_A xc_opts % numOccBeta = infos % mol_prop % nelec_B xc_opts % wfAlpha => da xc_opts % wfBeta => db xc_opts % dft_threshold = threshold xc_opts % molGrid => molGrid dat % pa => pa dat % pb => pb if ( doFxc ) then dat % xa => xa dat % xb => xb end if dat % nMtx = nMtx dat % do_fxc = doFxc call dat % pe % init ( infos % mpiinfo % comm , infos % mpiinfo % usempi ) call run_xc ( xc_opts , dat , basis ) ! Scale densities back do i = 1 , nbf da (:, i ) = da (:, i ) & / basis % bfnrm ( i ) & / basis % bfnrm (:) db (:, i ) = db (:, i ) & / basis % bfnrm ( i ) & / basis % bfnrm (:) end do do j = 1 , nMtx do i = 1 , nbf pa (:, i , j ) = pa (:, i , j ) & / basis % bfnrm ( i ) & / basis % bfnrm (:) pb (:, i , j ) = pb (:, i , j ) & / basis % bfnrm ( i ) & / basis % bfnrm (:) end do end do if ( doFxc ) then do j = 1 , nMtx do i = 1 , nbf xa (:, i , j ) = xa (:, i , j ) & / basis % bfnrm ( i ) & / basis % bfnrm (:) xb (:, i , j ) = xb (:, i , j ) & / basis % bfnrm ( i ) & / basis % bfnrm (:) end do end do end if do j = 1 , basis % nshell associate ( atom => basis % origin ( j ), & offset => basis % ao_offset ( j ), & naos => basis % naos ( j )) dedft ( 1 , atom ) = dedft ( 1 , atom ) - sum ( dat % bfGrad ( offset : offset + naos - 1 , 1 , 1 )) dedft ( 2 , atom ) = dedft ( 2 , atom ) - sum ( dat % bfGrad ( offset : offset + naos - 1 , 2 , 1 )) dedft ( 3 , atom ) = dedft ( 3 , atom ) - sum ( dat % bfGrad ( offset : offset + naos - 1 , 3 , 1 )) end associate end do call dat % clean () end subroutine !------------------------------------------------------------------------------- !> @brief Compute derivative XC contribution to the TD-DFT KS-like matrices !> @param[in]    basis     basis set !> @param[in]    wf        density matrix/orbitals !> @param[inout] fx        fock-like matrices !> @param[inout] dx        densities !> @param[in]    nMtx      number of density/Fock-like matrices !> @param[in]    threshold tolerance !> @param[in]    isGGA     .TRUE. if GGA/mGGA functional used !> @param[in]    infos     OQP metadata !> @author Vladimir Mironov subroutine tddft_xc_gradient ( basis , molGrid , dedft , & da , pa , xa , & nMtx , threshold , infos ) !$  use omp_lib, only: omp_get_num_threads, omp_get_thread_num use basis_tools , only : basis_set use mod_dft_gridint , only : xc_options_t , run_xc use types , only : information use mod_dft_molgrid , only : dft_grid_t implicit none type ( information ), target , intent ( in ) :: infos type ( dft_grid_t ), target , intent ( in ) :: molGrid real ( kind = fp ), intent ( out ) :: dedft (:,:) type ( basis_set ) :: basis integer , intent ( in ) :: nMtx real ( kind = fp ), intent ( inout ), contiguous , target :: da (:,:) real ( kind = fp ), intent ( inout ), target :: pa (:,:,:) real ( kind = fp ), intent ( inout ), optional , target :: xa (:,:,:) real ( kind = fp ), intent ( in ) :: threshold type ( xc_consumer_tdg_t ) :: dat type ( xc_options_t ) :: xc_opts integer :: i , j , nbf , nxcder logical :: doFxc nbf = ubound ( da , 1 ) ! Scale densities by B.F. norms do i = 1 , nbf da (:, i ) = da (:, i ) & * basis % bfnrm ( i ) & * basis % bfnrm (:) end do do j = 1 , nMtx do i = 1 , nbf pa (:, i , j ) = pa (:, i , j ) & * basis % bfnrm ( i ) & * basis % bfnrm (:) end do end do doFxc = present ( xa ) if ( doFxc ) then do j = 1 , nMtx do i = 1 , nbf xa (:, i , j ) = xa (:, i , j ) & * basis % bfnrm ( i ) & * basis % bfnrm (:) end do end do end if nxcder = 2 if ( doFxc ) nxcder = 3 xc_opts % isGGA = infos % functional % needGrd xc_opts % needTau = infos % functional % needTau xc_opts % hasBeta = . false . xc_opts % isWFVecs = . false . xc_opts % numAOs = nbf xc_opts % maxPts = molGrid % maxSlicePts xc_opts % limPts = molGrid % maxNRadTimesNAng xc_opts % numAtoms = infos % mol_prop % natom xc_opts % maxAngMom = basis % mxam xc_opts % functional => infos % functional xc_opts % nDer = 1 xc_opts % nXCDer = nxcder xc_opts % numOccAlpha = infos % mol_prop % nelec_A xc_opts % numOccBeta = infos % mol_prop % nelec_B xc_opts % wfAlpha => da xc_opts % dft_threshold = threshold xc_opts % molGrid => molGrid dat % pa => pa if ( doFxc ) then dat % xa => xa end if dat % nMtx = nMtx dat % do_fxc = doFxc call dat % pe % init ( infos % mpiinfo % comm , infos % mpiinfo % usempi ) call run_xc ( xc_opts , dat , basis ) ! Scale densities back do i = 1 , nbf da (:, i ) = da (:, i ) & / basis % bfnrm ( i ) & / basis % bfnrm (:) end do do j = 1 , nMtx do i = 1 , nbf pa (:, i , j ) = pa (:, i , j ) & / basis % bfnrm ( i ) & / basis % bfnrm (:) end do end do if ( doFxc ) then do j = 1 , nMtx do i = 1 , nbf xa (:, i , j ) = xa (:, i , j ) & / basis % bfnrm ( i ) & / basis % bfnrm (:) end do end do end if ! Factor 2 is because only alpha contribution to gradient is computed abouve ! beta contribution is equal to alpha in RHF case do j = 1 , basis % nshell associate ( atom => basis % origin ( j ), & offset => basis % ao_offset ( j ), & naos => basis % naos ( j )) dedft ( 1 , atom ) = dedft ( 1 , atom ) - 2 * sum ( dat % bfGrad ( offset : offset + naos - 1 , 1 , 1 )) dedft ( 2 , atom ) = dedft ( 2 , atom ) - 2 * sum ( dat % bfGrad ( offset : offset + naos - 1 , 2 , 1 )) dedft ( 3 , atom ) = dedft ( 3 , atom ) - 2 * sum ( dat % bfGrad ( offset : offset + naos - 1 , 3 , 1 )) end associate end do call dat % clean () end subroutine end module mod_dft_gridint_tdxc_grad","tags":"","url":"sourcefile/dft_gridint_tdxc_grad.f90.html"},{"title":"mathlib.F90 – OpenQP Fortran API","text":"Source Code module mathlib use precision , only : dp use oqp_linalg implicit none private public orb_to_dens public traceprod_sym_packed public solve_linear_equations public symmetrize_matrix public antisymmetrize_matrix public triangular_to_full public orthogonal_transform_sym public orthogonal_transform public orthogonal_transform2 public matrix_invsqrt interface pack_matrix module procedure :: PACK_F90 , PACK_F77 end interface pack_matrix interface unpack_matrix module procedure :: UNPACK_F90 , UNPACK_F77 end interface unpack_matrix public :: pack_matrix , unpack_matrix public :: pack_f90 , unpack_f90 contains !> @brief Compute density matrix from a set of orbitals and respective occupation numbers !> @detail Compute the transformation: D = V * X * V&#94;T !> @param[out]  d   density matrix !> @param[in]   v   matrix of orbitals !> @param[in]   x   vector of occupation numbers !> @param[in]   m   number of columns in `V` !> @param[in]   n   dimension of `D` !> @param[in]   ldv leading dimension of `V` subroutine orb_to_dens ( d , v , x , m , n , ldv ) use precision , only : dp implicit none real ( kind = dp ), intent ( out ) :: d ( * ) real ( kind = dp ), intent ( in ) :: v ( ldv , * ), x ( * ) integer , intent ( in ) :: m , n , ldv real ( kind = dp ), allocatable :: d2 (:,:), tmp (:,:) integer :: n2 , i allocate ( d2 ( n , n ), tmp ( n , m )) do i = 1 , m tmp (:, i ) = v (:, i ) * x ( i ) end do call dsyr2k ( 'u' , 'n' , n , m , 0.5_dp , v , ldv , tmp , n , 0.0_dp , d2 , n ) n2 = ( n * n + n ) / 2 call pack_matrix ( d2 , d (: n2 )) end subroutine !> @brief  Compute the trace of the product of two symmetric matrices in packed format !> @detail The trace is actually an inner product of matrices, assuming they are vectors !> @param[in]  a  first matrix !> @param[in]  b  second matrix !> @param[in]  n  dimension of matrices `A` and `B` function traceprod_sym_packed ( a , b , n ) result ( res ) use precision , only : dp implicit none integer :: i , k , n , n2 real ( kind = dp ) :: res , a ( * ), b ( * ) n2 = ( n * n + n ) / 2 res = 2 * dot_product ( a (: n2 ), b (: n2 )) ! subtract the product of the diagonal elements (it is counted twice above) k = 0 do i = 1 , n k = k + i res = res - a ( k ) * b ( k ) end do end function !> @brief Compute the solution to a real system of linear equations A * X = B !> @detai Wrapper for DSYSV from Lapack !> @param[in,out] A      general matrix, destroyed on exit. !> @param[in,out] B      RHS on entry. The solution on exit. !> @param[in]     n      size of the problem. !> @param[in]     nrhs   number of RHS vectors !> @param[in]     lda    leading dimension of matrix A !> @param[out]    ierr   Error flag, ierr=0 if no errors. Read DSYEV manual for details subroutine solve_linear_equations ( a , b , n , nrhs , lda , ierr ) use precision , only : dp use messages , only : show_message implicit none integer , intent ( in ) :: lda , n , nrhs real ( dp ) :: a ( * ) real ( dp ) :: b ( * ) integer , intent ( INOUT ) :: ierr real ( dp ), allocatable :: work (:) integer , allocatable :: ipvt (:) integer :: lwork real ( dp ) :: rwork ( 1 ) integer , external :: ilaenv call dsysv ( 'U' , n , nrhs , a , lda , ipvt , b , n , rwork , - 1 , ierr ) lwork = int ( rwork ( 1 )) allocate ( work ( lwork ), ipvt ( n )) call dsysv ( 'U' , n , nrhs , a , lda , ipvt , b , n , work , lwork , ierr ) deallocate ( work , ipvt ) if ( ierr /= 0 ) then call show_message ( 'DSYSV FAILED' ) end if end subroutine !> @brief Compute `A = A + A&#94;T` of a square matrix !> @param[inout] a  square NxN matrix !> @param[in]    n  matrix dimension subroutine symmetrize_matrix ( a , n ) use precision , only : dp real ( kind = dp ), intent ( inout ) :: a ( n , * ) integer , intent ( in ) :: n integer :: i do i = 1 , n a ( i : n , i ) = a ( i : n , i ) + a ( i , i : n ) a ( 1 : i - 1 , i ) = a ( i , 1 : i - 1 ) end do end subroutine symmetrize_matrix !> @brief Compute `A = A - A&#94;T` of a square matrix !> @param[inout] a  square NxN matrix !> @param[in]    n  matrix dimension subroutine antisymmetrize_matrix ( a , n ) use precision , only : dp real ( kind = dp ), intent ( inout ) :: a ( n , * ) integer , intent ( in ) :: n integer :: i do i = 1 , n a ( i : n , i ) = a ( i : n , i ) - a ( i , i : n ) a ( 1 : i - 1 , i ) = - a ( i , 1 : i - 1 ) end do end subroutine !> @brief Fill the upper/lower triangle of the symmetric matrix !         in triangular form !> @param[inout] a     square NxN matrix in triangular form !> @param[in]    n     matrix dimension !> @param[in]    uplo  U if `A` is upper triangular, L if lower triangular subroutine triangular_to_full ( a , n , uplo ) use precision , only : dp use messages , only : show_message , with_abort implicit none real ( kind = dp ), intent ( inout ) :: a ( n , * ) integer , intent ( in ) :: n character ( len = 1 ), intent ( in ) :: uplo integer :: i if ( uplo == 'u' . or . uplo == 'U' ) then do i = 1 , n a ( i + 1 : n , i ) = a ( i , i + 1 : n ) end do else if ( uplo == 'l' . or . uplo == 'L' ) then do i = 1 , n a ( i , i + 1 : n ) = a ( i + 1 : n , i ) end do else call show_message ( 'Invalid parameter UPLO=' // uplo // & ' in `triangular_to_full`. Use either `L` or `U`.' , with_abort ) end if end subroutine triangular_to_full !> @brief Compute orthogonal transformation of a symmetric marix A !>        in packed format: !>        B = U&#94;T * A * U !> @param[in]    a      Matrix to transform !> @param[in]    u      Orthogonal matrix U(ldu,m) !> @param[in]    n      dimension of matrix A !> @param[in]    m      dimension of matrix B !> @param[in]    ldu    leading dimension of matrix U !> @param[out]   b      Result !> @param[inout] wrk    Scratch space !> @author Vladimir Mironov subroutine orthogonal_transform_sym ( n , m , a , u , ldu , b ) use messages , only : show_message , with_abort implicit none integer , intent ( in ) :: n , m , ldu real ( kind = 8 ), intent ( in ) :: a ( * ) real ( kind = 8 ), intent ( in ) :: u ( n , * ) real ( kind = 8 ), intent ( out ) :: b ( * ) real ( kind = 8 ), allocatable :: tmp (:,:), a2 (:,:) integer :: info ! Allocate workspace array allocate ( a2 ( n , n ), tmp ( n , m ), stat = info ) if ( info /= 0 ) then call show_message ( 'Cannot allocate memory' , WITH_ABORT ) end if ! Unpack the symmetric matrix A call dtpttr ( 'u' , n , a , a2 , n , info ) if ( info /= 0 ) then call show_message ( '(A,I8)' , & 'Error: DTPTTR returned info =' , info , WITH_ABORT ) end if ! Compute A * U call dsymm ( 'l' , 'u' , n , m , 1.0d0 , a2 , n , u , ldu , 0.0d0 , tmp , n ) ! Compute symmetric matrix B = U&#94;T * (A * U) call dgemm ( 't' , 'n' , m , m , n , 1.0d0 , u , ldu , tmp , n , 0.0d0 , a2 , n ) ! Pack the symmetric matrix B call dtrttp ( 'u' , m , a2 , n , b , info ) if ( info /= 0 ) then call show_message ( '(A,I8)' , & 'Error: DTRTTP returned info =' , info , WITH_ABORT ) end if end subroutine !> @brief Compute orthogonal transformation of a square marix !> @param[in]    trans  If trans='n' compute B = U&#94;T * A * U !>                      If trans='t' compute B = U * A * U&#94;T !> @param[in]    ld     Dimension of matrices !> @param[in]    u      Square orthogonal matrix !> @param[inout] a      Matrix to transform, optionally output matrix !> @param[out]   b      Result, can be absent for in-place transform of matrix A !> @param[inout] wrk    Scratch space, optional !> @author Vladimir Mironov subroutine orthogonal_transform ( trans , ld , u , a , b , wrk ) use messages , only : show_message , with_abort implicit none character ( len = 1 ), intent ( in ) :: trans integer :: ld real ( kind = dp ), intent ( in ) :: u ( * ) real ( kind = dp ), intent ( in ) :: a ( * ) real ( kind = dp ), optional , intent ( out ) :: b ( * ) real ( kind = dp ), optional , target , intent ( inout ) :: wrk ( * ) real ( kind = dp ), pointer :: pwrk (:) real ( kind = dp ), allocatable , target :: wrk_internal (:) if ( present ( wrk )) then pwrk ( 1 : ld * ld ) => wrk ( 1 : ld * ld ) else allocate ( wrk_internal ( ld * ld )) pwrk ( 1 : ld * ld ) => wrk_internal ( 1 : ld * ld ) end if select case ( trans ) case ( 'n' , 'N' ) call dgemm ( 'n' , 'n' , ld , ld , ld , & 1.0_dp , a , ld , & u , ld , & 0.0_dp , pwrk , ld ) if ( present ( b )) then call dgemm ( 't' , 'n' , ld , ld , ld , & 1.0_dp , u , ld , & pwrk , ld , & 0.0_dp , b , ld ) else call dgemm ( 't' , 'n' , ld , ld , ld , & 1.0_dp , u , ld , & pwrk , ld , & 0.0_dp , a , ld ) end if case ( 't' , 'T' ) call dgemm ( 'n' , 'n' , ld , ld , ld , & 1.0_dp , u , ld , & a , ld , & 0.0_dp , pwrk , ld ) if ( present ( b )) then call dgemm ( 'n' , 't' , ld , ld , ld , & 1.0_dp , pwrk , ld , & u , ld , & 0.0_dp , b , ld ) else call dgemm ( 'n' , 't' , ld , ld , ld , & 1.0_dp , pwrk , ld , & u , ld , & 0.0_dp , a , ld ) end if case default call show_message ( 'Invalid parameter TRANS=' // trans // & ' in `orthogonal_transform`' , with_abort ) end select end subroutine !> @brief Compute orthogonal transformation of a square marix !> @param[in]    trans  If trans='n' compute B = U&#94;T * A * U !>                      If trans='t' compute B = U * A * U&#94;T !> @param[in]    ld     Dimension of matrices !> @param[in]    u      Square orthogonal matrix !> @param[in]    a      Matrix to transform !> @param[out]   b      Result !> @param[inout] wrk    Scratch space !> @author Vladimir Mironov subroutine orthogonal_transform2 ( trans , m , n , u , ldu , a , lda , b , ldb , wrk ) use messages , only : show_message , with_abort implicit none character ( len = 1 ), intent ( in ) :: trans integer :: m , n , ldu , lda , ldb real ( kind = dp ), intent ( in ) :: u ( * ) real ( kind = dp ), intent ( in ) :: a ( * ) real ( kind = dp ), intent ( out ) :: b ( * ) real ( kind = dp ), intent ( inout ) :: wrk ( * ) select case ( trans ) case ( 'n' , 'N' ) call dgemm ( 'n' , 'n' , m , n , m , & 1.0_dp , a , lda , & u , ldu , & 0.0_dp , wrk , n ) call dgemm ( 't' , 'n' , n , n , m , & 1.0_dp , u , ldu , & wrk , n , & 0.0_dp , b , ldb ) case ( 't' , 'T' ) call dgemm ( 'n' , 'n' , m , n , n , & 1.0_dp , u , ldu , & a , lda , & 0.0_dp , wrk , n ) call dgemm ( 'n' , 't' , m , m , n , & 1.0_dp , wrk , n , & u , ldu , & 0.0_dp , b , ldb ) case default call show_message ( 'Invalid parameter TRANS=' // trans // & ' in `orthogonal_transform`' , with_abort ) end select end subroutine !> @brief Compute matrix inverse square root using SVD and removing !>  linear dependency ! !> @detail This subroutine is used to obtain set of `canonical orbitals` !>   by diagonalization of the basis set overlap matrix !>   Q = S&#94;{-1/2}, Q&#94;T * S * Q = I ! !> @param[in]   s    Overlap matrix, symmetric packed format !> @param[out]  q    Matrix inverse square root, square matrix !> @param[in]   nbf  Dimeension of matrices S and Q, basis set size !> @param[out]  qrnk Rank of matrix Q !> @param[in]   tol  optional, tolerance to remove linear dependency, !>                   default = 1.0e-8 subroutine matrix_invsqrt ( s , q , nbf , qrnk , tol ) use messages , only : show_message , with_abort use eigen , only : diag_symm_full implicit none real ( kind = dp ), intent ( in ) :: s ( * ) real ( kind = dp ), intent ( out ) :: q ( nbf , * ) integer , intent ( in ) :: nbf real ( kind = dp ), optional , intent ( in ) :: tol integer , optional , intent ( out ) :: qrnk real ( kind = dp ), parameter :: deftol = 1.0d-08 real ( kind = dp ), allocatable :: eig (:) real ( kind = dp ) :: rtol integer :: ok , i , j rtol = deftol if ( present ( tol )) rtol = tol allocate ( eig ( nbf ), stat = ok ) if ( ok /= 0 ) call show_message ( 'Cannot allocate memory' , WITH_ABORT ) !   Unpack S into Q and diagonalize in full storage: !   the blocked full-storage driver is much faster than the !   packed-storage one, which cannot use level-3 BLAS. call unpack_matrix ( s , q (:, 1 : nbf )) call diag_symm_full ( 1 , nbf , q , nbf , eig ) !   Compute Q = S&#94;{-1/2}, eliminating eigenvectors corresponding !   to small eigenvalues j = 0 do i = 1 , nbf if ( eig ( i ) >= rtol ) then j = j + 1 q (:, j ) = q (:, i ) / sqrt ( eig ( i )) end if end do q (:, j + 1 : nbf ) = 0 if ( present ( qrnk )) qrnk = j end subroutine matrix_invsqrt !> @brief Fortran-90 routine for packing symmetric matrix to 1D array !> !> @date      6 October 2021   - Initial release - !> @author    Igor S. Gerasimov !> !> @param[in]          A    - matrix for packing (N x N) !> @param[out]         AP   - packed matrix ( N*(N+1)/2 ) !> @param[in,optional] UPLO - format of packed matrix, `U` for upper and `L` for lower subroutine PACK_F90 ( A , AP , UPLO ) real ( dp ), intent ( IN ) :: A (:, :) real ( dp ), intent ( OUT ) :: AP (:) character ( len = 1 ), intent ( in ), optional :: UPLO character ( len = 1 ) :: DUPLO if (. not . present ( UPLO )) then DUPLO = 'U' else DUPLO = UPLO end if call PACK_F77 ( A , size ( A , 1 ), AP , DUPLO ) end subroutine PACK_F90 !> @brief Fortran-77 routine for packing symmetric matrix to 1D array !> !> @date      6 October 2021   - Initial release - !> @author    Igor S. Gerasimov !> !> @param[in]          A    - matrix for packing (N x N) !> @param[in]          N    - shape of matrix A !> @param[out]         AP   - packed matrix ( N*(N+1)/2 ) !> @param[in]          UPLO - format of packed matrix, `U` for upper and `L` for lower subroutine PACK_F77 ( A , N , AP , UPLO ) bind ( C , name = \"MTX_PACK\" ) use messages , only : show_message , WITH_ABORT real ( dp ), intent ( in ) :: A ( N , * ) integer , intent ( in ) :: N real ( dp ), intent ( out ) :: AP ( * ) character ( len = 1 ), intent ( in ) :: UPLO integer :: INFO call dtrttp ( uplo , n , a , n , ap , info ) if ( info /= 0 ) then call show_message ( \"error in pack procedure. please, check arguments\" , with_abort ) end if end subroutine PACK_F77 !> @brief Fortran-90 routine for unpacking 1D array to symmetric matrix !> !> @details   LAPACK returns only upper or lower filling of matrix !<              so then matrix is symmetrised by couple of cycles !> !> @date      6 October 2021   - Initial release - !> @author    Igor S. Gerasimov !> !> @param[in]          AP   - packed matrix (N x N) !> @param[out]         A    - matrix for unpacking ( N*(N+1)/2 ) !> @param[in,optional] UPLO - format of packed matrix, `U` for upper and `L` for lower subroutine UNPACK_F90 ( AP , A , UPLO ) real ( dp ), intent ( IN ) :: AP ( * ) real ( dp ), intent ( OUT ) :: A (:, :) character ( len = 1 ), intent ( in ), optional :: UPLO character ( len = 1 ) :: DUPLO if (. not . present ( UPLO )) then DUPLO = 'U' else DUPLO = UPLO end if call UNPACK_F77 ( AP , A , size ( A , 1 ), DUPLO ) end subroutine UNPACK_F90 !> @brief Fortran-77 routine for unpacking 1D array to symmetric matrix !> !> @details   LAPACK returns only upper or lower filling of matrix !<              so then matrix is symmetrised by couple of cycles !> !> @date      6 October 2021   - Initial release - !> @author    Igor S. Gerasimov !> !> @param[in]          AP   - packed matrix !> @param[out]         A    - matrix for unpacking (N x N) !> @param[in]          N    - shape of matrix A !> @param[in]          UPLO - format of packed matrix, `U` for upper and `L` for lower subroutine UNPACK_F77 ( AP , A , N , UPLO ) bind ( C , name = \"MTX_UNPACK\" ) use messages , only : show_message , WITH_ABORT real ( dp ), intent ( in ) :: AP ( * ) real ( dp ), intent ( out ) :: A ( N , * ) integer , intent ( in ) :: N character ( len = 1 ), intent ( in ) :: UPLO integer :: info , i call dtpttr ( uplo , n , ap , a , n , info ) if ( INFO /= 0 ) then call show_message ( \"Error in PACK procedure. Please, check arguments\" , WITH_ABORT ) end if if ( UPLO == 'u' . or . UPLO == 'U' ) then do i = 1 , N A ( i + 1 : N , i ) = A ( i , i + 1 : N ) end do else if ( UPLO == 'l' . or . UPLO == 'L' ) then do i = 1 , N A ( i , i + 1 : N ) = A ( i + 1 : N , i ) end do else call show_message ( \"UNPACK_F77: UPLO can have only `l`, `L`, `u` or `U` value\" , WITH_ABORT ) end if end subroutine UNPACK_F77 end module","tags":"","url":"sourcefile/mathlib.f90.html"},{"title":"grd2.F90 – OpenQP Fortran API","text":"Source Code module grd2 !############################################################################### use precision , only : dp use constants , only : tol_int use io_constants , only : iw use basis_tools , only : basis_set use grd2_rys , only : grd2_int_data_t , grd2_rys_compute , grd2_rys_hess_compute use constants , only : BAS_MXANG use int2_compute , only : int2_compute_data_t , ints_exchange !############################################################################### implicit none !############################################################################### character ( len =* ), parameter :: module_name = \"grd2\" !############################################################################### character ( 1 ), parameter :: bfchars ( 0 : 6 ) = [ 'S' , 'P' , 'D' , 'F' , 'G' , 'H' , 'I' ] !############################################################################### type , abstract :: grd2_compute_data_t logical :: attenuated = . false . real ( kind = dp ) :: mu = 1.0d99 real ( kind = dp ) :: hfscale = 1.0d0 real ( kind = dp ) :: hfscale2 = 1.0d0 ! can be used in Responce calculations real ( kind = dp ) :: coulscale = 1.0d0 integer :: cur_pass = 1 contains procedure ( grd2_compute_data_t_init ), deferred , pass :: init procedure ( grd2_compute_data_t_clean ), deferred , pass :: clean procedure ( grd2_compute_data_t_get_density ), deferred , pass :: get_density end type !############################################################################### abstract interface subroutine grd2_compute_data_t_init ( this ) import implicit none class ( grd2_compute_data_t ), target , intent ( inout ) :: this end subroutine subroutine grd2_compute_data_t_clean ( this ) import implicit none class ( grd2_compute_data_t ), target , intent ( inout ) :: this end subroutine subroutine grd2_compute_data_t_get_density ( this , basis , id , dab , dabmax ) import implicit none class ( grd2_compute_data_t ), target , intent ( inout ) :: this type ( basis_set ), intent ( in ) :: basis integer , intent ( in ) :: id ( 4 ) real ( kind = dp ), target , intent ( out ) :: dab ( * ) real ( kind = dp ), intent ( out ) :: dabmax end subroutine end interface private public :: grd2_driver public :: grd2_hess_driver public :: grd2_compute_data_t !############################################################################### contains !> @brief The driver for the two electron gradient subroutine grd2_driver ( infos , basis , de , gcomp , & cam , alpha , beta , mu ) use types , only : information use basis_tools , only : basis_set implicit none type ( information ), target , intent ( inout ) :: infos type ( basis_set ), intent ( in ) :: basis real ( kind = dp ), intent ( inout ) :: de (:,:) class ( grd2_compute_data_t ), intent ( inout ) :: gcomp logical , optional , intent ( in ) :: cam real ( kind = dp ), optional , intent ( in ) :: alpha , beta , mu real ( kind = dp ), allocatable :: de_internal (:,:) logical :: do_cam = . false . do_cam = infos % dft % cam_flag if ( present ( cam )) do_cam = cam if ( do_cam ) then allocate ( de_internal , mold = de ) gcomp % cur_pass = 1 ! Regular Coulomb and exchange de_internal = 0 gcomp % attenuated = . false . gcomp % coulscale = 1.0d0 gcomp % hfscale = infos % dft % cam_alpha gcomp % hfscale2 = infos % tddft % cam_alpha if ( present ( alpha )) gcomp % hfscale2 = alpha call grd2_driver_gen ( infos , basis , de_internal , gcomp ) de = de + de_internal gcomp % cur_pass = 2 ! Short-range exchange: de_internal = 0 gcomp % attenuated = . true . gcomp % coulscale = 0.0d0 gcomp % hfscale = infos % dft % cam_beta gcomp % hfscale2 = infos % tddft % cam_beta if ( present ( beta )) gcomp % hfscale2 = beta gcomp % mu = infos % dft % cam_mu if ( present ( mu )) gcomp % mu = mu call grd2_driver_gen ( infos , basis , de_internal , gcomp ) de = de + de_internal else ! Only adopt the DFT hybrid mixing here for actual DFT calculations ! (hamilton>=20).  For pure Hartree-Fock the caller already set the ! correct hfscale (=1.0); infos%dft%hfscale is not meaningful in that ! case (it is left at its -1.0 sentinel) and must not clobber it. if ( infos % control % hamilton >= 20 ) then gcomp % hfscale = infos % dft % hfscale gcomp % hfscale2 = infos % tddft % hfscale end if call grd2_driver_gen ( infos , basis , de , gcomp ) end if end subroutine !> @brief The driver for the two electron gradient subroutine grd2_driver_gen ( infos , basis , de , gcomp ) use util , only : measure_time use messages , only : show_message , WITH_ABORT use types , only : information use mod_dft_molgrid , only : dft_grid_t use int2_pairs , only : int2_pair_storage , int2_cutoffs_t use int2_compute , only : petite_quartet_weight , load_petite_shell_map use oqp_tagarray_driver use parallel , only : par_env_t implicit none character ( len =* ), parameter :: subroutine_name = \"grd2_driver_gen\" type ( information ), target , intent ( inout ) :: infos type ( basis_set ), intent ( in ) :: basis class ( grd2_compute_data_t ), intent ( inout ) :: gcomp real ( kind = dp ), intent ( inout ) :: de (:,:) real ( dp ), dimension (:), allocatable :: dab real ( dp ), allocatable :: schwarz_ints (:,:) real ( kind = dp ) :: emu2 real ( kind = dp ) :: cutoff , cutoff2 , dabcut real ( kind = dp ) :: dabmax , gmax real ( kind = dp ) :: zbig integer :: numint , i , ij , skip1 , skip2 , mpi_ij integer :: iok , j , k , l , kl integer :: maxnbf , maxl integer :: q4 , sym_nops integer ( 8 ), contiguous , pointer :: sym_map (:) real ( kind = dp ) :: rtol , dtol character ( len = 64 ) :: sval integer :: ln logical :: lstats type ( grd2_int_data_t ) :: gdat type ( int2_pair_storage ) :: ppairs type ( int2_cutoffs_t ) :: cutoffs ! tagarray integer ( 4 ) :: status type ( par_env_t ) :: pe call pe % init ( infos % mpiinfo % comm , infos % mpiinfo % usempi ) if ( gcomp % attenuated ) then emu2 = gcomp % mu ** 2 end if !    `cutoff` is the Schwarz screening cutoff !    `dabcut` is the two particle density cutoff ! !   The gradient is evaluated at the CONVERGED density, so the derivative-ERI !   screening may be loosened relative to the SCF Fock build without changing !   the converged gradient beyond a controllable tolerance.  Opt-in, default-OFF !   (env unset => byte-identical to the historic 1.0d-10): !     OQP_GRAD_CUTOFF - Schwarz block cutoff (default 1.0d-10).  1.0d-8 is the !                       size-robust opt-in (max|dG| <= ~1e-6 a.u. through the !                       36-atom systems tested).  1.0d-7 is more aggressive but !                       max|dG| GROWS with system size and exceeds 1e-5 past !                       ~18-atom HF (DFT/MRSF, HF-exchange scale <=0.5, tolerate !                       it to larger sizes).  Looser still is unsafe: derivative !                       integrals amplify the dropped contributions.  See !                       GRAD_SCREENING_NOTES.md for the per-size/method table. ! Schwarz block cutoff for the 2e-derivative build, from [scf] grad_cutoff ! (infos%control%grad_cutoff; default 1.0d-10 = historic exact baseline). cutoff = infos % control % grad_cutoff if ( cutoff <= 0.0_dp ) cutoff = 1.0d-10 cutoff2 = cutoff / 2.0d+00 zbig = maxval ( basis % ex ) dabcut = 1.0d-11 if ( zbig > 1.0d+06 ) dabcut = dabcut / 10 if ( zbig > 1.0d+07 ) dabcut = dabcut / 10 dtol = 1 0.0d0 ** ( - tol_int ) rtol = log ( 1 0.0_dp ) * tol_int !   Opt-in screening diagnostics (auto-enabled when the lever is active). lstats = ( cutoff /= 1.0d-10 ) call get_environment_variable ( \"OQP_GRAD_STATS\" , sval , ln ) if ( ln > 0 ) lstats = ( sval ( 1 : 1 ) == '1' . or . sval ( 1 : 1 ) == 'y' . or . sval ( 1 : 1 ) == 'Y' & . or . sval ( 1 : 1 ) == 't' . or . sval ( 1 : 1 ) == 'T' ) call cutoffs % set (& cutoff_integral_value = dabcut ,& cutoff_exp = rtol , & cutoff_prefactor_pq = dtol , & cutoff_prefactor_p = dtol ) call ppairs % alloc ( basis , cutoffs ) call ppairs % compute ( basis , cutoffs ) ! integrals for screening allocate ( schwarz_ints ( basis % nshell , basis % nshell )) if ( gcomp % attenuated ) then call ints_exchange ( basis , schwarz_ints , emu2 ) else call ints_exchange ( basis , schwarz_ints ) end if !   Initialize the integral block counters to zero skip1 = 0 skip2 = 0 numint = 0 !   Optional symmetry petite list (valid: the gradient is linear in the !   quartets and the SCF density is totally symmetric). call load_petite_shell_map ( infos , basis % nshell , sym_map , sym_nops ) !   Check maximum angular momentum if ( basis % mxam > BAS_MXANG ) then call show_message ( 'gradient integrals programmed up to ' & // bfchars ( BAS_MXANG - 1 ) // ' functions' , with_abort ) end if !   Calculate the largest shell type maxnbf = ( basis % mxam + 1 ) * ( basis % mxam + 2 ) / 2 !   Square dtol for use in grd2_rys_compute dtol = dtol * dtol !$omp parallel & !$omp   private ( & !$omp   gdat, dab, i, j, k, l, ij, maxl, kl, gmax, dabmax, iok, mpi_ij, q4) & !$omp   reduction(+:skip1, skip2, numint, de) allocate ( dab ( maxnbf ** 4 )) call gdat % init ( basis % mxam , 1 , dtol , dabcut , iok ) !$omp barrier if ( infos % mpiinfo % usempi ) then mpi_ij = 0 end if do i = 1 , basis % nshell do j = 1 , i ij = i * ( i - 1 ) / 2 + j if ( ppairs % ppid ( 1 , ij ) == 0 ) cycle if ( infos % mpiinfo % usempi ) then mpi_ij = mpi_ij + 1 if ( mod ( mpi_ij , pe % size ) /= pe % rank ) cycle end if !$omp do schedule(dynamic,4) collapse(2) do k = 1 , i do l = 1 , i maxl = k if ( k == i ) maxl = j if ( l > maxl ) cycle kl = k * ( k - 1 ) / 2 + l if ( ppairs % ppid ( 1 , kl ) == 0 ) cycle gmax = schwarz_ints ( i , j ) * schwarz_ints ( k , l ) !           Coarse screening, on just the integral value if ( gmax < cutoff ) then skip1 = skip1 + 1 cycle end if !           Select centers for derivatives call gdat % set_ids ( basis , i , j , k , l ) if ( all ( gdat % skip (:))) cycle !           Petite list: keep only the orbit representative; the skeleton !           gradient is symmetrized (projected) afterwards in pyoqp. if ( sym_nops > 1 ) then q4 = petite_quartet_weight ( sym_map , sym_nops , basis % nshell , i , j , k , l ) if ( q4 == 0 ) cycle else q4 = 1 end if !           Obtain 2 body density for this shell block call gcomp % get_density ( basis , gdat % id , dab , dabmax ) !           Fine screening on the weighted contribution (see int2_twoei). if ( dabmax * gmax * real ( q4 , dp ) < cutoff2 ) then skip2 = skip2 + 1 cycle end if !           Evaluate derivative integral, and add to the gradient numint = numint + 1 if ( gcomp % attenuated ) then call grd2_rys_compute ( gdat , ppairs , dab , dabmax , emu2 ) else call grd2_rys_compute ( gdat , ppairs , dab , dabmax ) end if de (:, gdat % at ) = de (:, gdat % at ) + real ( q4 , dp ) * gdat % fd end do end do !$omp end do end do end do call gdat % clean () !$omp end parallel call pe % allreduce ( skip1 , 1 ) call pe % allreduce ( skip2 , 1 ) call pe % allreduce ( numint , 1 ) call pe % allreduce ( de , size ( de )) !   Finish up the final gradient !   Project rotational contaminant from gradients !   call dfinal(1) if ( lstats ) then write ( iw , fmt = \"(& &/1X,'[grd2] screening: cutoff=',ES9.2,'  pass=',I1,& &/1X,'[grd2] blocks coarse/fine skipped ',I12,'/',I12,& &'  computed ',I12)\" ) & cutoff , gcomp % cur_pass , skip1 , skip2 , numint end if end subroutine grd2_driver_gen !############################################################################### !> @brief Driver for the analytic two-electron contribution to the Hessian !>        (skeleton/Hellmann-Feynman part: derivatives of the ERIs contracted !>        with a fixed two-body density). Mirrors grd2_driver_gen but builds the !>        per-quartet second-derivative block fd2(3,4,3,4) and scatters it into !>        the (3*natom,3*natom) Hessian by atom pair. recursive subroutine grd2_hess_driver ( infos , basis , hess , gcomp , & cam , alpha , beta , mu ) use util , only : measure_time use messages , only : show_message , WITH_ABORT use types , only : information use int2_pairs , only : int2_pair_storage , int2_cutoffs_t use parallel , only : par_env_t implicit none type ( information ), target , intent ( inout ) :: infos type ( basis_set ), intent ( in ) :: basis class ( grd2_compute_data_t ), intent ( inout ) :: gcomp real ( kind = dp ), intent ( inout ) :: hess (:,:) logical , optional , intent ( in ) :: cam real ( kind = dp ), optional , intent ( in ) :: alpha , beta , mu real ( dp ), dimension (:), allocatable :: dab real ( dp ), allocatable :: schwarz_ints (:,:) real ( kind = dp ), allocatable :: hess_internal (:,:) real ( kind = dp ) :: emu2 real ( kind = dp ) :: cutoff , cutoff2 , dabcut real ( kind = dp ) :: dabmax , gmax real ( kind = dp ) :: zbig integer :: numint , i , ij , skip1 , skip2 , mpi_ij integer :: iok , j , k , l , kl integer :: maxnbf , maxl integer :: c1 , c2 , a1 , a2 , r0 , c0 real ( kind = dp ) :: rtol , dtol type ( grd2_int_data_t ) :: gdat type ( int2_pair_storage ) :: ppairs type ( int2_cutoffs_t ) :: cutoffs type ( par_env_t ) :: pe logical :: do_cam = . false . do_cam = infos % dft % cam_flag if ( present ( cam )) do_cam = cam if ( do_cam ) then allocate ( hess_internal , mold = hess ) gcomp % cur_pass = 1 ! Regular Coulomb and exchange. hess_internal = 0.0_dp gcomp % attenuated = . false . gcomp % coulscale = 1.0_dp gcomp % hfscale = infos % dft % cam_alpha gcomp % hfscale2 = infos % tddft % cam_alpha if ( present ( alpha )) gcomp % hfscale2 = alpha call grd2_hess_driver ( infos , basis , hess_internal , gcomp , cam = . false .) hess = hess + hess_internal gcomp % cur_pass = 2 ! Short-range exchange. hess_internal = 0.0_dp gcomp % attenuated = . true . gcomp % coulscale = 0.0_dp gcomp % hfscale = infos % dft % cam_beta gcomp % hfscale2 = infos % tddft % cam_beta if ( present ( beta )) gcomp % hfscale2 = beta gcomp % mu = infos % dft % cam_mu if ( present ( mu )) gcomp % mu = mu call grd2_hess_driver ( infos , basis , hess_internal , gcomp , cam = . false .) hess = hess + hess_internal deallocate ( hess_internal ) return end if call pe % init ( infos % mpiinfo % comm , infos % mpiinfo % usempi ) if ( infos % control % hamilton >= 20 . and . . not . present ( cam )) then gcomp % hfscale = infos % dft % hfscale gcomp % hfscale2 = infos % tddft % hfscale end if if ( gcomp % attenuated ) emu2 = gcomp % mu ** 2 cutoff = 1.0d-10 cutoff2 = cutoff / 2.0d+00 zbig = maxval ( basis % ex ) dabcut = 1.0d-11 if ( zbig > 1.0d+06 ) dabcut = dabcut / 10 if ( zbig > 1.0d+07 ) dabcut = dabcut / 10 dtol = 1 0.0d0 ** ( - tol_int ) rtol = log ( 1 0.0_dp ) * tol_int call cutoffs % set (& cutoff_integral_value = dabcut ,& cutoff_exp = rtol , & cutoff_prefactor_pq = dtol , & cutoff_prefactor_p = dtol ) call ppairs % alloc ( basis , cutoffs ) call ppairs % compute ( basis , cutoffs ) allocate ( schwarz_ints ( basis % nshell , basis % nshell )) if ( gcomp % attenuated ) then call ints_exchange ( basis , schwarz_ints , emu2 ) else call ints_exchange ( basis , schwarz_ints ) end if skip1 = 0 skip2 = 0 numint = 0 if ( basis % mxam > BAS_MXANG ) then call show_message ( 'hessian integrals programmed up to ' & // bfchars ( BAS_MXANG - 1 ) // ' functions' , with_abort ) end if maxnbf = ( basis % mxam + 1 ) * ( basis % mxam + 2 ) / 2 dtol = dtol * dtol !$omp parallel & !$omp   private ( & !$omp   gdat, dab, i, j, k, l, ij, maxl, kl, gmax, dabmax, iok, mpi_ij, & !$omp   c1, c2, a1, a2, r0, c0) & !$omp   reduction(+:skip1, skip2, numint, hess) allocate ( dab ( maxnbf ** 4 )) call gdat % init ( basis % mxam , 2 , dtol , dabcut , iok ) !$omp barrier if ( infos % mpiinfo % usempi ) then mpi_ij = 0 end if do i = 1 , basis % nshell do j = 1 , i ij = i * ( i - 1 ) / 2 + j if ( ppairs % ppid ( 1 , ij ) == 0 ) cycle if ( infos % mpiinfo % usempi ) then mpi_ij = mpi_ij + 1 if ( mod ( mpi_ij , pe % size ) /= pe % rank ) cycle end if !$omp do schedule(dynamic,4) collapse(2) do k = 1 , i do l = 1 , i maxl = k if ( k == i ) maxl = j if ( l > maxl ) cycle kl = k * ( k - 1 ) / 2 + l if ( ppairs % ppid ( 1 , kl ) == 0 ) cycle gmax = schwarz_ints ( i , j ) * schwarz_ints ( k , l ) if ( gmax < cutoff ) then skip1 = skip1 + 1 cycle end if call gdat % set_ids ( basis , i , j , k , l ) ! All four centers on the same atom -> zero contribution if ( all ( gdat % skip (:))) cycle ! Differentiate all four centers explicitly (no TI recovery) gdat % skip = . false . call gcomp % get_density ( basis , gdat % id , dab , dabmax ) if ( dabmax * gmax < cutoff2 ) then skip2 = skip2 + 1 cycle end if numint = numint + 1 if ( gcomp % attenuated ) then call grd2_rys_hess_compute ( gdat , ppairs , dab , dabmax , emu2 ) else call grd2_rys_hess_compute ( gdat , ppairs , dab , dabmax ) end if ! Scatter fd2(a1,c1,a2,c2) into the atom-pair Hessian blocks do c1 = 1 , 4 r0 = 3 * ( gdat % at ( c1 ) - 1 ) do c2 = 1 , 4 c0 = 3 * ( gdat % at ( c2 ) - 1 ) do a1 = 1 , 3 do a2 = 1 , 3 hess ( r0 + a1 , c0 + a2 ) = hess ( r0 + a1 , c0 + a2 ) & + gdat % fd2 ( a1 , c1 , a2 , c2 ) end do end do end do end do end do end do !$omp end do end do end do call gdat % clean () !$omp end parallel call pe % allreduce ( skip1 , 1 ) call pe % allreduce ( skip2 , 1 ) call pe % allreduce ( numint , 1 ) call pe % allreduce ( hess , size ( hess )) end subroutine grd2_hess_driver !############################################################################### end module grd2","tags":"","url":"sourcefile/grd2.f90.html"},{"title":"guess_sap.F90 – OpenQP Fortran API","text":"Source Code module guess_sap_mod implicit none character ( len =* ), parameter :: module_name = \"guess_sap_mod\" contains subroutine guess_sap_C ( c_handle ) bind ( C , name = \"guess_sap\" ) use c_interop , only : oqp_handle_t , oqp_handle_get_info use types , only : information type ( oqp_handle_t ) :: c_handle type ( information ), pointer :: inf inf => oqp_handle_get_info ( c_handle ) call guess_sap ( inf ) end subroutine guess_sap_C subroutine guess_sap ( infos ) use precision , only : dp use types , only : information use io_constants , only : IW use oqp_tagarray_driver use basis_tools , only : basis_set use guess , only : get_ab_initio_density , get_ab_initio_orbital use qmat_cache , only : get_qmat_cached use util , only : measure_time use messages , only : show_message , WITH_ABORT use printing , only : print_module_info use parallel , only : par_env_t use iso_c_binding , only : c_char , c_null_char use mod_dft_molgrid , only : dft_grid_t use dft , only : dft_initialize use sap_lut , only : sap_table_t use mod_dft_gridint_sap , only : sap_potential_matrix implicit none character ( len =* ), parameter :: subroutine_name = \"guess_sap\" type ( information ), target , intent ( inout ) :: infos integer :: nbf , nbf2 , ok , i , maxz real ( kind = dp ), allocatable :: qmat (:,:), fock (:), vsap (:) type ( basis_set ), pointer :: basis type ( dft_grid_t ) :: molGrid character ( kind = c_char ) :: saved_xcname ( 20 ) type ( sap_table_t ) :: sap character ( len = :), allocatable :: sap_file logical :: err integer , parameter :: root = 0 type ( par_env_t ) :: pe ! tagarray real ( kind = dp ), contiguous , pointer :: & Tmat (:), Smat (:), & dmat_a (:), mo_a (:,:), mo_energy_a (:), & dmat_b (:), mo_b (:,:), mo_energy_b (:) character ( len =* ), parameter :: tags_alpha ( 3 ) = ( / character ( len = 80 ) :: & OQP_DM_A , OQP_E_MO_A , OQP_VEC_MO_A / ) character ( len =* ), parameter :: tags_beta ( 3 ) = ( / character ( len = 80 ) :: & OQP_DM_B , OQP_E_MO_B , OQP_VEC_MO_B / ) character ( len =* ), parameter :: tags_general ( 3 ) = ( / character ( len = 80 ) :: & OQP_SM , OQP_TM , OQP_hbasis_filename / ) character ( len = 1 , kind = c_char ), contiguous , pointer :: sap_filename (:) open ( unit = IW , file = infos % log_filename , position = \"append\" ) call print_module_info ( 'Guess_SAP' , & 'Initial guess using Superposition of Atomic Potentials' ) call pe % init ( infos % mpiinfo % comm , infos % mpiinfo % usempi ) ! Resolve the SAP data file path passed from Python (via the hbasis tag) call data_has_tags ( infos % dat , tags_general , module_name , subroutine_name , WITH_ABORT ) call tagarray_get_data ( infos % dat , OQP_hbasis_filename , sap_filename ) allocate ( character ( ubound ( sap_filename , 1 )) :: sap_file ) do i = 1 , ubound ( sap_filename , 1 ) sap_file ( i : i ) = sap_filename ( i ) end do ! Load the radial SAP table call sap % load ( sap_file , err ) if ( err ) call show_message ( 'Guess_SAP: cannot read SAP data file ' // trim ( sap_file ), WITH_ABORT ) ! Warn about elements beyond the tabulated range maxz = maxval ( nint ( infos % atoms % zn )) if ( maxz > sap % zmax ) then write ( IW , '(1x,a,i0,a,i0,a)' ) & 'Guess_SAP warning: element Z=' , maxz , & ' exceeds tabulated SAP range (Z<=' , sap % zmax , & '); those atoms contribute only the core Hamiltonian' end if basis => infos % basis basis % atoms => infos % atoms nbf = basis % nbf nbf2 = nbf * ( nbf + 1 ) / 2 allocate ( qmat ( nbf , nbf ), fock ( nbf2 ), vsap ( nbf2 ), stat = ok ) if ( ok /= 0 ) call show_message ( 'Guess_SAP: cannot allocate memory' , WITH_ABORT ) ! clean previous data ! load general data (overlap and kinetic-energy matrices are built by int1e). ! SAP uses the kinetic matrix T (not Hcore): the screened potential ! V_SAP = -Z_eff(r)/r already includes the nuclear attraction, so the guess ! Fock is F = T + V_SAP. Using Hcore would double-count nuclear attraction. call tagarray_get_data ( infos % dat , OQP_SM , smat ) call tagarray_get_data ( infos % dat , OQP_TM , tmat ) ! allocate alpha call infos % dat % alloc_or_die ( OQP_DM_A , ( / nbf2 / ), dmat_a , description = OQP_DM_A_comment ) call infos % dat % alloc_or_die ( OQP_E_MO_A , ( / nbf / ), mo_energy_a , description = OQP_E_MO_A_comment ) call infos % dat % alloc_or_die ( OQP_VEC_MO_A , ( / nbf , nbf / ), mo_a , description = OQP_VEC_MO_A_comment ) ! UHF/ROHF if ( infos % control % scftype >= 2 ) then call infos % dat % alloc_or_die ( OQP_DM_B , ( / nbf2 / ), dmat_b , description = OQP_DM_B_comment ) call infos % dat % alloc_or_die ( OQP_E_MO_B , ( / nbf / ), mo_energy_b , description = OQP_E_MO_B_comment ) call infos % dat % alloc_or_die ( OQP_VEC_MO_B , ( / nbf , nbf / ), mo_b , description = OQP_VEC_MO_B_comment ) end if ! Build the DFT molecular grid. The XC functional name is not yet set at ! guess time (it is initialized later for the SCF), so temporarily blank it ! and request grid setup without a functional (need_functional=.false.) so ! dft_set_options skips any LibXC functional setup. saved_xcname = infos % dft % xc_functional_name infos % dft % xc_functional_name = c_null_char call dft_initialize ( infos , basis , molGrid , verbose = . false ., need_functional = . false .) infos % dft % xc_functional_name = saved_xcname ! Integrate the SAP potential matrix on the grid vsap = 0.0_dp call sap_potential_matrix ( basis , molGrid , vsap , nbf , sap , infos ) ! Guess Fock = T + V_SAP  (V_SAP already contains the screened nuclear term) fock ( 1 : nbf2 ) = tmat ( 1 : nbf2 ) + vsap ( 1 : nbf2 ) ! Solve F C = eps S C call get_qmat_cached ( infos , smat , qmat , nbf ) call get_ab_initio_orbital ( fock , MO_A , MO_Energy_A , QMat ) if ( infos % control % scftype >= 2 ) MO_B = MO_A ! Density matrix if ( infos % control % scftype == 1 ) then call get_ab_initio_density ( Dmat_A , MO_A , infos = infos , basis = basis ) else call get_ab_initio_density ( Dmat_A , MO_A , Dmat_B , MO_B , infos , basis ) end if call sap % clean () write ( IW , '(/1x,a/)' ) '...... End Of Initial Orbital Guess ......' call measure_time ( print_total = 1 , log_unit = iw ) close ( IW ) end subroutine guess_sap end module guess_sap_mod","tags":"","url":"sourcefile/guess_sap.f90.html"},{"title":"fock_deriv.F90 – OpenQP Fortran API","text":"Source Code module fock_deriv_mod !> @brief Two-electron derivative-Fock contraction  tr(M . F&#94;x[P])  for the !>   CPHF nuclear right-hand side, built natively on top of the validated 2e !>   gradient driver (grd2_driver) with no changes to the Rys internals and no !>   libint. !> !>   The 2e gradient driver contracts the derivative ERIs d(uv|ls)/dx with a !>   four-index density product supplied by a grd2_compute_data_t extension. The !>   standard (energy-gradient) extension forms D (x) D. Here we instead form a !>   MIXED product M (x) P, so the same driver returns, for each nuclear !>   coordinate x, !>     g_x = sum_{uvls} d(uv|ls)/dx * [ 4 c M_uv P_ls - x_hf ( M_ul P_vs + M_us P_vl ) ] !>   which is exactly  sum_uv M_uv F&#94;x_uv[P]  for the closed-shell response Fock !>   F&#94;x[P] = J&#94;x[P] - 1/2 K&#94;x[P] (Coulomb scaled by c, exchange by x_hf=HFscale), !>   summed over the two equivalent index orderings that the driver already !>   exploits. M is the \"probe\" matrix; for a CPHF RHS element B&#94;x_{ia} the probe !>   is the symmetric AO matrix C_{.,i} C_{.,a}&#94;T + C_{.,a} C_{.,i}&#94;T. !> !>   This is the F&#94;x building block of the native CPHF chain. It is validated by !>   the trace identity tr(P . F&#94;x[P]) = (2e part of dE/dx), i.e. against the !>   already-validated grd2_driver energy gradient (exact, non-iterative). use precision , only : dp use grd2 , only : grd2_driver , grd2_compute_data_t use basis_tools , only : basis_set , bas_norm_matrix , build_cart_density use constants , only : HARMONIC_ACTIVE , NUM_CART_BF use types , only : information implicit none character ( len =* ), parameter :: module_name = \"fock_deriv_mod\" !> grd2 compute-data extension forming the mixed two-density product M (x) P. type , extends ( grd2_compute_data_t ) :: grd2_fockprobe_data_t real ( kind = dp ), pointer :: pmat (:,:) => null () !< density P (nbf,nbf), full real ( kind = dp ), pointer :: mmat (:,:) => null () !< probe  M (nbf,nbf), full (symmetric) ! Cartesian-effective (bfnrm-folded) copies + Cartesian offsets, used under ! HARMONIC_ACTIVE so the spherical probe/density contract with Cartesian ! derivative ERIs (set by prepare_cart). real ( kind = dp ), allocatable :: pmat_cart (:,:), mmat_cart (:,:) integer , allocatable :: cart_off (:) integer :: nbf = 0 contains procedure :: init => grd2_fockprobe_init procedure :: clean => grd2_fockprobe_clean procedure :: get_density => grd2_fockprobe_get_density end type !> Open-shell (UHF/ROHF) extension: the probe M is contracted against a !> Coulomb density (the spin-summed total) and a SEPARATE exchange density !> (one spin), so the contraction returns the genuine open-shell derivative- !> Fock trace !>    g_x = sum_uv M_uv ( J&#94;x_uv[pcoul] - c_x K&#94;x_uv[pexch] ) !> with the full (not 1/2) open-shell exchange factor, matching the spin-s !> Fock that scf_addons::fock_jk assembles for scftype>=2.  Setting !> pcoul == pexch == P does NOT reduce to the closed-shell grd2_fockprobe_data_t !> (which carries the closed-shell 1/2 K factor); this object is for the !> open-shell response only. type , extends ( grd2_compute_data_t ) :: grd2_fockprobe_os_data_t real ( kind = dp ), pointer :: pcoul (:,:) => null () !< Coulomb density (total = Pa+Pb) real ( kind = dp ), pointer :: pexch (:,:) => null () !< exchange density (one spin) real ( kind = dp ), pointer :: mmat (:,:) => null () !< probe M (nbf,nbf), full (symmetric) real ( kind = dp ), allocatable :: pcoul_cart (:,:), pexch_cart (:,:), mmat_cart (:,:) integer , allocatable :: cart_off (:) integer :: nbf = 0 contains procedure :: init => grd2_fockprobe_os_init procedure :: clean => grd2_fockprobe_os_clean procedure :: get_density => grd2_fockprobe_os_get_density end type private public :: grd2_fockprobe_data_t public :: grd2_fockprobe_os_data_t public :: fock_deriv_contract public :: fock_deriv_contract_os contains !############################################################################### !> @brief Compute g_x = sum_uv M_uv F&#94;x_uv[P] for every nuclear coordinate. !> @param[in]  infos    system info (converged SCF) !> @param[in]  basis    basis set !> @param[in]  pmat     density P (nbf,nbf) full, AO basis (alpha density for RHF) !> @param[in]  mmat     probe M (nbf,nbf) full, symmetric, AO basis !> @param[in]  hfscale  HF exchange scale (1.0 for HF; HFscale for hybrids) !> @param[out] gx       (3, natom) contraction per nuclear coordinate subroutine fock_deriv_contract ( infos , basis , pmat , mmat , hfscale , gx ) type ( information ), target , intent ( inout ) :: infos type ( basis_set ), intent ( in ) :: basis real ( kind = dp ), target , intent ( in ) :: pmat (:,:), mmat (:,:) real ( kind = dp ), intent ( in ) :: hfscale real ( kind = dp ), intent ( out ) :: gx (:,:) type ( grd2_fockprobe_data_t ) :: gcomp integer , allocatable :: off_dummy (:) integer :: ncart gcomp % pmat => pmat gcomp % mmat => mmat gcomp % nbf = basis % nbf gcomp % coulscale = 1.0_dp gcomp % hfscale = hfscale gcomp % hfscale2 = hfscale if ( HARMONIC_ACTIVE ) then call fockprobe_cart ( basis , pmat , gcomp % pmat_cart , gcomp % cart_off , ncart ) call fockprobe_cart ( basis , mmat , gcomp % mmat_cart , off_dummy , ncart ) end if gx = 0.0_dp call grd2_driver ( infos , basis , gx , gcomp ) end subroutine fock_deriv_contract !############################################################################### !> @brief Cartesian-effective (bfnrm-folded) copy of a full AO matrix + !>   Cartesian per-shell offsets, for contraction with Cartesian derivative !>   ERIs under HARMONIC_ACTIVE. subroutine fockprobe_cart ( basis , m , m_cart , cart_off , nbf_cart ) type ( basis_set ), intent ( in ) :: basis real ( kind = dp ), intent ( in ) :: m (:,:) real ( kind = dp ), allocatable , intent ( out ) :: m_cart (:,:) integer , allocatable , intent ( out ) :: cart_off (:) integer , intent ( out ) :: nbf_cart real ( kind = dp ), allocatable :: tmp (:,:) tmp = m call bas_norm_matrix ( tmp , basis % bfnrm , basis % nbf ) call build_cart_density ( basis , tmp , m_cart , cart_off , nbf_cart ) end subroutine fockprobe_cart !############################################################################### subroutine grd2_fockprobe_init ( this ) class ( grd2_fockprobe_data_t ), target , intent ( inout ) :: this ! pmat/mmat are full matrices supplied by the caller; nothing to unpack. end subroutine grd2_fockprobe_init !############################################################################### subroutine grd2_fockprobe_clean ( this ) class ( grd2_fockprobe_data_t ), target , intent ( inout ) :: this this % pmat => null () this % mmat => null () end subroutine grd2_fockprobe_clean !############################################################################### !> @brief Mixed two-density product for the shell quartet, matching the layout !>   and normalization of grd2_rhf_compute_data_t_get_density but replacing the !>   second density factor with the probe M.  The energy-gradient routine forms !>     4 c D_ij D_kl - x_hf ( D_ik D_jl + D_il D_jk ). !>   To contract d(uv|ls)/dx with M on the (i,j)=(u,v) pair and P on the !>   (k,l)=(l,s) pair (Coulomb), and M/P spread across the exchange index !>   pairings symmetrically, we form !>     4 c M_ij P_kl !>     - x_hf/2 ( M_ik P_jl + M_il P_jk + P_ik M_jl + P_il M_jk ). !>   The 1/2 with the four symmetric exchange terms reproduces the same total as !>   the energy routine's x_hf ( D_ik D_jl + D_il D_jk ) when M = P, so the trace !>   identity tr(P . F&#94;x[P]) = (2e gradient) holds exactly. subroutine grd2_fockprobe_get_density ( this , basis , id , dab , dabmax ) class ( grd2_fockprobe_data_t ), target , intent ( inout ) :: this type ( basis_set ), intent ( in ) :: basis integer , intent ( in ) :: id ( 4 ) real ( kind = dp ), target , intent ( out ) :: dab ( * ) real ( kind = dp ), intent ( out ) :: dabmax real ( kind = dp ) :: coulfact , xcfact , df1 , dq1 , bfn integer :: i , j , k , l , i1 , j1 , k1 , l1 integer :: loc ( 4 ), nbf ( 4 ) real ( kind = dp ), pointer :: ab (:,:,:,:) real ( kind = dp ), pointer :: pmat (:,:), mmat (:,:) logical :: usecart coulfact = 4 * this % coulscale xcfact = this % hfscale usecart = HARMONIC_ACTIVE if ( usecart ) then pmat => this % pmat_cart ; mmat => this % mmat_cart loc = this % cart_off ( id ) - 1 nbf = NUM_CART_BF ( basis % am ( id )) else pmat => this % pmat ; mmat => this % mmat loc = basis % ao_offset ( id ) - 1 nbf = basis % naos ( id ) end if dabmax = 0 ab ( 1 : nbf ( 4 ), 1 : nbf ( 3 ), 1 : nbf ( 2 ), 1 : nbf ( 1 )) => dab ( 1 : product ( nbf )) do i = 1 , nbf ( 1 ) i1 = loc ( 1 ) + i do j = 1 , nbf ( 2 ) j1 = loc ( 2 ) + j do k = 1 , nbf ( 3 ) k1 = loc ( 3 ) + k do l = 1 , nbf ( 4 ) l1 = loc ( 4 ) + l ! Coulomb: symmetrized over the (ij)<->(kl) permutation the driver ! exploits: 2 c (M_ij P_kl + M_kl P_ij) (reduces to 4 c P_ij P_kl at M=P). df1 = 0.5_dp * coulfact * ( mmat ( i1 , j1 ) * pmat ( k1 , l1 ) & + mmat ( k1 , l1 ) * pmat ( i1 , j1 ) ) if ( xcfact /= 0.0_dp ) then ! Exchange: symmetrized 4-term (reduces to x(P_ik P_jl+P_il P_jk) at M=P). dq1 = 0.5_dp * ( mmat ( i1 , k1 ) * pmat ( j1 , l1 ) & + mmat ( i1 , l1 ) * pmat ( j1 , k1 ) & + pmat ( i1 , k1 ) * mmat ( j1 , l1 ) & + pmat ( i1 , l1 ) * mmat ( j1 , k1 ) ) df1 = df1 - xcfact * dq1 end if dabmax = max ( dabmax , abs ( df1 )) bfn = 1.0_dp if (. not . usecart ) bfn = product ( basis % bfnrm ([ i1 , j1 , k1 , l1 ])) ab ( l , k , j , i ) = df1 * bfn end do end do end do end do end subroutine grd2_fockprobe_get_density !############################################################################### !  Open-shell (UHF/ROHF) two-density derivative-Fock contraction !############################################################################### !> @brief Compute g_x = sum_uv M_uv ( J&#94;x_uv[pcoul] - c_x K&#94;x_uv[pexch] ) for !>   every nuclear coordinate, i.e. the trace of the probe M against the !>   open-shell spin-s derivative Fock with Coulomb from the total density and !>   exchange from the spin density. !> @param[in]  infos    system info (converged SCF) !> @param[in]  basis    basis set !> @param[in]  pcoul    Coulomb density (total Pa+Pb), full (nbf,nbf), AO basis !> @param[in]  pexch    exchange density (one spin), full (nbf,nbf), AO basis !> @param[in]  mmat     probe M (nbf,nbf) full, symmetric, AO basis !> @param[in]  hfscale  HF exchange scale (1.0 for HF; HFscale for hybrids) !> @param[out] gx       (3, natom) contraction per nuclear coordinate subroutine fock_deriv_contract_os ( infos , basis , pcoul , pexch , mmat , hfscale , gx ) type ( information ), target , intent ( inout ) :: infos type ( basis_set ), intent ( in ) :: basis real ( kind = dp ), target , intent ( in ) :: pcoul (:,:), pexch (:,:), mmat (:,:) real ( kind = dp ), intent ( in ) :: hfscale real ( kind = dp ), intent ( out ) :: gx (:,:) type ( grd2_fockprobe_os_data_t ) :: gcomp integer , allocatable :: off_dummy (:) integer :: ncart gcomp % pcoul => pcoul gcomp % pexch => pexch gcomp % mmat => mmat gcomp % nbf = basis % nbf gcomp % coulscale = 1.0_dp gcomp % hfscale = hfscale gcomp % hfscale2 = hfscale if ( HARMONIC_ACTIVE ) then call fockprobe_cart ( basis , pcoul , gcomp % pcoul_cart , gcomp % cart_off , ncart ) call fockprobe_cart ( basis , pexch , gcomp % pexch_cart , off_dummy , ncart ) call fockprobe_cart ( basis , mmat , gcomp % mmat_cart , off_dummy , ncart ) end if gx = 0.0_dp call grd2_driver ( infos , basis , gx , gcomp ) end subroutine fock_deriv_contract_os !############################################################################### subroutine grd2_fockprobe_os_init ( this ) class ( grd2_fockprobe_os_data_t ), target , intent ( inout ) :: this ! densities/probe are full matrices supplied by the caller; nothing to do. end subroutine grd2_fockprobe_os_init !############################################################################### subroutine grd2_fockprobe_os_clean ( this ) class ( grd2_fockprobe_os_data_t ), target , intent ( inout ) :: this this % pcoul => null () this % pexch => null () this % mmat => null () end subroutine grd2_fockprobe_os_clean !############################################################################### !> @brief Open-shell mixed-density product for the shell quartet. !>   The closed-shell grd2_fockprobe_get_density forms !>     2 c (M_ij P_kl + M_kl P_ij) - x_hf/2 (M_ik P_jl + M_il P_jk !>                                            + P_ik M_jl + P_il M_jk), !>   which the validated builder maps to  1/2 Tr[M J&#94;x[P]] - 1/4 c_x Tr[M K&#94;x[P]] !>   (the closed-shell Fock J - 1/2 K).  Here we want the FULL open-shell trace !>     Tr[M J&#94;x[pcoul]] - c_x Tr[M K&#94;x[pexch]], !>   i.e. twice the Coulomb coefficient and four times the exchange coefficient, !>   with Coulomb taking the total density (pcoul) and exchange the spin density !>   (pexch).  Validated by fock_deriv_os_selftest against a finite difference of !>   Tr[M . fock_jk_spin] at frozen densities. subroutine grd2_fockprobe_os_get_density ( this , basis , id , dab , dabmax ) class ( grd2_fockprobe_os_data_t ), target , intent ( inout ) :: this type ( basis_set ), intent ( in ) :: basis integer , intent ( in ) :: id ( 4 ) real ( kind = dp ), target , intent ( out ) :: dab ( * ) real ( kind = dp ), intent ( out ) :: dabmax real ( kind = dp ) :: ccoef , xcoef , df1 , dq1 , bfn integer :: i , j , k , l , i1 , j1 , k1 , l1 integer :: loc ( 4 ), nbf ( 4 ) real ( kind = dp ), pointer :: ab (:,:,:,:) real ( kind = dp ), pointer :: mmat (:,:), pcoul (:,:), pexch (:,:) logical :: usecart ccoef = 4 * this % coulscale ! 2x the closed-shell Coulomb -> full Tr[M J&#94;x[pcoul]] xcoef = 2 * this % hfscale ! 4x the closed-shell exchange -> full c_x Tr[M K&#94;x[pexch]] usecart = HARMONIC_ACTIVE if ( usecart ) then mmat => this % mmat_cart ; pcoul => this % pcoul_cart ; pexch => this % pexch_cart loc = this % cart_off ( id ) - 1 nbf = NUM_CART_BF ( basis % am ( id )) else mmat => this % mmat ; pcoul => this % pcoul ; pexch => this % pexch loc = basis % ao_offset ( id ) - 1 nbf = basis % naos ( id ) end if dabmax = 0 ab ( 1 : nbf ( 4 ), 1 : nbf ( 3 ), 1 : nbf ( 2 ), 1 : nbf ( 1 )) => dab ( 1 : product ( nbf )) do i = 1 , nbf ( 1 ) i1 = loc ( 1 ) + i do j = 1 , nbf ( 2 ) j1 = loc ( 2 ) + j do k = 1 , nbf ( 3 ) k1 = loc ( 3 ) + k do l = 1 , nbf ( 4 ) l1 = loc ( 4 ) + l ! Coulomb: M against the TOTAL density (symmetrized over (ij)<->(kl)). df1 = ccoef * ( mmat ( i1 , j1 ) * pcoul ( k1 , l1 ) & + mmat ( k1 , l1 ) * pcoul ( i1 , j1 ) ) if ( xcoef /= 0.0_dp ) then ! Exchange: M against the SPIN density (4-term symmetrized). dq1 = mmat ( i1 , k1 ) * pexch ( j1 , l1 ) & + mmat ( i1 , l1 ) * pexch ( j1 , k1 ) & + pexch ( i1 , k1 ) * mmat ( j1 , l1 ) & + pexch ( i1 , l1 ) * mmat ( j1 , k1 ) df1 = df1 - xcoef * dq1 end if dabmax = max ( dabmax , abs ( df1 )) bfn = 1.0_dp if (. not . usecart ) bfn = product ( basis % bfnrm ([ i1 , j1 , k1 , l1 ])) ab ( l , k , j , i ) = df1 * bfn end do end do end do end do end subroutine grd2_fockprobe_os_get_density end module fock_deriv_mod","tags":"","url":"sourcefile/fock_deriv.f90.html"},{"title":"tdhf_energy.F90 – OpenQP Fortran API","text":"Source Code module tdhf_energy_mod implicit none character ( len =* ), parameter :: module_name = \"tdhf_energy_mod\" contains subroutine tdhf_energy_C ( c_handle ) bind ( C , name = \"tdhf_energy\" ) use c_interop , only : oqp_handle_t , oqp_handle_get_info use types , only : information type ( oqp_handle_t ) :: c_handle type ( information ), pointer :: inf inf => oqp_handle_get_info ( c_handle ) call tdhf_energy_with_restart ( inf ) end subroutine tdhf_energy_C ! Run the TDDFT/TDHF Davidson and auto-restart with a larger subspace (maxvec) ! and more iterations (maxit_dav) if it fails to converge.  Re-invoking the ! driver reallocates a fresh, larger subspace; user settings restored after. subroutine tdhf_energy_with_restart ( infos ) use types , only : information use io_constants , only : iw type ( information ), intent ( inout ) :: infos integer , parameter :: max_restarts = 2 integer :: attempt , maxvec0 , maxit0 maxvec0 = infos % tddft % maxvec maxit0 = infos % control % maxit_dav do attempt = 0 , max_restarts call tdhf_energy ( infos ) if ( infos % mol_energy % Davidson_converged ) exit if ( attempt < max_restarts ) then infos % tddft % maxvec = 2 * infos % tddft % maxvec infos % control % maxit_dav = 2 * infos % control % maxit_dav open ( unit = iw , file = infos % log_filename , position = \"append\" ) write ( iw , '(/,2X,\"Davidson not converged; auto-restart #\",I0, & &\" with larger subspace (maxvec=\",I0,\", maxit_dav=\",I0,\")\"/)' ) & attempt + 1 , infos % tddft % maxvec , infos % control % maxit_dav close ( iw ) end if end do infos % tddft % maxvec = maxvec0 infos % control % maxit_dav = maxit0 end subroutine tdhf_energy_with_restart subroutine tdhf_energy ( infos ) use , intrinsic :: ieee_arithmetic , only : ieee_is_finite use io_constants , only : iw use oqp_tagarray_driver use types , only : information use strings , only : Cstring , fstring use basis_tools , only : basis_set use messages , only : show_message , with_abort use precision , only : dp use int2_compute , only : int2_compute_t use tdhf_lib , only : sym_response_project , & int2_td_data_t use tdhf_lib , only : & inivec , iatogen , mntoia , rparedms , rpaeig , rpavnorm , & rpaechk , rpaprint , rparesvec , rpaexpndv , rpanewb , esum , & tdhf_unrelaxed_density use dft , only : dft_initialize , dftclean use mod_dft_gridint_fxc , only : tddft_fxc use util , only : measure_time use mathlib , only : symmetrize_matrix , orthogonal_transform use mod_dft_molgrid , only : dft_grid_t use mathlib , only : unpack_matrix use printing , only : print_module_info implicit none character ( len =* ), parameter :: subroutine_name = \"tdhf_energy\" type ( basis_set ), pointer :: basis type ( information ), target , intent ( inout ) :: infos integer :: ok real ( kind = dp ), allocatable :: scr2 (:) real ( kind = dp ), allocatable :: ab1_mo (:,:), ab2_mo (:,:), abxc (:,:), scr3 (:,:) real ( kind = dp ), allocatable :: eex (:) real ( kind = dp ), allocatable :: abm_l (:,:), abp_r (:,:), amb (:,:), & apb (:,:), vlo (:,:), vro (:,:) real ( kind = dp ), allocatable , target :: vl (:), vr (:) real ( kind = dp ), pointer :: vl_p (:,:), vr_p (:,:) real ( kind = dp ), allocatable :: xm (:) real ( kind = dp ), allocatable :: bvec_mo (:,:) real ( kind = dp ), allocatable , target :: bvec (:,:,:) real ( kind = dp ), allocatable :: scr1 (:,:) real ( kind = dp ), allocatable :: errors (:) real ( kind = dp ), pointer :: ab2 (:,:,:) real ( kind = dp ), pointer :: ab1 (:,:,:) real ( kind = dp ), allocatable :: dip (:,:) integer :: nocc , nvir integer :: nbf , nbf2 , lexc integer :: ndsr , mxvec , nmax , ist , iend , nvec , novec integer :: iter , istart , nv , iv , ivec integer :: mxiter logical :: do_apb , do_amb , tamm_dancoff ! SWITCH FOR a-b, a+b, tANDAMM COFF integer :: imax logical :: converged integer :: ierr real ( kind = dp ) :: mxerr , cnvtol , scale_exch , norm integer :: maxvec , nstates type ( int2_compute_t ) :: int2_driver type ( int2_td_data_t ), target :: int2_data type ( dft_grid_t ) :: molGrid logical :: dft ! tagarray real ( kind = dp ), contiguous , pointer :: & mo_energy_a (:), mo_a (:,:), td_t (:,:), & xpy (:,:), xmy (:,:), td_energies (:) character ( len =* ), parameter :: tags_alloc ( 4 ) = ( / character ( len = 80 ) :: & OQP_td_t , OQP_td_xpy , OQP_td_xmy , OQP_td_energies / ) character ( len =* ), parameter :: tags_alpha ( 2 ) = ( / character ( len = 80 ) :: & OQP_E_MO_A , OQP_VEC_MO_A / ) dft = infos % control % hamilton == 20 ! Files open ! 3. LOG: Write: Main output file open ( unit = IW , file = infos % log_filename , position = \"append\" ) ! call print_module_info ( 'THDF_Energy' , 'Computing Energy of TDDFT' ) ! Readings ! Load basis set basis => infos % basis basis % atoms => infos % atoms ! Allocate H, S ,T and D matrices nbf = basis % nbf nbf2 = nbf * ( nbf + 1 ) / 2 call data_has_tags ( infos % dat , tags_alpha , module_name , subroutine_name , WITH_ABORT ) call tagarray_get_data ( infos % dat , OQP_E_MO_A , mo_energy_a ) call tagarray_get_data ( infos % dat , OQP_VEC_MO_A , mo_a ) if ( dft ) call dft_initialize ( infos , basis , molGrid , verbose = . true .) nstates = infos % tddft % nstate maxvec = infos % tddft % maxvec cnvtol = infos % tddft % cnvtol do_apb = . true . ! Always do A+B part do_amb = . true . ! = isGGA ! Do A-B part if a hybrid functional. tamm_dancoff = infos % tddft % tda ! Tamm/Dancoff approximation nocc = infos % mol_prop % nocc nvir = nbf - nocc lexc = nocc * nvir mxvec = min ( maxvec * nstates , lexc ) nvec = min ( nstates , mxvec ) ndsr = nvec nmax = 2 * nvec !nvec = 2*nvec ! Allocate TDDFT variables allocate ( xm ( lexc ), & abxc ( nbf , nbf ), & bvec_mo ( lexc , mxvec ), & ab1_mo ( lexc , mxvec ), & ab2_mo ( lexc , mxvec ), & bvec ( nbf , nbf , nmax ), & eex ( mxvec ), & errors ( mxvec ), & apb ( mxvec , mxvec ), & amb ( mxvec , mxvec ), & vr ( mxvec * mxvec ), & vro ( lexc , mxvec ), & vl ( mxvec * mxvec ), & vlo ( lexc , mxvec ), & abp_r ( lexc , mxvec ), & abm_l ( lexc , mxvec ), & dip ( 3 , nstates ), & scr1 ( nbf , nbf ), & scr2 ( mxvec * mxvec ), & scr3 ( lexc , nmax ), & source = 0.0d0 , & stat = ok ) if ( ok /= 0 ) & call show_message ( 'Cannot allocate memory' , with_abort ) ! Initialize ERI calculations call int2_driver % init ( basis , infos ) call int2_driver % set_screening () scale_exch = 1.0_dp if ( dft ) scale_exch = infos % dft % HFscale ! Construct TD trial vector call inivec ( mo_energy_a , mo_energy_a , bvec_mo , xm , nocc , nocc , nvec ) ist = 1 istart = 1 iend = nvec iter = 0 mxiter = infos % control % maxit_dav ierr = 0 do iter = 1 , mxiter nv = iend - ist + 1 !$omp parallel private(iv,scr1,abxc,ivec) !$omp do schedule(static) do ivec = ist , iend iv = ivec - ist + 1 call iatogen ( bvec_mo (:, ivec ), abxc , nocc , nocc ) call orthogonal_transform ( 't' , nbf , mo_a , abxc , bvec (:,:, iv ), scr1 ) end do !$omp end do !$omp end parallel int2_data = int2_td_data_t ( d2 = bvec (:,:,: nv ), & int_apb = do_apb , int_amb = do_amb , tamm_dancoff = tamm_dancoff , & tamm_dancoff_coulomb = . true ., & scale_exchange = scale_exch ) call int2_driver % run ( int2_data , & cam = dft . and . infos % dft % cam_flag , & alpha = infos % dft % cam_alpha , & beta = infos % dft % cam_beta ,& mu = infos % dft % cam_mu ) ab1 => int2_data % apb (:,:,:, 1 ) ab2 => int2_data % amb (:,:,:, 1 ) if ( dft ) then do ivec = ist , iend iv = ivec - ist + 1 call symmetrize_matrix ( bvec (:,:, iv ), nbf ) end do call tddft_fxc ( basis = basis , & molGrid = molGrid , & isVecs = . true ., & wf = mo_a , & fx = ab1 (:,:,: iv ), & dx = bvec (:,:,: iv ), & nmtx = iv , & !threshold=1.0d-15, & threshold = 0.0d0 , & infos = infos ) end if !$omp parallel private(iv,ivec) !$omp do schedule(static) do ivec = ist , iend iv = ivec - ist + 1 !     Convert AO to MO basis if ( tamm_dancoff ) then ab1 (:,:, iv ) = 0.5_dp * ab1 (:,:, iv ) + ab2 (:,:, iv ) end if call mntoia ( ab1 (:,:, iv ), ab1_mo (:, ivec ), mo_a , mo_a , nocc , nocc ) !     Product (A+B)*X call esum ( mo_energy_a , ab1_mo , bvec_mo , nocc , ivec ) if (. not . tamm_dancoff ) then !         Product (A-B)*X call mntoia ( ab2 (:,:, iv ), ab2_mo (:, ivec ), mo_a , mo_a , nocc , nocc ) call esum ( mo_energy_a , ab2_mo , bvec_mo , nocc , ivec ) end if end do !$omp end do !$omp end parallel call rparedms ( bvec_mo , ab1_mo , ab2_mo , apb , amb , nvec , tamm_dancoff ) vl_p ( 1 : nvec , 1 : nvec ) => vl ( 1 : nvec * nvec ) vr_p ( 1 : nvec , 1 : nvec ) => vr ( 1 : nvec * nvec ) call rpaeig ( eex , vl_p , vr_p , apb , amb , scr2 , tamm_dancoff ) call rpavnorm ( vr_p , vl_p , tamm_dancoff ) call rpaexpndv ( vr_p , vl_p , vro , vlo , bvec_mo , bvec_mo , ndsr , tamm_dancoff ) call rpaexpndv ( vr_p , vl_p , abp_r , abm_l , ab1_mo , ab2_mo , ndsr , tamm_dancoff ) call rpaechk ( eex , nvec , ndsr , imax , tamm_dancoff ) !     Residual vectors W !     Get perturbed vectors Q if required call rparesvec ( scr3 , abp_r , abm_l , vlo , vro , eex , xm , ndsr , errors , cnvtol , imax , tamm_dancoff ) !     Response-space symmetry blocking (no-op unless staged by pyoqp). call sym_response_project ( infos , vro , scr3 , ndsr ) if ( imax < ndsr ) then if ( any (. not . ieee_is_finite ( errors ( imax + 1 : ndsr )))) then ierr = 4 exit end if mxerr = maxval ( errors ( imax + 1 : ndsr )) else mxerr = 0.0_dp end if call rpaprint ( eex , errors , cnvtol , iter , imax , ndsr ) !     Check convergence converged = mxerr <= cnvtol if ( converged ) exit !     No space left for new vectors, exit if ( nvec == mxvec ) ierr = 1 if ( ierr /= 0 ) exit call rpanewb ( ndsr , bvec_mo , scr3 , novec , nvec , ierr , tamm_dancoff ) !   ierr=1 nvec over mxvec: not converged case if ( ierr /= 0 ) exit ist = novec + 1 iend = nvec end do if ( iter >= mxiter . and . . not . converged ) ierr = - 1 select case ( ierr ) case ( - 1 ) write ( * , '(/,2X,\"TD-DFT energies NOT CONVERGED after \",I4,\" iterations\"/)' ) mxiter infos % mol_energy % Davidson_converged = . false . !      call show_message(\"Aborting. Try to increase maxit or check your system.\", WITH_ABORT) case ( 0 ) write ( * , '(/,2X,\"TD-DFT energies converged in \",I4,\" iterations\"/)' ) iter infos % mol_energy % Davidson_converged = . true . case ( 1 ) write ( * , '(/,2X,\"..something is wrong.. nvec = mxvec\")' ) infos % mol_energy % Davidson_converged = . false . case ( 2 ) write ( * , '(/,2x,\"..something is wrong..  nvec > mxvec\")' ) write ( * , '(3x,\"nvec/mxvec =\",I4,\"/\",I4)' ) nvec , mxvec infos % mol_energy % Davidson_converged = . false . case ( 3 ) write ( * , '(/,2x,\"..something is wrong.. No vectors were added\")' ) infos % mol_energy % Davidson_converged = . false . case ( 4 ) write ( * , '(/,2X,\"TD-DFT Davidson breakdown: non-finite residual\",/)' ) infos % mol_energy % Davidson_converged = . false . call int2_driver % clean () if ( dft ) call dftclean ( infos ) call measure_time ( print_total = 1 , log_unit = iw ) close ( iw ) return end select call get_td_transition_dipole ( basis , dip , mo_a , vro , vlo , nstates , nocc ) call td_print_results ( eex , dip , nstates ) call measure_time ( print_total = 1 , log_unit = iw ) ! Bi-orthogonalize X+Y and X-Y: ! (X+Y)_i \\dot (X-Y)_j = \\delta_ij ! only normalization is needed ! RHF reference case: alpha == beta, additional factor of 1/sqrt(2) do ist = 1 , nstates norm = 1 / sqrt ( 2 * dot_product ( vlo (:, ist ), vro (:, ist ))) vlo (:, ist ) = vlo (:, ist ) * norm vro (:, ist ) = vro (:, ist ) * norm end do call infos % dat % alloc_or_die ( OQP_td_t , ( / nbf2 , 1 / ), td_t , description = OQP_td_t_comment ) call infos % dat % alloc_or_die ( OQP_td_xpy , ( / lexc , nstates / ), xpy , & description = \"(X+Y) vector for target state in TD-DFT calculations\" ) call infos % dat % alloc_or_die ( OQP_td_xmy , ( / lexc , nstates / ), xmy , & description = \"(X-Y) vector for target state in TD-DFT calculations\" ) call infos % dat % alloc_or_die ( OQP_td_energies , ( / nstates / ), td_energies , & description = OQP_td_energies_comment ) xpy = vro (:,: nstates ) xmy = vlo (:,: nstates ) td_energies = eex (: nstates ) infos % mol_energy % excited_energy = td_energies ( infos % tddft % target_state ) call int2_driver % clean () if ( dft ) call dftclean ( infos ) close ( iw ) end subroutine tdhf_energy subroutine get_td_transition_dipole ( basis , dip , v , vr , vl , nstates , nocc ) use int1 use types , only : information use basis_tools , only : basis_set use messages , only : show_message , with_abort use tdhf_lib , only : iatogen use mathlib , only : orthogonal_transform , symmetrize_matrix , traceprod_sym_packed use mathlib , only : pack_matrix implicit none type ( basis_set ), intent ( in ) :: basis real ( kind = 8 ) :: vl (:,:), vr (:,:), v (:,:) real ( kind = 8 ) :: dip (:,:) integer :: nstates , nocc real ( kind = 8 ) :: com ( 3 ) real ( kind = 8 ), allocatable :: mints (:,:), trden (:,:), trden_ao (:,:) real ( kind = 8 ), allocatable , target :: tmp (:,:) real ( kind = 8 ), pointer :: tmp2 (:) integer :: nbf , nbf2 , ok integer :: i , j , s1 nbf = basis % nbf nbf2 = nbf * ( nbf + 1 ) / 2 allocate ( mints ( nbf2 , 3 ), & trden ( nbf , nbf ), & trden_ao ( nbf , nbf ), & tmp ( nbf , nbf ), & source = 0.0d0 , stat = ok ) if ( ok /= 0 ) call show_message ( 'Cannot allocate memory' , WITH_ABORT ) ! Compute dipole integrals at the center of mass com = basis % atoms % center ( weight = 'mass' ) call multipole_integrals ( basis , mints , com , 1 ) ! Compute transition dipole between the ground state and all excited do s1 = 1 , nstates ! Compute transition density ! unpack X+Y call iatogen ( vr (:, s1 ), trden , nocc , nocc ) ! unpack X-Y call iatogen ( vl (:, s1 ), tmp , nocc , nocc ) do i = nocc + 1 , nbf do j = 1 , nocc trden ( i , j ) = trden ( j , i ) - tmp ( j , i ) ! Y: vir -> occ trden ( j , i ) = trden ( j , i ) + tmp ( j , i ) ! X: occ -> vir end do end do ! Convert transition density from MO to AO basis call orthogonal_transform ( 't' , nbf , v , trden , trden_ao , tmp ) ! Symmetrize and pack transition density to triangular format tmp2 ( 1 : nbf2 ) => tmp call symmetrize_matrix ( trden_ao , nbf ) call pack_matrix ( trden_ao , tmp2 ) ! Compute dipole moment: ! D_i = Tr(T * dipole_ints_i), i = x, y, z dip ( 1 , s1 ) = - traceprod_sym_packed ( tmp2 , mints (:, 1 ), nbf ) / ( 2.0d0 * sqrt ( 2.0d0 )) dip ( 2 , s1 ) = - traceprod_sym_packed ( tmp2 , mints (:, 2 ), nbf ) / ( 2.0d0 * sqrt ( 2.0d0 )) dip ( 3 , s1 ) = - traceprod_sym_packed ( tmp2 , mints (:, 3 ), nbf ) / ( 2.0d0 * sqrt ( 2.0d0 )) end do end subroutine subroutine td_print_results ( energies , dip , nstates ) use io_constants , only : iw use physical_constants , only : UNITS_EV implicit none real ( kind = 8 ) :: energies (:) real ( kind = 8 ) :: dip (:,:) real ( kind = 8 ) :: f integer :: nstates integer :: i write ( iw , '(/x,78(\"&#94;\"))' ) write ( iw , '(/8x,a/)' ) \"Summary of the TD-DFT calculation\" write ( iw , '(A12,A16,3A12,a14)' ) 'Transition' , 'dE(eV)' , 'DX' , 'DY' , 'DZ' , 'Osc.str.' do i = 1 , nstates f = 2.0d0 / 3.0d0 * energies ( i ) * dot_product ( dip (:, i ), dip (:, i )) write ( iw , '(3X,\"0 -> \",G0,t15,F15.6, 4F12.4)' ) i , energies ( i ) / UNITS_EV , dip ( 1 : 3 , i ), f end do write ( iw , '(x,78(\"=\")/)' ) end subroutine end module tdhf_energy_mod","tags":"","url":"sourcefile/tdhf_energy.f90.html"},{"title":"rys_lut.F90 – OpenQP Fortran API","text":"Source Code module rys_lut implicit none private integer , public , parameter :: mxrys = 13 integer , parameter :: mxdim = 16 integer , public , parameter :: maux = 55 integer , public , parameter :: nauxs ( mxdim ) = [ & 20 , 25 , 30 , 30 , 35 , 40 , 40 , 40 , 45 , 50 , 50 , 55 , 55 , 0 , 0 , 0 ] integer , public , parameter :: maprys ( mxdim ) = [ & 1 , 2 , 3 , 3 , 4 , 5 , 5 , 5 , 6 , 7 , 7 , 8 , 8 , 0 , 0 , 0 ] real ( kind = 8 ), public , parameter :: xasymp ( mxdim ) = [ & 0.2900000000000000D+02 , 0.3700000000000000D+02 , 0.4300000000000000D+02 , & 0.4900000000000000D+02 , 0.5500000000000000D+02 , 0.6000000000000000D+02 , & 0.6500000000000000D+02 , 0.7100000000000000D+02 , 0.7600000000000000D+02 , & 0.8100000000000000D+02 , 0.8600000000000000D+02 , 0.9100000000000000D+02 , & 0.9600000000000000D+02 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 ] real ( kind = 8 ), public , parameter :: rts_hermit ( mxdim , mxdim ) = reshape ([ & 0.4999999999999999D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.2752551286084109D+00 , 0.2724744871391588D+01 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.1901635091934877D+00 , & 0.1784492748543251D+01 , 0.5525343742263263D+01 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.1453035215033170D+00 , 0.1339097288126361D+01 , 0.3926963501358284D+01 , & 0.8588635689012030D+01 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.1175813202117781D+00 , 0.1074562012436902D+01 , & 0.3085937443717543D+01 , 0.6414729733662035D+01 , 0.1180718948997174D+02 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.9874701406848084D-01 , & 0.8983028345696176D+00 , 0.2552589802668170D+01 , 0.5196152530054469D+01 , & 0.9124248037531169D+01 , 0.1512995978110809D+02 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.8511544299759395D-01 , 0.7721379200427770D+00 , 0.2180591888450460D+01 , & 0.4389792886731013D+01 , 0.7554091326101775D+01 , 0.1198999303982387D+02 , & 0.1852827749585249D+02 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.7479188259681829D-01 , 0.6772490876492894D+00 , & 0.1905113635031427D+01 , 0.3809476361484907D+01 , 0.6483145428627172D+01 , & 0.1009332367522134D+02 , 0.1497262708842640D+02 , 0.2198427284096265D+02 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.6670223095819450D-01 , & 0.6032363570817492D+00 , 0.1692395079793180D+01 , 0.3369176270243266D+01 , & 0.5694423342957756D+01 , 0.8769756730268611D+01 , 0.1277182535486919D+02 , & 0.1804650546772900D+02 , 0.2548597916609910D+02 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.6019206314958798D-01 , 0.5438675002946464D+00 , 0.1522944105404443D+01 , & 0.3022513376451579D+01 , 0.5084907750098519D+01 , 0.7777439231525440D+01 , & 0.1120813020434865D+02 , 0.1556116333218934D+02 , 0.2119389209630154D+02 , & 0.2902495034023624D+02 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.5483986957881845D-01 , 0.4951741233503562D+00 , & 0.1384655740084599D+01 , 0.2741919940106705D+01 , 0.4597737700485715D+01 , & 0.6999397469528830D+01 , 0.1001890827595722D+02 , 0.1376930586610169D+02 , & 0.1844111968097817D+02 , 0.2440196124238704D+02 , 0.3259498009144090D+02 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.5036188911729382D-01 , & 0.4545066815637803D+00 , 0.1269589940103963D+01 , 0.2509848097232129D+01 , & 0.4198415644878415D+01 , 0.6369975388030632D+01 , 0.9075434230961196D+01 , & 0.1239044796380947D+02 , 0.1643219508767528D+02 , 0.2139675593616610D+02 , & 0.2766110877984612D+02 , 0.3619136036061559D+02 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.4656008324502469D-01 , 0.4200274064012148D+00 , 0.1172310773277779D+01 , & 0.2314540864349434D+01 , 0.3864585038228155D+01 , 0.5848734811306353D+01 , & 0.8304553489985896D+01 , 0.1128575099351764D+02 , 0.1487096037752540D+02 , & 0.1918091948561046D+02 , 0.2441669233305651D+02 , 0.3096393827474677D+02 , & 0.3981042606874937D+02 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.4329203573977355D-01 , 0.3904209260420311D+00 , & 0.1088965867569270D+01 , 0.2147799470582231D+01 , 0.3581028249991769D+01 , & 0.5409112330616471D+01 , 0.7660691115610091D+01 , 0.1037556300977005D+02 , & 0.1360971142939024D+02 , 0.1744429447570417D+02 , 0.2200319676691490D+02 , & 0.2749204150484384D+02 , 0.3430462050937314D+02 , 0.4344926230785199D+02 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.4045270430457500D-01 , & 0.3647206450514074D+00 , 0.1016746068857497D+01 , 0.2003718953133922D+01 , & 0.3336983205734512D+01 , 0.5032805277625116D+01 , 0.7113593769729876D+01 , & 0.9609817284304439D+01 , 0.1256308236994851D+02 , 0.1603128410807399D+02 , & 0.2009778533475589D+02 , 0.2488931247515655D+02 , 0.3061571740089948D+02 , & 0.3767847178420531D+02 , 0.4710550861821893D+02 , 0.0000000000000000D+00 , & 0.3796291457531353D-01 , 0.3422001560109476D+00 , 0.9535531553908647D+00 , & 0.1877931507696076D+01 , 0.3124601050702149D+01 , 0.4706726707667594D+01 , & 0.6642215179741446D+01 , 0.8955001337723395D+01 , 0.1167703367397597D+02 , & 0.1485143134180126D+02 , 0.1853774317860668D+02 , 0.2282130069352519D+02 , & 0.2783143821132870D+02 , 0.3378197048822615D+02 , 0.4108166652549115D+02 , & 0.5077722387753715D+02 ], shape = [ mxdim , mxdim ]) real ( kind = 8 ), public , parameter :: wts_hermit ( mxdim , mxdim ) = reshape ([ & 0.8862269254527578D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.8049140900055122D+00 , 0.8131283544724527D-01 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.7246295952243917D+00 , & 0.1570673203228566D+00 , 0.4530009905508823D-02 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.6611470125582407D+00 , 0.2078023258148924D+00 , 0.1707798300741349D-01 , & 0.1996040722113677D-03 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.6108626337353259D+00 , 0.2401386110823149D+00 , & 0.3387439445548109D-01 , 0.1343645746781227D-02 , 0.7640432855232614D-05 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.5701352362624800D+00 , & 0.2604923102641603D+00 , 0.5160798561588373D-01 , 0.3905390584629056D-02 , & 0.8573687043587825D-04 , 0.2658551684356290D-06 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.5364059097120907D+00 , 0.2731056090642466D+00 , 0.6850553422346510D-01 , & 0.7850054726457951D-02 , 0.3550926135519222D-03 , 0.4716484355018901D-05 , & 0.8628591168125136D-08 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.5079294790166150D+00 , 0.2806474585285342D+00 , & 0.8381004139898544D-01 , 0.1288031153550990D-01 , 0.9322840086241784D-03 , & 0.2711860092537892D-04 , 0.2320980844865203D-06 , 0.2654807474011178D-09 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.4834956947254553D+00 , & 0.2848072856699815D+00 , 0.9730174764131426D-01 , 0.1864004238754435D-01 , & 0.1888522630268412D-02 , 0.9181126867929414D-04 , 0.1810654481093431D-05 , & 0.1046720579579207D-07 , 0.7828199772115893D-11 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.4622436696006099D+00 , 0.2866755053628365D+00 , 0.1090172060200211D+00 , & 0.2481052088746278D-01 , 0.3243773342237852D-02 , 0.2283386360163555D-03 , & 0.7802556478532065D-05 , 0.1086069370769282D-06 , 0.4399340992273156D-09 , & 0.2229393645534101D-12 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.4435452264349595D+00 , 0.2869714332469076D+00 , & 0.1191023609587827D+00 , 0.3114037088442376D-01 , 0.4978399335051637D-02 , & 0.4648850508842540D-03 , 0.2365512855251058D-04 , 0.5884287563301031D-06 , & 0.5966990986059582D-08 , 0.1744339007548002D-10 , 0.6167183424403973D-14 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.4269311638686994D+00 , & 0.2861795353464496D+00 , 0.1277396217845544D+00 , 0.3744547050322967D-01 , & 0.7048355810072597D-02 , 0.8236924826884187D-03 , 0.5688691636404408D-04 , & 0.2158245704902338D-05 , 0.4018971174941502D-07 , 0.3046254269987586D-09 , & 0.6584620243078033D-12 , 0.1664368496489109D-15 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.4120436505903693D+00 , 0.2846322411767849D+00 , 0.1351133279117871D+00 , & 0.4359822721725066D-01 , 0.9397901291159602D-02 , 0.1319064722323852D-02 , & 0.1162297016031100D-03 , 0.6103291717396038D-05 , 0.1770106337397365D-06 , & 0.2524494034490502D-08 , 0.1460999933981618D-10 , 0.2383148659372185D-13 , & 0.4396916094753885D-17 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.3986047178264511D+00 , 0.2825613912593893D+00 , & 0.1413946097869542D+00 , 0.4951488928989775D-01 , 0.1196842321435477D-01 , & 0.1957331294408983D-02 , 0.2106181000240334D-03 , 0.1434550422971449D-04 , & 0.5857719720992975D-06 , 0.1325682501541730D-07 , 0.1475853168277706D-09 , & 0.6639436714909664D-12 , 0.8315937951206589D-15 , 0.1140139347903717D-18 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.3863948895418141D+00 , & 0.2801309308392122D+00 , 0.1467358475408903D+00 , 0.5514417687023410D-01 , & 0.1470382970482666D-01 , 0.2737922473067670D-02 , 0.3483101243186850D-03 , & 0.2938725228922972D-04 , 0.1579094887324712D-05 , 0.5108522450775928D-07 , & 0.9178580424378772D-09 , 0.8106186297462860D-11 , 0.2878607080548738D-13 , & 0.2810333602750910D-16 , 0.2908254700131270D-20 , 0.0000000000000000D+00 , & 0.3752383525928027D+00 , 0.2774581423025306D+00 , 0.1512697340766421D+00 , & 0.6045813095591175D-01 , 0.1755342883157332D-01 , 0.3654890326654427D-02 , & 0.5362683655279709D-03 , 0.5416584061819988D-04 , 0.3650585129562379D-05 , & 0.1574167792545589D-06 , 0.4098832164770857D-08 , 0.5933291463396614D-10 , & 0.4215010211326414D-12 , 0.1197344017092862D-14 , 0.9231736536518531D-18 , & 0.7310676427383964D-22 ], shape = [ mxdim , mxdim ]) real ( kind = 8 ), public , parameter :: rtsaux ( maux , 8 ) = reshape ([ & 0.3311423082817931D-01 , 0.5981277244514300D-01 , 0.1608687542003543D-01 , & 0.6470837188913184D-02 , 0.1925698896092918D-02 , 0.3245055060169843D-03 , & 0.1180403728976994D-04 , 0.9806101582803445D-01 , 0.1490786729242584D+00 , & 0.2132008165424501D+00 , 0.2897273376759475D+00 , 0.3768645240659037D+00 , & 0.4717671045434542D+00 , 0.5706797743959704D+00 , 0.6691679115546944D+00 , & 0.7624187818801862D+00 , 0.8455878090111316D+00 , 0.9141601271474185D+00 , & 0.9642964327839307D+00 , 0.9931404032223842D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.4459215012310767D-01 , 0.2663972894789983D-01 , & 0.1448902560832900D-01 , 0.6935339478525350D-02 , 0.2756670127399030D-02 , & 0.8129748816298266D-03 , 0.1361431404118938D-03 , 0.4935129360637439D-05 , & 0.6943153026591924D-01 , 0.1020252057162236D+00 , 0.1429343223834524D+00 , & 0.1923415868672259D+00 , 0.2499999999999999D+00 , 0.3152062794779362D+00 , & 0.3868012061044409D+00 , 0.4631975115256109D+00 , 0.5424342617116348D+00 , & 0.6222550803643302D+00 , 0.7002060974213685D+00 , 0.7737482886456865D+00 , & 0.8403779682393594D+00 , 0.8977486680056744D+00 , 0.9437875461106039D+00 , & 0.9768000645999300D+00 , 0.9955619049198584D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.3600009444917834D-01 , & 0.5367929502127710D-01 , 0.2282358087416106D-01 , 0.1348183025995716D-01 , & 0.7261957338041792D-02 , 0.3448006938362446D-02 , 0.1361608249860346D-02 , & 0.3995628201530626D-03 , 0.6668254930138793D-04 , 0.2412610298614493D-05 , & 0.7644291300781368D-01 , 0.1047477930875140D+00 , 0.1388915279581130D+00 , & 0.1789840307741864D+00 , 0.2249264163663510D+00 , 0.2763982589216690D+00 , & 0.3328539443827702D+00 , 0.3935284541260027D+00 , 0.4574525186183916D+00 , & 0.5234766825459025D+00 , 0.5903034431632973D+00 , 0.6565262774384205D+00 , & 0.7206740756674773D+00 , 0.7812592623647830D+00 , 0.8368277197208105D+00 , & 0.8860085427304147D+00 , 0.9275616556791347D+00 , 0.9604214277884603D+00 , & 0.9837348058290485D+00 , 0.9968958966849477D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.4398555195277359D-01 , 0.3058574876834499D-01 , 0.6092930105499368D-01 , & 0.2033269213059855D-01 , 0.1279045049262753D-01 , 0.7503899366138534D-02 , & 0.4018347564842567D-02 , 0.1898594940807536D-02 , 0.7467882061060832D-03 , & 0.2184836363610052D-03 , 0.3638644488856184D-04 , 0.1314956323727580D-05 , & 0.8175666785532240D-01 , 0.1067323821680571D+00 , 0.1360307958356441D+00 , & 0.1697229634514230D+00 , 0.2077667019402563D+00 , 0.2499999999999998D+00 , & 0.2961380452159158D+00 , 0.3457740246174122D+00 , 0.3983837370449402D+00 , & 0.4533339365988709D+00 , 0.5098942093731368D+00 , 0.5672520742964827D+00 , & 0.6245308967025374D+00 , 0.6808101134342349D+00 , 0.7351471936872270D+00 , & 0.7866007027795398D+00 , 0.8342537984583634D+00 , 0.8772374725900651D+00 , & 0.9147528563001249D+00 , 0.9460919364139329D+00 , 0.9706560996755904D+00 , & 0.9879721508887392D+00 , 0.9977078840559234D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.3752862210285295D-01 , 0.5074496784251226D-01 , & 0.2690310419233024D-01 , 0.6680265670059675D-01 , 0.1858883348816642D-01 , & 0.1228709604735500D-01 , 0.7690217393316887D-02 , 0.4491713694776070D-02 , & 0.2396160899229440D-02 , 0.1128529682849472D-02 , 0.4427485262711727D-03 , & 0.1292774686851154D-03 , 0.2150066216486457D-04 , 0.7764167660645311D-06 , & 0.8591370530679703D-01 , 0.1082429441270552D+00 , 0.1339003060774142D+00 , & 0.1629342990513548D+00 , 0.1953268425285067D+00 , 0.2309896163367905D+00 , & 0.2697620338428412D+00 , 0.3114109132037622D+00 , 0.3556318797527262D+00 , & 0.4020524910846677D+00 , 0.4502370349528138D+00 , 0.4996929096784019D+00 , & 0.5498784583867753D+00 , 0.6002120929376404D+00 , 0.6500825117708330D+00 , & 0.6988597888065096D+00 , 0.7459070886780932D+00 , 0.7905927474738742D+00 , & 0.8323024482266286D+00 , 0.8704512169070354D+00 , 0.9044949678681030D+00 , & 0.9339413379615261D+00 , 0.9583595677400624D+00 , 0.9773892274524588D+00 , & 0.9907477393616217D+00 , 0.9982384861273251D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.4364961121395911D-01 , & 0.5648398190166988D-01 , 0.3296886428003663D-01 , 0.2425468583739952D-01 , & 0.1730423844079668D-01 , 0.1190452155752850D-01 , 0.7838072567300970D-02 , & 0.4888633282362963D-02 , 0.2846666829304473D-02 , 0.1514613186770935D-02 , & 0.7117772849514748D-03 , 0.2787512336375375D-03 , 0.8128180937639950D-04 , & 0.1350563070652586D-04 , 0.4874516944821551D-06 , 0.7163782758885393D-01 , & 0.8925068302442711D-01 , 0.1094310699873910D+00 , 0.1322523159580150D+00 , & 0.1577489776219076D+00 , 0.1859139476909168D+00 , 0.2166963107764356D+00 , & 0.2499999999999997D+00 , 0.2856832909395797D+00 , 0.3235591536741699D+00 , & 0.3633964674051715D+00 , 0.4049220857103925D+00 , 0.4478237242379931D+00 , & 0.4917536268829691D+00 , 0.5363329515084886D+00 , 0.5811568023645853D+00 , & 0.6257998237833122D+00 , 0.6698222587332601D+00 , 0.7127763666085998D+00 , & 0.7542130873862868D+00 , 0.7936888341514342D+00 , 0.8307722930693874D+00 , & 0.8650511092430273D+00 , 0.8961383385825462D+00 , 0.9236785499057714D+00 , & 0.9473534682805803D+00 , 0.9668870616305321D+00 , 0.9820499968439161D+00 , & 0.9926635040779103D+00 , 0.9986041326336311D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.4902719181508489D-01 , 0.3847424833481418D-01 , 0.2960181058194297D-01 , & 0.6139043253713792D-01 , 0.2226773223374810D-01 , 0.1632079039873591D-01 , & 0.1160404728431016D-01 , 0.7958239359710731D-02 , 0.5225137891769632D-02 , & 0.3250825423481754D-02 , 0.1888834328260073D-02 , 0.1003095980873591D-02 , & 0.4706523012354059D-03 , 0.1840853989094785D-03 , 0.5362571351821748D-04 , & 0.8904347214872945D-05 , 0.3212597347084014D-06 , 0.7567826725867491D-01 , & 0.9198654925267620D-01 , 0.1103899809594068D+00 , 0.1309396946157232D+00 , & 0.1536611631576847D+00 , 0.1785524787184205D+00 , 0.2055830304726597D+00 , & 0.2346926074980837D+00 , 0.2657909458252721D+00 , 0.2987577320327461D+00 , & 0.3334430687165666D+00 , 0.3696684000337266D+00 , 0.4072278883952550D+00 , & 0.4458902263788443D+00 , 0.4854008611502410D+00 , 0.5254846022327136D+00 , & 0.5658485774446024D+00 , 0.6061854963297351D+00 , 0.6461771755197649D+00 , & 0.6854982762673824D+00 , 0.7238202009405706D+00 , 0.7608150926248051D+00 , & 0.7961598801847096D+00 , 0.8295403102190463D+00 , 0.8606549073217162D+00 , & 0.8892188049470944D+00 , 0.9149673909840519D+00 , 0.9376597149257520D+00 , & 0.9570816075440438D+00 , 0.9730484705056013D+00 , 0.9854077097615248D+00 , & 0.9940408737793049D+00 , 0.9988667256798059D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.4343624158117879D-01 , 0.5375839047537360D-01 , & 0.3455983018026716D-01 , 0.2702670399540115D-01 , 0.2072687140681374D-01 , & 0.1554487095139011D-01 , 0.6561918588455740D-01 , 0.1136187779405652D-01 , & 0.8057818189945613D-02 , 0.5513462965948451D-02 , 0.3612471437300600D-02 , & 0.2243357933571111D-02 , 0.1301354228704902D-02 , 0.6901426368777302D-03 , & 0.3234363306937525D-03 , 0.1263855374816439D-03 , 0.3679064690900260D-04 , & 0.6105895739168861D-05 , 0.2202333083263958D-06 , 0.7910008312146158D-01 , & 0.9426929356479725D-01 , 0.1111801399767667D+00 , 0.1298695808908628D+00 , & 0.1503569255021147D+00 , 0.1726427581138337D+00 , 0.1967080885645231D+00 , & 0.2225137422094791D+00 , 0.2500000000000002D+00 , 0.2790864960278161D+00 , & 0.3096723766238527D+00 , 0.3416367217607065D+00 , 0.3748392261499602D+00 , & 0.4091211340916689D+00 , 0.4443064188667903D+00 , 0.4802031943057769D+00 , & 0.5166053431586364D+00 , 0.5532943440720315D+00 , 0.5900412763837164D+00 , & 0.6266089796072110D+00 , 0.6627543424301952D+00 , 0.6982306943152268D+00 , & 0.7327902713934512D+00 , 0.7661867272994123D+00 , 0.7981776589216788D+00 , & 0.8285271167492663D+00 , 0.8570080695831021D+00 , 0.8834047938571962D+00 , & 0.9075151586775710D+00 , 0.9291527789494963D+00 , 0.9481490106780879D+00 , & 0.9643547649238285D+00 , 0.9776421210414711D+00 , 0.9879057318457978D+00 , & 0.9950640837431507D+00 , 0.9990616397981268D+00 ], shape = [ maux , 8 ]) real ( kind = 8 ), public , parameter :: wtsaux ( maux , 8 ) = reshape ([ & 0.5909726598075888D-01 , 0.6584431922458862D-01 , 0.5096505990862041D-01 , & 0.4163837078835225D-01 , 0.3133602416705433D-01 , 0.2030071490019332D-01 , & 0.8807003569576349D-02 , 0.7104805465919128D-01 , 0.7458649323630183D-01 , & 0.7637669356536272D-01 , 0.7637669356536346D-01 , 0.7458649323630144D-01 , & 0.7104805465919112D-01 , 0.6584431922458830D-01 , 0.5909726598076000D-01 , & 0.5096505990862025D-01 , 0.4163837078835227D-01 , 0.3133602416705442D-01 , & 0.2030071490019355D-01 , 0.8807003569576227D-02 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.5026797453352529D-01 , 0.4551413099148229D-01 , & 0.4007035016750040D-01 , 0.3401916690617832D-01 , 0.2745234798791782D-01 , & 0.2046957835065303D-01 , 0.1317749330751579D-01 , 0.5696899250513485D-02 , & 0.5425981223713152D-01 , 0.5742912957285592D-01 , 0.5972788176789209D-01 , & 0.6112122149515455D-01 , 0.6158802686335779D-01 , 0.6112122149515536D-01 , & 0.5972788176789246D-01 , 0.5742912957285590D-01 , 0.5425981223713182D-01 , & 0.5026797453352500D-01 , 0.4551413099148207D-01 , 0.4007035016750037D-01 , & 0.3401916690617897D-01 , 0.2745234798791809D-01 , 0.2046957835065275D-01 , & 0.1317749330751527D-01 , 0.5696899250513537D-02 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.4037794761470943D-01 , & 0.4344989360054208D-01 , 0.3687798736885270D-01 , 0.3298711494109012D-01 , & 0.2874657810880918D-01 , 0.2420133641529743D-01 , 0.1939959628481344D-01 , & 0.1439235394166157D-01 , 0.9233234155545691D-02 , 0.3984096248083391D-02 , & 0.4606126111889302D-01 , 0.4818436858732206D-01 , 0.4979671029339763D-01 , & 0.5088119487420216D-01 , 0.5142632644677943D-01 , 0.5142632644677995D-01 , & 0.5088119487420249D-01 , 0.4979671029339827D-01 , 0.4818436858732192D-01 , & 0.4606126111889324D-01 , 0.4344989360054120D-01 , 0.4037794761471003D-01 , & 0.3687798736885173D-01 , 0.3298711494109043D-01 , 0.2874657810880946D-01 , & 0.2420133641529735D-01 , 0.1939959628481361D-01 , 0.1439235394166174D-01 , & 0.9233234155545632D-02 , 0.3984096248083247D-02 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.3602239738628011D-01 , 0.3361114263454359D-01 , 0.3815172857772094D-01 , & 0.3093683598304008D-01 , 0.2802040810618503D-01 , 0.2488468520067677D-01 , & 0.2155421116308512D-01 , 0.1805505793173160D-01 , 0.1441463005444643D-01 , & 0.1066148995574242D-01 , 0.6825414174180503D-02 , 0.2941716710221880D-02 , & 0.3998247112116213D-01 , 0.4150029686442836D-01 , 0.4269332669604951D-01 , & 0.4355222349859141D-01 , 0.4407026521513794D-01 , 0.4424339745355207D-01 , & 0.4407026521513754D-01 , 0.4355222349859152D-01 , 0.4269332669604975D-01 , & 0.4150029686442849D-01 , 0.3998247112116278D-01 , 0.3815172857772100D-01 , & 0.3602239738628051D-01 , 0.3361114263454346D-01 , 0.3093683598304035D-01 , & 0.2802040810618515D-01 , 0.2488468520067681D-01 , 0.2155421116308484D-01 , & 0.1805505793173228D-01 , 0.1441463005444692D-01 , 0.1066148995574185D-01 , & 0.6825414174181070D-02 , 0.2941716710221409D-02 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.3065312124646436D-01 , 0.3240200672830060D-01 , & 0.2871988454969593D-01 , 0.3395602290761694D-01 , 0.2661392349196827D-01 , & 0.2434790381753858D-01 , 0.2193545409283397D-01 , 0.1939108398723607D-01 , & 0.1673009764127369D-01 , 0.1396850349001161D-01 , 0.1112292459708341D-01 , & 0.8210529190954175D-02 , 0.5249142265576177D-02 , 0.2260638549266816D-02 , & 0.3530582369564367D-01 , 0.3644329119790184D-01 , 0.3736158452898425D-01 , & 0.3805518095031275D-01 , 0.3851990908212372D-01 , 0.3875297398921261D-01 , & 0.3875297398921173D-01 , 0.3851990908212474D-01 , 0.3805518095031294D-01 , & 0.3736158452898516D-01 , 0.3644329119790151D-01 , 0.3530582369564279D-01 , & 0.3395602290761690D-01 , 0.3240200672830062D-01 , 0.3065312124646425D-01 , & 0.2871988454969628D-01 , 0.2661392349196852D-01 , 0.2434790381753621D-01 , & 0.2193545409283680D-01 , 0.1939108398723554D-01 , 0.1673009764127440D-01 , & 0.1396850349001189D-01 , 0.1112292459708395D-01 , 0.8210529190953284D-02 , & 0.5249142265576468D-02 , 0.2260638549266104D-02 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.2806743937989311D-01 , & 0.2938711635942114D-01 , 0.2661400836563443D-01 , 0.2503374961897618D-01 , & 0.2333419385918702D-01 , 0.2152344035458202D-01 , 0.1961011836465203D-01 , & 0.1760334610080350D-01 , 0.1551268746725794D-01 , 0.1334810698378866D-01 , & 0.1111992377528920D-01 , 0.8838767628969348D-02 , 0.6515552495791421D-02 , & 0.4161594648109023D-02 , 0.1791331577641875D-02 , 0.3056675041553340D-01 , & 0.3160072003690959D-01 , 0.3248409787536193D-01 , 0.3321267422492125D-01 , & 0.3378297708180428D-01 , 0.3419228868933463D-01 , 0.3443865848883079D-01 , & 0.3452091241461568D-01 , 0.3443865848883113D-01 , 0.3419228868933424D-01 , & 0.3378297708180292D-01 , 0.3321267422492117D-01 , 0.3248409787536162D-01 , & 0.3160072003691082D-01 , 0.3056675041553352D-01 , 0.2938711635942091D-01 , & 0.2806743937989297D-01 , 0.2661400836563448D-01 , 0.2503374961897604D-01 , & 0.2333419385918714D-01 , 0.2152344035458233D-01 , 0.1961011836465042D-01 , & 0.1760334610080437D-01 , 0.1551268746725816D-01 , 0.1334810698378838D-01 , & 0.1111992377529002D-01 , 0.8838767628968630D-02 , 0.6515552495791605D-02 , & 0.4161594648109016D-02 , 0.1791331577641597D-02 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.2582785153479077D-01 , 0.2470046922473299D-01 , 0.2347752565197435D-01 , & 0.2685531094449798D-01 , 0.2216375216940157D-01 , 0.2076423154507500D-01 , & 0.1928437830629284D-01 , 0.1772991780757497D-01 , 0.1610686411178732D-01 , & 0.1442149679026786D-01 , 0.1268033678500444D-01 , 0.1089012158506380D-01 , & 0.9057780356744979D-02 , 0.7190411380742174D-02 , 0.5295274191826010D-02 , & 0.3379899597872772D-02 , 0.1454311276577341D-02 , 0.2777887240310640D-01 , & 0.2859496282386398D-01 , 0.2930042490661166D-01 , 0.2989252935213247D-01 , & 0.3036898542088475D-01 , 0.3072794979515820D-01 , 0.3096803371034183D-01 , & 0.3108830832767347D-01 , 0.3108830832767407D-01 , 0.3096803371034139D-01 , & 0.3072794979515868D-01 , 0.3036898542088479D-01 , 0.2989252935213276D-01 , & 0.2930042490661133D-01 , 0.2859496282386403D-01 , 0.2777887240310611D-01 , & 0.2685531094449840D-01 , 0.2582785153478988D-01 , 0.2470046922473255D-01 , & 0.2347752565197456D-01 , 0.2216375216940185D-01 , 0.2076423154507295D-01 , & 0.1928437830629468D-01 , 0.1772991780757407D-01 , 0.1610686411178809D-01 , & 0.1442149679026780D-01 , 0.1268033678500648D-01 , 0.1089012158506232D-01 , & 0.9057780356744797D-02 , 0.7190411380742838D-02 , 0.5295274191825420D-02 , & 0.3379899597872453D-02 , 0.1454311276577576D-02 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.0000000000000000D+00 , 0.0000000000000000D+00 , & 0.0000000000000000D+00 , 0.2299018197314214D-01 , 0.2388714927560028D-01 , & 0.2201957021080317D-01 , 0.2097842315885948D-01 , 0.1987007593716820D-01 , & 0.1869807893398359D-01 , 0.2470759885577663D-01 , 0.1746618643679334D-01 , & 0.1617834461309376D-01 , 0.1483867888257975D-01 , 0.1345148072819935D-01 , & 0.1202119400486185D-01 , 0.1055240083400823D-01 , 0.9049807260364221D-02 , & 0.7518229166756075D-02 , 0.5962580359924479D-02 , 0.4387873053529027D-02 , & 0.2799316133280325D-02 , 0.1204161809990090D-02 , 0.2544890256224712D-01 , & 0.2610868577281617D-01 , 0.2668483500080304D-01 , 0.2717550466495542D-01 , & 0.2757912300125436D-01 , 0.2789439709764200D-01 , 0.2812031703554178D-01 , & 0.2825615912488630D-01 , 0.2830148822227995D-01 , 0.2825615912488606D-01 , & 0.2812031703554219D-01 , 0.2789439709764192D-01 , 0.2757912300125449D-01 , & 0.2717550466495561D-01 , 0.2668483500080322D-01 , 0.2610868577281601D-01 , & 0.2544890256224744D-01 , 0.2470759885577558D-01 , 0.2388714927560043D-01 , & 0.2299018197314154D-01 , 0.2201957021080389D-01 , 0.2097842315885954D-01 , & 0.1987007593716834D-01 , 0.1869807893398267D-01 , 0.1746618643679476D-01 , & 0.1617834461309308D-01 , 0.1483867888258053D-01 , 0.1345148072819702D-01 , & 0.1202119400486354D-01 , 0.1055240083400783D-01 , 0.9049807260364362D-02 , & 0.7518229166755907D-02 , 0.5962580359924624D-02 , 0.4387873053529463D-02 , & 0.2799316133280401D-02 , 0.1204161809989695D-02 ], shape = [ maux , 8 ]) end module rys_lut","tags":"","url":"sourcefile/rys_lut.f90.html"},{"title":"tdhf_mrsf_gradient.F90 – OpenQP Fortran API","text":"Source Code module tdhf_mrsf_gradient_mod use precision , only : dp use grd2 , only : grd2_driver , grd2_compute_data_t use basis_tools , only : basis_set , bas_norm_matrix , build_cart_density use constants , only : HARMONIC_ACTIVE , NUM_CART_BF use printing , only : print_module_info implicit none character ( len =* ), parameter :: module_name = \"tdhf_mrsf_gradient_mod\" public tdhf_mrsf_gradient type , extends ( grd2_compute_data_t ) :: grd2_mrsf_compute_data_t real ( kind = dp ), pointer :: d2 (:,:,:) => null () real ( kind = dp ), pointer :: p2 (:,:,:) => null () real ( kind = dp ), pointer :: spc2 (:,:,:) => null () ! Cartesian-effective (bfnrm-folded) copies + offsets for HARMONIC_ACTIVE: ! d/p (alpha,beta) and the seven spin-pair-coupling densities. real ( kind = dp ), allocatable :: d2a_c (:,:), d2b_c (:,:), p2a_c (:,:), p2b_c (:,:) real ( kind = dp ), allocatable :: ball_c (:,:), bo2v_c (:,:), bo1v_c (:,:), bco1_c (:,:), & bco2_c (:,:), o21v_c (:,:), co12_c (:,:) integer , allocatable :: cart_off (:) integer :: nbf = 0 integer :: mrst = 1 real ( kind = dp ), dimension ( 3 ) :: spcscale = [ 0.0_dp , 0.0_dp , 0.0_dp ] contains procedure :: init => grd2_mrsf_compute_data_t_init procedure :: clean => grd2_mrsf_compute_data_t_clean procedure :: get_density => grd2_mrsf_compute_data_t_get_density procedure :: build_cart => grd2_mrsf_build_cart end type contains subroutine tdhf_mrsf_gradient_C ( c_handle ) bind ( C , name = \"tdhf_mrsf_gradient\" ) use c_interop , only : oqp_handle_t , oqp_handle_get_info use types , only : information type ( oqp_handle_t ) :: c_handle type ( information ), pointer :: inf inf => oqp_handle_get_info ( c_handle ) call tdhf_mrsf_gradient ( inf ) end subroutine tdhf_mrsf_gradient_c subroutine tdhf_mrsf_gradient ( infos ) use io_constants , only : iw use oqp_tagarray_driver use types , only : information use strings , only : Cstring , fstring use basis_tools , only : basis_set use messages , only : show_message , with_abort use grd1 , only : eijden , print_gradient use util , only : measure_time use dft , only : dft_initialize , dftclean use mathlib , only : symmetrize_matrix use mod_dft_molgrid , only : dft_grid_t use mod_dft_gridint_tdxc_grad , only : utddft_xc_gradient use mathlib , only : unpack_matrix use tdhf_sf_gradient_mod , only : sf_1e_grad , sf_2e_grad use tdhf_sf_lib , only : mrsf_state_label implicit none character ( len =* ), parameter :: subroutine_name = \"tdhf_mrsf_gradient\" type ( basis_set ), pointer :: basis type ( information ), target , intent ( inout ) :: infos integer :: s_size integer :: nbf , nbf2 integer :: mrst character ( len = 12 ) :: target_label character ( len = 16 ) :: method_name logical :: roref = . false . type ( dft_grid_t ) :: molGrid ! General data logical :: dft integer :: scf_type , mol_mult real ( kind = dp ), allocatable :: p (:,:,:), v (:,:,:), d (:,:,:), spc (:,:,:) ! tagarray real ( kind = dp ), contiguous , pointer :: dmat_a (:), dmat_b (:), td_mrsf_density (:,:,:), td_abxc (:,:), td_p (:,:) character ( len =* ), parameter :: tags_general ( * ) = ( / character ( len = 80 ) :: & OQP_DM_A , OQP_DM_B , OQP_td_abxc , OQP_td_p / ) character ( len =* ), parameter :: tags_mrsf ( 1 ) = ( / character ( len = 80 ) :: & OQP_td_mrsf_density / ) dft = infos % control % hamilton == 20 if ( dft ) then method_name = 'MRSF-TDDFT' else method_name = 'MRSF-TDHF' end if mol_mult = infos % mol_prop % mult if ( mol_mult /= 3 ) call show_message (& 'MRSF requires a triplet ROHF/UHF internal reference (mult=3).' , with_abort ) scf_type = infos % control % scftype if ( scf_type == 3 ) roref = . true . mrst = infos % tddft % mult target_label = mrsf_state_label ( mrst , infos % tddft % target_state ) ! Files open open ( unit = iw , file = infos % log_filename , position = \"append\" ) ! call print_module_info ( 'MRSF_Grad' , 'Computing Gradient of ' // trim ( method_name )) ! write ( iw , '(/5X,\"Gradient options\"/& &5X,18(\"-\")/& &5X,\"Physical target state: \",A/& &5X,\"Internal response root: \",I8/)' )& & trim ( target_label ), infos % tddft % target_state ! Load basis set basis => infos % basis basis % atoms => infos % atoms ! Input parameters ! Allocate H, S ,T and D matrices nbf = basis % nbf nbf2 = nbf * ( nbf + 1 ) / 2 s_size = ( basis % nshell ** 2 + basis % nshell ) / 2 !   Compute 1e gradient call flush ( iw ) call sf_1e_grad ( infos , basis ) write ( iw , \"(' ..... End Of 1-Eelectron Gradient ......')\" ) call measure_time ( print_total = 1 , log_unit = iw ) call flush ( iw ) allocate ( v ( nbf , nbf , 2 ), source = 0.0d0 ) allocate ( d ( nbf , nbf , 2 ), source = 0.0d0 ) allocate ( p ( nbf , nbf , 2 ), source = 0.0d0 ) allocate ( spc ( 7 , nbf , nbf ), source = 0.0d0 ) call data_has_tags ( infos % dat , tags_general , module_name , subroutine_name , WITH_ABORT ) call tagarray_get_data ( infos % dat , OQP_DM_A , dmat_a ) call tagarray_get_data ( infos % dat , OQP_DM_B , dmat_b ) call tagarray_get_data ( infos % dat , OQP_td_abxc , td_abxc ) call tagarray_get_data ( infos % dat , OQP_td_p , td_p ) if ( mrst == 1 . or . mrst == 3 ) then call data_has_tags ( infos % dat , tags_mrsf , module_name , subroutine_name , WITH_ABORT ) call tagarray_get_data ( infos % dat , OQP_td_mrsf_density , td_mrsf_density ) endif call unpack_matrix ( td_p (:, 1 ), p (:,:, 1 )) call unpack_matrix ( td_p (:, 2 ), p (:,:, 2 )) call unpack_matrix ( dmat_a , d (:,:, 1 )) call unpack_matrix ( dmat_b , d (:,:, 2 )) v (:,:, 1 ) = td_abxc if ( mrst == 1 . or . mrst == 3 ) then spc ( 1 : 7 ,:,:) = td_mrsf_density end if !   Compute xc gradient if ( dft ) then call dft_initialize ( infos , basis , molGrid , verbose = . true .) call utddft_xc_gradient ( basis = basis , & molGrid = molGrid , & dedft = infos % atoms % grad , & da = d (:,:, 1 ), & db = d (:,:, 2 ), & pa = p (:,:, 1 : 1 ), & pb = p (:,:, 2 : 2 ), & nmtx = 1 , & !threshold=1.0d-15, & threshold = 0.0d0 , & infos = infos ) call dftclean ( infos ) call measure_time ( print_total = 1 , log_unit = iw ) call flush ( iw ) end if !   Compute 2e gradient if ( mrst == 1 . or . mrst == 3 ) then call mrsf_2e_grad ( basis , infos , d , p , spc , v (:,:, 1 )) else if ( mrst == 5 ) then call sf_2e_grad ( basis , infos , d , p , v (:,:, 1 )) end if call print_gradient ( infos ) !   Print timings call measure_time ( print_total = 1 , log_unit = iw ) close ( iw ) end subroutine tdhf_mrsf_gradient !############################################################################### ! @brief The driver for the two electron gradient subroutine mrsf_2e_grad ( basis , infos , d , p , spc , v ) use basis_tools , only : basis_set use precision , only : dp use messages , only : show_message , WITH_ABORT use types , only : information implicit none type ( information ), target , intent ( inout ) :: infos type ( basis_set ) :: basis real ( kind = dp ), contiguous , target :: p (:,:,:), d (:,:,:), spc (:,:,:), v (:,:) logical :: urohf , dft character ( len = 16 ) :: method_name real ( kind = dp ) :: scale_exch ! HF scale in Reference real ( kind = dp ) :: scale_exch2 ! HF scale in Response integer :: ok real ( kind = dp ), allocatable :: de (:,:) class ( grd2_compute_data_t ), allocatable :: gcomp dft = infos % control % hamilton == 20 ! dft or hf if ( dft ) then method_name = 'MRSF-TDDFT' else method_name = 'MRSF-TDHF' end if urohf = infos % control % scftype >= 2 scale_exch = 1.0_dp scale_exch2 = 1.0_dp if ( dft ) then scale_exch = infos % dft % HFscale scale_exch2 = infos % tddft % HFscale end if allocate ( de ( 3 , ubound ( infos % atoms % zn , 1 )), & source = 0.0d0 , & stat = ok ) if ( ok /= 0 ) call show_message ( 'cannot allocate memory' , WITH_ABORT ) write ( * , '(/7x,\"Fitting parameters for \",A)' ) trim ( method_name ) if (. not . infos % dft % cam_flag ) then write ( * , '(10x,\"Exact HF exchange:\")' ) write ( * , '(5x,\"Reference: |\", t20, f6.3, t29, \"|\")' ) scale_exch write ( * , '(5x,\"Response:  |\", t20, f6.3, t29, \"|\")' ) scale_exch2 else write ( * , '(10x,\"CAM parametres:\")' ) write ( * , '(16x,\"|   alpha   |    beta   |     mu    |\")' ) write ( * , '(5x,\"Reference: |\", t20, f6.3, t29, \"|\", t32, f6.3, t41, \"|\", t44, f6.3, t53, \"|\")' ) & infos % dft % cam_alpha , infos % dft % cam_beta , infos % dft % cam_mu write ( * , '(5x,\"Response:  |\", t20, f6.3, t29, \"|\", t32, f6.3, t41, \"|\", t44, f6.3, t53, \"|\")' ) & infos % tddft % cam_alpha , infos % tddft % cam_beta , infos % tddft % cam_mu end if write ( * , '(10x,\"Spin-pair coupling parametres:\")' ) write ( * , '(16x,\"|   CO-CO   |   OV-OV   |   CO-OV   |\")' ) write ( * , '(16x,\"|\", t20, f6.3, t29, \"|\", t32, f6.3, t41, \"|\", t44, f6.3, t53, \"|\")' ) & infos % tddft % spc_coco , infos % tddft % spc_ovov , infos % tddft % spc_coov gcomp = grd2_mrsf_compute_data_t ( d2 = d & , p2 = p & , spc2 = spc & , nbf = basis % nbf & , hfscale = scale_exch & , hfscale2 = scale_exch2 & , spcscale = [ infos % tddft % spc_coco , & infos % tddft % spc_ovov , & infos % tddft % spc_coov ] & , mrst = infos % tddft % mult ) call gcomp % init () select type ( gcomp ) class is ( grd2_mrsf_compute_data_t ) call gcomp % build_cart ( basis ) end select call grd2_driver ( infos , basis , de , gcomp , & cam = dft . and . infos % dft % cam_flag , & alpha = infos % tddft % cam_alpha , & beta = infos % tddft % cam_beta , & mu = infos % tddft % cam_mu ) infos % atoms % grad = infos % atoms % grad + de call gcomp % clean () end subroutine !############################################################################### subroutine grd2_mrsf_compute_data_t_init ( this ) implicit none class ( grd2_mrsf_compute_data_t ), target , intent ( inout ) :: this call this % clean () this % d2 (:,:, 1 ) = this % d2 (:,:, 1 ) + this % d2 (:,:, 2 ) this % d2 (:,:, 2 ) = this % d2 (:,:, 1 ) - 2 * this % d2 (:,:, 2 ) this % p2 (:,:, 1 ) = this % p2 (:,:, 1 ) + this % p2 (:,:, 2 ) this % p2 (:,:, 2 ) = this % p2 (:,:, 1 ) - 2 * this % p2 (:,:, 2 ) end subroutine !############################################################################### ! @brief Cartesian-effective copies of the MRSF gradient densities (d/p alpha !   and beta + the seven spin-pair-coupling densities) for HARMONIC_ACTIVE. !   Call AFTER init (which combines the spin densities). The spc densities may !   be non-symmetric; the per-block expansion handles that. subroutine grd2_mrsf_build_cart ( this , basis ) class ( grd2_mrsf_compute_data_t ), intent ( inout ) :: this type ( basis_set ), intent ( in ) :: basis integer , allocatable :: od (:) integer :: nc if (. not . HARMONIC_ACTIVE ) return call mrsf_cart_one ( basis , this % d2 (:,:, 1 ), this % d2a_c , this % cart_off , nc ) call mrsf_cart_one ( basis , this % d2 (:,:, 2 ), this % d2b_c , od , nc ) call mrsf_cart_one ( basis , this % p2 (:,:, 1 ), this % p2a_c , od , nc ) call mrsf_cart_one ( basis , this % p2 (:,:, 2 ), this % p2b_c , od , nc ) call mrsf_cart_one ( basis , this % spc2 ( 7 ,:,:), this % ball_c , od , nc ) call mrsf_cart_one ( basis , this % spc2 ( 1 ,:,:), this % bo2v_c , od , nc ) call mrsf_cart_one ( basis , this % spc2 ( 2 ,:,:), this % bo1v_c , od , nc ) call mrsf_cart_one ( basis , this % spc2 ( 3 ,:,:), this % bco1_c , od , nc ) call mrsf_cart_one ( basis , this % spc2 ( 4 ,:,:), this % bco2_c , od , nc ) call mrsf_cart_one ( basis , this % spc2 ( 5 ,:,:), this % o21v_c , od , nc ) call mrsf_cart_one ( basis , this % spc2 ( 6 ,:,:), this % co12_c , od , nc ) end subroutine grd2_mrsf_build_cart subroutine mrsf_cart_one ( basis , m , m_cart , off , nc ) type ( basis_set ), intent ( in ) :: basis real ( kind = dp ), intent ( in ) :: m (:,:) real ( kind = dp ), allocatable , intent ( out ) :: m_cart (:,:) integer , allocatable , intent ( out ) :: off (:) integer , intent ( out ) :: nc real ( kind = dp ), allocatable :: tmp (:,:) tmp = m call bas_norm_matrix ( tmp , basis % bfnrm , basis % nbf ) call build_cart_density ( basis , tmp , m_cart , off , nc ) end subroutine mrsf_cart_one !############################################################################### subroutine grd2_mrsf_compute_data_t_clean ( this ) implicit none class ( grd2_mrsf_compute_data_t ), target , intent ( inout ) :: this end subroutine !############################################################################### ! @brief This routine forms the product of density !        matrices for use in forming the two electron !        gradient. Valid for closed and open shell SCF. subroutine grd2_mrsf_compute_data_t_get_density ( this , basis , id , dab , dabmax ) implicit none class ( grd2_mrsf_compute_data_t ), target , intent ( inout ) :: this type ( basis_set ), intent ( in ) :: basis integer , intent ( in ) :: id ( 4 ) real ( kind = dp ), target , intent ( out ) :: dab ( * ) real ( kind = dp ), intent ( out ) :: dabmax real ( kind = dp ) :: xcfact , xcfact2 , coulfact , df1 , dq1 , dt2 , bfn real ( kind = dp ) :: qfspcp1 , qfspcp2 , qfspcp3 , sgnk real ( kind = dp ) :: db1 , db2 , dc1 , dc2 , dc3 , dc4 , dd1 , dd2 , dd3 , dd4 real ( kind = dp ), pointer , dimension (:,:) :: & ball , bo2v , bo1v , bco1 , bco2 , co12 , o21v , & d2a , d2b , p2a , p2b logical :: usecart integer :: i , j , k , l integer :: loc ( 4 ) integer :: nbf ( 4 ) real ( kind = dp ), pointer :: ab (:,:,:,:) integer :: i1 , j1 , k1 , l1 coulfact = 4 * this % coulscale xcfact = this % hfscale xcfact2 = this % hfscale2 qfspcp1 = this % spcscale ( 1 ) qfspcp2 = this % spcscale ( 2 ) qfspcp3 = this % spcscale ( 3 ) sgnk = 1.0_dp if ( this % mrst == 3 ) sgnk = - 1.0_dp dabmax = 0 usecart = HARMONIC_ACTIVE if ( usecart ) then d2a => this % d2a_c ; d2b => this % d2b_c ; p2a => this % p2a_c ; p2b => this % p2b_c ball => this % ball_c ; bo2v => this % bo2v_c ; bo1v => this % bo1v_c bco1 => this % bco1_c ; bco2 => this % bco2_c ; o21v => this % o21v_c ; co12 => this % co12_c loc = this % cart_off ( id ) - 1 nbf = NUM_CART_BF ( basis % am ( id )) else d2a => this % d2 (:,:, 1 ); d2b => this % d2 (:,:, 2 ) p2a => this % p2 (:,:, 1 ); p2b => this % p2 (:,:, 2 ) ball => this % spc2 ( 7 ,:,:) bo2v => this % spc2 ( 1 ,:,:); bo1v => this % spc2 ( 2 ,:,:) bco1 => this % spc2 ( 3 ,:,:); bco2 => this % spc2 ( 4 ,:,:) o21v => this % spc2 ( 5 ,:,:); co12 => this % spc2 ( 6 ,:,:) loc = basis % ao_offset ( id ) - 1 nbf = basis % naos ( id ) end if ab ( 1 : nbf ( 4 ), 1 : nbf ( 3 ), 1 : nbf ( 2 ), 1 : nbf ( 1 )) => dab ( 1 : product ( nbf )) do i = 1 , nbf ( 1 ) i1 = loc ( 1 ) + i do j = 1 , nbf ( 2 ) j1 = loc ( 2 ) + j do k = 1 , nbf ( 3 ) k1 = loc ( 3 ) + k do l = 1 , nbf ( 4 ) l1 = loc ( 4 ) + l df1 = ( d2a ( i1 , j1 ) + p2a ( i1 , j1 )) * d2a ( k1 , l1 ) & + d2a ( i1 , j1 ) * p2a ( k1 , l1 ) df1 = df1 * coulfact if ( xcfact /= 0.0_dp . or . xcfact2 /= 0.0_dp ) then dq1 = ( d2a ( i1 , k1 ) + p2a ( i1 , k1 )) * d2a ( j1 , l1 ) & + d2a ( i1 , k1 ) * p2a ( j1 , l1 ) & + ( d2a ( i1 , l1 ) + p2a ( i1 , l1 )) * d2a ( j1 , k1 ) & + d2a ( i1 , l1 ) * p2a ( j1 , k1 ) & + ( d2b ( i1 , k1 ) + p2b ( i1 , k1 )) * d2b ( j1 , l1 ) & + d2b ( i1 , k1 ) * p2b ( j1 , l1 ) & + ( d2b ( i1 , l1 ) + p2b ( i1 , l1 )) * d2b ( j1 , k1 ) & + d2b ( i1 , l1 ) * p2b ( j1 , k1 ) dt2 = ball ( i1 , k1 ) * ball ( j1 , l1 ) & + ball ( k1 , i1 ) * ball ( l1 , j1 ) & + ball ( i1 , l1 ) * ball ( j1 , k1 ) & + ball ( l1 , i1 ) * ball ( k1 , j1 ) df1 = df1 - xcfact * dq1 - xcfact2 * 2.0_dp * dt2 end if if ( qfspcp1 /= 0.0_dp ) then db1 = co12 ( i1 , k1 ) * co12 ( l1 , j1 ) & + co12 ( i1 , l1 ) * co12 ( k1 , j1 ) & + co12 ( j1 , k1 ) * co12 ( l1 , i1 ) & + co12 ( j1 , l1 ) * co12 ( k1 , i1 ) & + co12 ( l1 , j1 ) * co12 ( i1 , k1 ) & + co12 ( k1 , j1 ) * co12 ( i1 , l1 ) & + co12 ( l1 , i1 ) * co12 ( j1 , k1 ) & + co12 ( k1 , i1 ) * co12 ( j1 , l1 ) df1 = df1 + sgnk * qfspcp1 * db1 end if if ( qfspcp2 /= 0.0_dp ) then db2 = o21v ( i1 , k1 ) * o21v ( l1 , j1 ) & + o21v ( i1 , l1 ) * o21v ( k1 , j1 ) & + o21v ( j1 , k1 ) * o21v ( l1 , i1 ) & + o21v ( j1 , l1 ) * o21v ( k1 , i1 ) & + o21v ( l1 , j1 ) * o21v ( i1 , k1 ) & + o21v ( k1 , j1 ) * o21v ( i1 , l1 ) & + o21v ( l1 , i1 ) * o21v ( j1 , k1 ) & + o21v ( k1 , i1 ) * o21v ( j1 , l1 ) df1 = df1 + sgnk * qfspcp2 * db2 end if if ( qfspcp3 /= 0.0_dp ) then dc1 = bco1 ( i1 , k1 ) * bo2v ( j1 , l1 ) & + bco1 ( i1 , l1 ) * bo2v ( j1 , k1 ) & + bco1 ( j1 , k1 ) * bo2v ( i1 , l1 ) & + bco1 ( j1 , l1 ) * bo2v ( i1 , k1 ) & + bco1 ( l1 , j1 ) * bo2v ( k1 , i1 ) & + bco1 ( k1 , j1 ) * bo2v ( l1 , i1 ) & + bco1 ( l1 , i1 ) * bo2v ( k1 , j1 ) & + bco1 ( k1 , i1 ) * bo2v ( l1 , j1 ) dc2 = bco2 ( i1 , k1 ) * bo1v ( j1 , l1 ) & + bco2 ( i1 , l1 ) * bo1v ( j1 , k1 ) & + bco2 ( j1 , k1 ) * bo1v ( i1 , l1 ) & + bco2 ( j1 , l1 ) * bo1v ( i1 , k1 ) & + bco2 ( l1 , j1 ) * bo1v ( k1 , i1 ) & + bco2 ( k1 , j1 ) * bo1v ( l1 , i1 ) & + bco2 ( l1 , i1 ) * bo1v ( k1 , j1 ) & + bco2 ( k1 , i1 ) * bo1v ( l1 , j1 ) dc3 = bo2v ( i1 , k1 ) * bco1 ( j1 , l1 ) & + bo2v ( i1 , l1 ) * bco1 ( j1 , k1 ) & + bo2v ( j1 , k1 ) * bco1 ( i1 , l1 ) & + bo2v ( j1 , l1 ) * bco1 ( i1 , k1 ) & + bo2v ( l1 , j1 ) * bco1 ( k1 , i1 ) & + bo2v ( k1 , j1 ) * bco1 ( l1 , i1 ) & + bo2v ( l1 , i1 ) * bco1 ( k1 , j1 ) & + bo2v ( k1 , i1 ) * bco1 ( l1 , j1 ) dc4 = bo1v ( i1 , k1 ) * bco2 ( j1 , l1 ) & + bo1v ( i1 , l1 ) * bco2 ( j1 , k1 ) & + bo1v ( j1 , k1 ) * bco2 ( i1 , l1 ) & + bo1v ( j1 , l1 ) * bco2 ( i1 , k1 ) & + bo1v ( l1 , j1 ) * bco2 ( k1 , i1 ) & + bo1v ( k1 , j1 ) * bco2 ( l1 , i1 ) & + bo1v ( l1 , i1 ) * bco2 ( k1 , j1 ) & + bo1v ( k1 , i1 ) * bco2 ( l1 , j1 ) dd1 = bco1 ( i1 , j1 ) * bo2v ( l1 , k1 ) & + bco1 ( i1 , j1 ) * bo2v ( k1 , l1 ) & + bco1 ( j1 , i1 ) * bo2v ( l1 , k1 ) & + bco1 ( j1 , i1 ) * bo2v ( k1 , l1 ) & + bco1 ( l1 , k1 ) * bo2v ( i1 , j1 ) & + bco1 ( k1 , l1 ) * bo2v ( i1 , j1 ) & + bco1 ( l1 , k1 ) * bo2v ( j1 , i1 ) & + bco1 ( k1 , l1 ) * bo2v ( j1 , i1 ) dd2 = bco2 ( i1 , j1 ) * bo1v ( l1 , k1 ) & + bco2 ( i1 , j1 ) * bo1v ( k1 , l1 ) & + bco2 ( j1 , i1 ) * bo1v ( l1 , k1 ) & + bco2 ( j1 , i1 ) * bo1v ( k1 , l1 ) & + bco2 ( l1 , k1 ) * bo1v ( i1 , j1 ) & + bco2 ( k1 , l1 ) * bo1v ( i1 , j1 ) & + bco2 ( l1 , k1 ) * bo1v ( j1 , i1 ) & + bco2 ( k1 , l1 ) * bo1v ( j1 , i1 ) dd3 = bo2v ( i1 , j1 ) * bco1 ( l1 , k1 ) & + bo2v ( i1 , j1 ) * bco1 ( k1 , l1 ) & + bo2v ( j1 , i1 ) * bco1 ( l1 , k1 ) & + bo2v ( j1 , i1 ) * bco1 ( k1 , l1 ) & + bo2v ( l1 , k1 ) * bco1 ( i1 , j1 ) & + bo2v ( k1 , l1 ) * bco1 ( i1 , j1 ) & + bo2v ( l1 , k1 ) * bco1 ( j1 , i1 ) & + bo2v ( k1 , l1 ) * bco1 ( j1 , i1 ) dd4 = bo1v ( i1 , j1 ) * bco2 ( l1 , k1 ) & + bo1v ( i1 , j1 ) * bco2 ( k1 , l1 ) & + bo1v ( j1 , i1 ) * bco2 ( l1 , k1 ) & + bo1v ( j1 , i1 ) * bco2 ( k1 , l1 ) & + bo1v ( l1 , k1 ) * bco2 ( i1 , j1 ) & + bo1v ( k1 , l1 ) * bco2 ( i1 , j1 ) & + bo1v ( l1 , k1 ) * bco2 ( j1 , i1 ) & + bo1v ( k1 , l1 ) * bco2 ( j1 , i1 ) df1 = df1 + sgnk * qfspcp3 * ( - dc1 - dc2 - dc3 - dc4 & + dd1 + dd2 + dd3 + dd4 ) end if dabmax = max ( dabmax , abs ( df1 )) bfn = 1.0_dp if (. not . usecart ) bfn = product ( basis % bfnrm ([ i1 , j1 , k1 , l1 ])) ab ( l , k , j , i ) = df1 * bfn end do end do end do end do end subroutine grd2_mrsf_compute_data_t_get_density !############################################################################### end module tdhf_mrsf_gradient_mod","tags":"","url":"sourcefile/tdhf_mrsf_gradient.f90.html"},{"title":"util.F90 – OpenQP Fortran API","text":"Source Code module util use precision , only : dp implicit none character ( len =* ), parameter :: module_name = \"util\" private public :: measure_time public :: e_charge_repulsion contains subroutine measure_time ( print_total , log_unit ) use iso_fortran_env , only : int64 , real64 implicit none integer , intent ( in ) :: print_total , log_unit integer ( int64 ), save :: start_clock , previous_clock integer ( int64 ) :: clock_rate , current_clock real ( real64 ), save :: start_cpu_time , previous_cpu_time real ( real64 ) :: current_cpu_time , elapsed_cpu_time , elapsed_wall_time logical , save :: first_call = . true . if ( first_call ) then call system_clock ( start_clock , clock_rate ) call cpu_time ( start_cpu_time ) previous_clock = start_clock previous_cpu_time = start_cpu_time first_call = . false . end if call system_clock ( current_clock , clock_rate ) call cpu_time ( current_cpu_time ) elapsed_wall_time = real ( current_clock - previous_clock , & real64 ) / real ( clock_rate , real64 ) elapsed_cpu_time = current_cpu_time - previous_cpu_time write ( log_unit , \"(3X, A, F10.3, 3X, A, F10.3)\" ) & \"Step  CPU time (seconds): \" , elapsed_cpu_time , & \"Wall time (seconds): \" , elapsed_wall_time previous_clock = current_clock previous_cpu_time = current_cpu_time if ( print_total /= 0 ) then elapsed_wall_time = real ( current_clock - start_clock , & real64 ) / real ( clock_rate , real64 ) elapsed_cpu_time = current_cpu_time - start_cpu_time write ( log_unit , \"(3X, A, F10.3, 3X, A, F10.3)\" ) & \"Total CPU time (seconds): \" , elapsed_cpu_time , & \"Wall time (seconds): \" , elapsed_wall_time end if end subroutine measure_time pure function e_charge_repulsion ( xyz , q ) result ( enuc ) use precision , only : dp implicit none real ( kind = dp ) :: enuc real ( kind = dp ), intent ( in ) :: xyz (:,:), q (:) real ( kind = dp ), parameter :: disttol = 1.0d-10 integer :: i , j , nat real ( kind = dp ) :: rr nat = min ( ubound ( q , 1 ), ubound ( xyz , 2 )) enuc = 0.0d0 do i = 2 , nat do j = 1 , i - 1 rr = sum (( xyz (:, i ) - xyz (:, j )) ** 2 ) if ( rr >= disttol ) enuc = enuc + q ( i ) * q ( j ) / sqrt ( rr ) end do end do end function e_charge_repulsion end module util","tags":"","url":"sourcefile/util.f90.html"},{"title":"int2_pure_generated.F90 – OpenQP Fortran API","text":"Source Code ! Generated by tools/generate_int2_pure_kernels.py; do not edit by hand. module int2_pure_generated use precision , only : dp use constants , only : BAS_MXCART , BAS_MXANG , NUM_CART_BF , NUM_SPH_BF implicit none private integer , parameter , public :: INT2_PURE_MAX_TERMS = 4 type , public :: int2_shell_projection_t integer :: ncart = 0 integer :: nout = 0 integer :: nterm ( BAS_MXCART ) = 0 integer :: out_idx ( INT2_PURE_MAX_TERMS , BAS_MXCART ) = 0 real ( dp ) :: coeff ( INT2_PURE_MAX_TERMS , BAS_MXCART ) = 0.0_dp end type int2_shell_projection_t public :: int2_init_shell_projection public :: int2_project_pure_block contains subroutine int2_init_shell_projection ( l , pure , proj ) integer , intent ( in ) :: l , pure type ( int2_shell_projection_t ), intent ( out ) :: proj integer :: c if ( l < 0 . or . l > BAS_MXANG ) error stop 'int2_pure_generated: angular momentum out of range' proj = int2_shell_projection_t () proj % ncart = NUM_CART_BF ( l ) proj % nout = proj % ncart if ( pure == 1 . and . l >= 2 ) then proj % nout = NUM_SPH_BF ( l ) select case ( l ) case ( 2 ) call load_l2 ( proj ) case ( 3 ) call load_l3 ( proj ) case ( 4 ) call load_l4 ( proj ) case ( 5 ) call load_l5 ( proj ) case ( 6 ) call load_l6 ( proj ) case default error stop 'int2_pure_generated: unsupported pure angular momentum' end select else do c = 1 , proj % ncart call add_term ( proj , c , c , 1.0_dp ) end do end if end subroutine int2_init_shell_projection subroutine int2_project_pure_block ( ints , am , pure , nbf , nbf_out ) real ( dp ), intent ( inout ), target :: ints (:) integer , intent ( in ) :: am ( 4 ), pure ( 4 ), nbf ( 4 ) integer , intent ( out ) :: nbf_out ( 4 ) type ( int2_shell_projection_t ) :: proj ( 4 ) real ( dp ), allocatable , target :: cart (:) real ( dp ), pointer :: src (:,:,:,:), dst (:,:,:,:) integer :: c1 , c2 , c3 , c4 , t1 , t2 , t3 , t4 integer :: o1 , o2 , o3 , o4 , s real ( dp ) :: val , v1 , v2 , v3 do s = 1 , 4 call int2_init_shell_projection ( am ( s ), pure ( s ), proj ( s )) nbf_out ( s ) = proj ( s )% nout end do if ( all ( nbf_out == nbf )) return allocate ( cart ( product ( nbf ))) cart = ints ( 1 : product ( nbf )) ints ( 1 : product ( nbf_out )) = 0.0_dp src ( 1 : nbf ( 1 ), 1 : nbf ( 2 ), 1 : nbf ( 3 ), 1 : nbf ( 4 )) => cart dst ( 1 : nbf_out ( 1 ), 1 : nbf_out ( 2 ), 1 : nbf_out ( 3 ), 1 : nbf_out ( 4 )) => ints do c4 = 1 , proj ( 4 )% ncart do c3 = 1 , proj ( 3 )% ncart do c2 = 1 , proj ( 2 )% ncart do c1 = 1 , proj ( 1 )% ncart val = src ( c1 , c2 , c3 , c4 ) if ( val == 0.0_dp ) cycle do t4 = 1 , proj ( 4 )% nterm ( c4 ) o4 = proj ( 4 )% out_idx ( t4 , c4 ) v3 = val * proj ( 4 )% coeff ( t4 , c4 ) do t3 = 1 , proj ( 3 )% nterm ( c3 ) o3 = proj ( 3 )% out_idx ( t3 , c3 ) v2 = v3 * proj ( 3 )% coeff ( t3 , c3 ) do t2 = 1 , proj ( 2 )% nterm ( c2 ) o2 = proj ( 2 )% out_idx ( t2 , c2 ) v1 = v2 * proj ( 2 )% coeff ( t2 , c2 ) do t1 = 1 , proj ( 1 )% nterm ( c1 ) o1 = proj ( 1 )% out_idx ( t1 , c1 ) dst ( o1 , o2 , o3 , o4 ) = dst ( o1 , o2 , o3 , o4 ) + v1 * proj ( 1 )% coeff ( t1 , c1 ) end do end do end do end do end do end do end do end do deallocate ( cart ) end subroutine int2_project_pure_block subroutine add_term ( proj , cart_idx , out_idx , coeff ) type ( int2_shell_projection_t ), intent ( inout ) :: proj integer , intent ( in ) :: cart_idx , out_idx real ( dp ), intent ( in ) :: coeff integer :: slot slot = proj % nterm ( cart_idx ) + 1 if ( slot > INT2_PURE_MAX_TERMS ) error stop 'int2_pure_generated: sparse row overflow' proj % nterm ( cart_idx ) = slot proj % out_idx ( slot , cart_idx ) = out_idx proj % coeff ( slot , cart_idx ) = coeff end subroutine add_term subroutine load_l2 ( proj ) type ( int2_shell_projection_t ), intent ( inout ) :: proj call add_term ( proj , 1 , 3 , - 4.999999999999999e-01_dp ) call add_term ( proj , 1 , 5 , 8.660254037844386e-01_dp ) call add_term ( proj , 2 , 3 , - 4.999999999999999e-01_dp ) call add_term ( proj , 2 , 5 , - 8.660254037844386e-01_dp ) call add_term ( proj , 3 , 3 , 9.999999999999999e-01_dp ) call add_term ( proj , 4 , 1 , 1.000000000000000e+00_dp ) call add_term ( proj , 5 , 4 , 1.000000000000000e+00_dp ) call add_term ( proj , 6 , 2 , 1.000000000000000e+00_dp ) end subroutine load_l2 subroutine load_l3 ( proj ) type ( int2_shell_projection_t ), intent ( inout ) :: proj call add_term ( proj , 1 , 5 , - 6.123724356957946e-01_dp ) call add_term ( proj , 1 , 7 , 7.905694150420950e-01_dp ) call add_term ( proj , 2 , 1 , - 7.905694150420950e-01_dp ) call add_term ( proj , 2 , 3 , - 6.123724356957946e-01_dp ) call add_term ( proj , 3 , 4 , 1.000000000000000e+00_dp ) call add_term ( proj , 4 , 1 , 1.060660171779821e+00_dp ) call add_term ( proj , 4 , 3 , - 2.738612787525830e-01_dp ) call add_term ( proj , 5 , 4 , - 6.708203932499368e-01_dp ) call add_term ( proj , 5 , 6 , 8.660254037844386e-01_dp ) call add_term ( proj , 6 , 5 , - 2.738612787525830e-01_dp ) call add_term ( proj , 6 , 7 , - 1.060660171779821e+00_dp ) call add_term ( proj , 7 , 4 , - 6.708203932499368e-01_dp ) call add_term ( proj , 7 , 6 , - 8.660254037844386e-01_dp ) call add_term ( proj , 8 , 5 , 1.095445115010332e+00_dp ) call add_term ( proj , 9 , 3 , 1.095445115010332e+00_dp ) call add_term ( proj , 10 , 2 , 1.000000000000000e+00_dp ) end subroutine load_l3 subroutine load_l4 ( proj ) type ( int2_shell_projection_t ), intent ( inout ) :: proj call add_term ( proj , 1 , 5 , 3.750000000000000e-01_dp ) call add_term ( proj , 1 , 7 , - 5.590169943749475e-01_dp ) call add_term ( proj , 1 , 9 , 7.395099728874520e-01_dp ) call add_term ( proj , 2 , 5 , 3.750000000000000e-01_dp ) call add_term ( proj , 2 , 7 , 5.590169943749475e-01_dp ) call add_term ( proj , 2 , 9 , 7.395099728874520e-01_dp ) call add_term ( proj , 3 , 5 , 1.000000000000000e+00_dp ) call add_term ( proj , 4 , 1 , 1.118033988749895e+00_dp ) call add_term ( proj , 4 , 3 , - 4.225771273642583e-01_dp ) call add_term ( proj , 5 , 6 , - 8.964214570007953e-01_dp ) call add_term ( proj , 5 , 8 , 7.905694150420950e-01_dp ) call add_term ( proj , 6 , 1 , - 1.118033988749895e+00_dp ) call add_term ( proj , 6 , 3 , - 4.225771273642583e-01_dp ) call add_term ( proj , 7 , 2 , - 7.905694150420950e-01_dp ) call add_term ( proj , 7 , 4 , - 8.964214570007953e-01_dp ) call add_term ( proj , 8 , 6 , 1.195228609334394e+00_dp ) call add_term ( proj , 9 , 4 , 1.195228609334394e+00_dp ) call add_term ( proj , 10 , 5 , 2.195775164134200e-01_dp ) call add_term ( proj , 10 , 9 , - 1.299038105676658e+00_dp ) call add_term ( proj , 11 , 5 , - 8.783100656536799e-01_dp ) call add_term ( proj , 11 , 7 , 9.819805060619657e-01_dp ) call add_term ( proj , 12 , 5 , - 8.783100656536799e-01_dp ) call add_term ( proj , 12 , 7 , - 9.819805060619657e-01_dp ) call add_term ( proj , 13 , 2 , 1.060660171779821e+00_dp ) call add_term ( proj , 13 , 4 , - 4.008918628686365e-01_dp ) call add_term ( proj , 14 , 6 , - 4.008918628686365e-01_dp ) call add_term ( proj , 14 , 8 , - 1.060660171779821e+00_dp ) call add_term ( proj , 15 , 3 , 1.133893419027681e+00_dp ) end subroutine load_l4 subroutine load_l5 ( proj ) type ( int2_shell_projection_t ), intent ( inout ) :: proj call add_term ( proj , 1 , 7 , 4.841229182759271e-01_dp ) call add_term ( proj , 1 , 9 , - 5.229125165837973e-01_dp ) call add_term ( proj , 1 , 11 , 7.015607600201139e-01_dp ) call add_term ( proj , 2 , 1 , 7.015607600201139e-01_dp ) call add_term ( proj , 2 , 3 , 5.229125165837973e-01_dp ) call add_term ( proj , 2 , 5 , 4.841229182759271e-01_dp ) call add_term ( proj , 3 , 6 , 1.000000000000000e+00_dp ) call add_term ( proj , 4 , 1 , 1.169267933366856e+00_dp ) call add_term ( proj , 4 , 3 , - 5.229125165837972e-01_dp ) call add_term ( proj , 4 , 5 , 1.613743060919757e-01_dp ) call add_term ( proj , 5 , 6 , 6.250000000000001e-01_dp ) call add_term ( proj , 5 , 8 , - 8.539125638299664e-01_dp ) call add_term ( proj , 5 , 10 , 7.395099728874519e-01_dp ) call add_term ( proj , 6 , 7 , 1.613743060919757e-01_dp ) call add_term ( proj , 6 , 9 , 5.229125165837972e-01_dp ) call add_term ( proj , 6 , 11 , 1.169267933366856e+00_dp ) call add_term ( proj , 7 , 6 , 6.250000000000001e-01_dp ) call add_term ( proj , 7 , 8 , 8.539125638299664e-01_dp ) call add_term ( proj , 7 , 10 , 7.395099728874519e-01_dp ) call add_term ( proj , 8 , 7 , 1.290994448735805e+00_dp ) call add_term ( proj , 9 , 5 , 1.290994448735805e+00_dp ) call add_term ( proj , 10 , 7 , 2.112885636821291e-01_dp ) call add_term ( proj , 10 , 9 , 2.282177322938192e-01_dp ) call add_term ( proj , 10 , 11 , - 1.530931089239486e+00_dp ) call add_term ( proj , 11 , 7 , - 1.267731382092775e+00_dp ) call add_term ( proj , 11 , 9 , 9.128709291752769e-01_dp ) call add_term ( proj , 12 , 1 , - 1.530931089239486e+00_dp ) call add_term ( proj , 12 , 3 , - 2.282177322938192e-01_dp ) call add_term ( proj , 12 , 5 , 2.112885636821291e-01_dp ) call add_term ( proj , 13 , 3 , - 9.128709291752769e-01_dp ) call add_term ( proj , 13 , 5 , - 1.267731382092775e+00_dp ) call add_term ( proj , 14 , 6 , - 1.091089451179962e+00_dp ) call add_term ( proj , 14 , 8 , 1.118033988749895e+00_dp ) call add_term ( proj , 15 , 6 , - 1.091089451179962e+00_dp ) call add_term ( proj , 15 , 8 , - 1.118033988749895e+00_dp ) call add_term ( proj , 16 , 2 , 1.118033988749895e+00_dp ) call add_term ( proj , 16 , 4 , - 6.454972243679028e-01_dp ) call add_term ( proj , 17 , 2 , - 1.118033988749895e+00_dp ) call add_term ( proj , 17 , 4 , - 6.454972243679028e-01_dp ) call add_term ( proj , 18 , 4 , 1.290994448735806e+00_dp ) call add_term ( proj , 19 , 6 , 3.659625273557000e-01_dp ) call add_term ( proj , 19 , 10 , - 1.299038105676658e+00_dp ) call add_term ( proj , 20 , 3 , 1.224744871391589e+00_dp ) call add_term ( proj , 20 , 5 , - 5.669467095138407e-01_dp ) call add_term ( proj , 21 , 7 , - 5.669467095138407e-01_dp ) call add_term ( proj , 21 , 9 , - 1.224744871391589e+00_dp ) end subroutine load_l5 subroutine load_l6 ( proj ) type ( int2_shell_projection_t ), intent ( inout ) :: proj call add_term ( proj , 1 , 7 , - 3.125000000000001e-01_dp ) call add_term ( proj , 1 , 9 , 4.528555233184201e-01_dp ) call add_term ( proj , 1 , 11 , - 4.960783708246108e-01_dp ) call add_term ( proj , 1 , 13 , 6.716932893813962e-01_dp ) call add_term ( proj , 2 , 7 , - 3.125000000000001e-01_dp ) call add_term ( proj , 2 , 9 , - 4.528555233184201e-01_dp ) call add_term ( proj , 2 , 11 , - 4.960783708246108e-01_dp ) call add_term ( proj , 2 , 13 , - 6.716932893813962e-01_dp ) call add_term ( proj , 3 , 7 , 1.000000000000000e+00_dp ) call add_term ( proj , 4 , 1 , 1.215138880951473e+00_dp ) call add_term ( proj , 4 , 3 , - 5.982930264130993e-01_dp ) call add_term ( proj , 4 , 5 , 2.730821554704072e-01_dp ) call add_term ( proj , 5 , 8 , 8.635615996346967e-01_dp ) call add_term ( proj , 5 , 10 , - 8.192464664112216e-01_dp ) call add_term ( proj , 5 , 12 , 7.015607600201141e-01_dp ) call add_term ( proj , 6 , 1 , 1.215138880951473e+00_dp ) call add_term ( proj , 6 , 3 , 5.982930264130993e-01_dp ) call add_term ( proj , 6 , 5 , 2.730821554704072e-01_dp ) call add_term ( proj , 7 , 2 , 7.015607600201141e-01_dp ) call add_term ( proj , 7 , 4 , 8.192464664112216e-01_dp ) call add_term ( proj , 7 , 6 , 8.635615996346967e-01_dp ) call add_term ( proj , 8 , 8 , 1.381698559415515e+00_dp ) call add_term ( proj , 9 , 6 , 1.381698559415515e+00_dp ) call add_term ( proj , 10 , 7 , - 1.631978024584668e-01_dp ) call add_term ( proj , 10 , 9 , 7.883202798586143e-02_dp ) call add_term ( proj , 10 , 11 , 4.317807998173486e-01_dp ) call add_term ( proj , 10 , 13 , - 1.753901900050285e+00_dp ) call add_term ( proj , 11 , 7 , 9.791868147508008e-01_dp ) call add_term ( proj , 11 , 9 , - 1.261312447773783e+00_dp ) call add_term ( proj , 11 , 11 , 8.635615996346971e-01_dp ) call add_term ( proj , 12 , 7 , - 1.631978024584668e-01_dp ) call add_term ( proj , 12 , 9 , - 7.883202798586143e-02_dp ) call add_term ( proj , 12 , 11 , 4.317807998173486e-01_dp ) call add_term ( proj , 12 , 13 , 1.753901900050285e+00_dp ) call add_term ( proj , 13 , 7 , 9.791868147508008e-01_dp ) call add_term ( proj , 13 , 9 , 1.261312447773783e+00_dp ) call add_term ( proj , 13 , 11 , 8.635615996346971e-01_dp ) call add_term ( proj , 14 , 7 , - 1.305582419667734e+00_dp ) call add_term ( proj , 14 , 9 , 1.261312447773783e+00_dp ) call add_term ( proj , 15 , 7 , - 1.305582419667734e+00_dp ) call add_term ( proj , 15 , 9 , - 1.261312447773783e+00_dp ) call add_term ( proj , 16 , 2 , 1.169267933366857e+00_dp ) call add_term ( proj , 16 , 4 , - 8.192464664112215e-01_dp ) call add_term ( proj , 16 , 6 , 2.878538665448989e-01_dp ) call add_term ( proj , 17 , 8 , 2.878538665448989e-01_dp ) call add_term ( proj , 17 , 10 , 8.192464664112215e-01_dp ) call add_term ( proj , 17 , 12 , 1.169267933366857e+00_dp ) call add_term ( proj , 18 , 5 , 1.456438162508838e+00_dp ) call add_term ( proj , 19 , 1 , - 1.976423537605236e+00_dp ) call add_term ( proj , 19 , 5 , 2.665008954445131e-01_dp ) call add_term ( proj , 20 , 8 , - 1.685499656158105e+00_dp ) call add_term ( proj , 20 , 10 , 1.066003581778052e+00_dp ) call add_term ( proj , 21 , 4 , - 1.066003581778052e+00_dp ) call add_term ( proj , 21 , 6 , - 1.685499656158105e+00_dp ) call add_term ( proj , 22 , 8 , 3.768891807222045e-01_dp ) call add_term ( proj , 22 , 10 , 3.575484709670971e-01_dp ) call add_term ( proj , 22 , 12 , - 1.530931089239487e+00_dp ) call add_term ( proj , 23 , 3 , 1.305582419667734e+00_dp ) call add_term ( proj , 23 , 5 , - 9.534625892455924e-01_dp ) call add_term ( proj , 24 , 2 , - 1.530931089239487e+00_dp ) call add_term ( proj , 24 , 4 , - 3.575484709670971e-01_dp ) call add_term ( proj , 24 , 6 , 3.768891807222045e-01_dp ) call add_term ( proj , 25 , 3 , - 1.305582419667734e+00_dp ) call add_term ( proj , 25 , 5 , - 9.534625892455924e-01_dp ) call add_term ( proj , 26 , 4 , 1.430193883868389e+00_dp ) call add_term ( proj , 26 , 6 , - 7.537783614444090e-01_dp ) call add_term ( proj , 27 , 8 , - 7.537783614444090e-01_dp ) call add_term ( proj , 27 , 10 , - 1.430193883868389e+00_dp ) call add_term ( proj , 28 , 7 , 5.733530903673290e-01_dp ) call add_term ( proj , 28 , 11 , - 1.516949690542295e+00_dp ) end subroutine load_l6 end module int2_pure_generated","tags":"","url":"sourcefile/int2_pure_generated.f90.html"},{"title":"minao_lut.F90 – OpenQP Fortran API","text":"Source Code !> @brief MINAO atomic-density lookup table. !> !> Loads spherically-averaged neutral-atom density matrices in a fixed minimal !> reference basis (STO-3G, Cartesian) from the OpenQP data file !> (basis_sets/minao_sto3g.dat, generated offline by !> tools/minao/generate_minao_data.py from PySCF's atomic HF densities). These !> are superposed block-diagonally and projected onto the target basis to form !> the MINAO initial guess. module minao_lut use precision , only : dp implicit none private public :: minao_table_t type :: minao_elem_t integer :: nao = 0 real ( kind = dp ) :: nelec = 0.0_dp real ( kind = dp ), allocatable :: dm (:,:) !< (nao,nao) atomic density, AO basis end type type :: minao_table_t integer :: zmax = 0 type ( minao_elem_t ), allocatable :: elem (:) contains procedure :: load => minao_load procedure :: clean => minao_clean end type contains subroutine minao_load ( self , filename , err ) class ( minao_table_t ), intent ( inout ) :: self character ( len =* ), intent ( in ) :: filename logical , intent ( out ) :: err integer :: u , ios , z , zz , nao , i , j character ( len = 256 ) :: line real ( kind = dp ), allocatable :: flat (:) err = . false . call self % clean () open ( newunit = u , file = trim ( filename ), status = 'old' , action = 'read' , iostat = ios ) if ( ios /= 0 ) then err = . true . return end if ! first non-comment line: zmax do read ( u , '(A)' , iostat = ios ) line if ( ios /= 0 ) then err = . true .; close ( u ); return end if if ( len_trim ( line ) == 0 ) cycle if ( line ( 1 : 1 ) == '#' ) cycle exit end do read ( line , * , iostat = ios ) self % zmax if ( ios /= 0 . or . self % zmax <= 0 ) then err = . true .; close ( u ); return end if allocate ( self % elem ( self % zmax )) do z = 1 , self % zmax read ( u , * , iostat = ios ) zz , nao , self % elem ( z )% nelec if ( ios /= 0 . or . zz /= z ) then err = . true .; close ( u ); return end if self % elem ( z )% nao = nao allocate ( self % elem ( z )% dm ( nao , nao ), flat ( nao * nao )) read ( u , * , iostat = ios ) flat if ( ios /= 0 ) then err = . true .; close ( u ); return end if ! data written row-major do i = 1 , nao do j = 1 , nao self % elem ( z )% dm ( i , j ) = flat (( i - 1 ) * nao + j ) end do end do deallocate ( flat ) end do close ( u ) end subroutine minao_load subroutine minao_clean ( self ) class ( minao_table_t ), intent ( inout ) :: self integer :: z if ( allocated ( self % elem )) then do z = 1 , size ( self % elem ) if ( allocated ( self % elem ( z )% dm )) deallocate ( self % elem ( z )% dm ) end do deallocate ( self % elem ) end if self % zmax = 0 end subroutine minao_clean end module minao_lut","tags":"","url":"sourcefile/minao_lut.f90.html"},{"title":"int_rotaxis.F90 – OpenQP Fortran API","text":"Source Code module int2e_rotaxis use precision , only : dp , qp use basis_tools , only : basis_set use boys_lut , only : fgrid , xgrid , rxinc , rfinc , rmr , tmax use int2_pairs , only : int2_pair_storage , int2_cutoffs_t use constants , only : HARMONIC_ACTIVE , pi implicit none private public genr22 public genr22_pure public genr22_reduce_pure ! exported so the int2e_rotaxis_pure submodule gets external linkage public genr22_core !> Direct pure-spherical variant of genr22, implemented in !> int_rotaxis_pure.F90. Harmonic-flagged d shells come out at !> 2l+1 components; nbf returns the per-slot output dimensions !> in canonical (flipped) shell order. interface module subroutine genr22_pure ( basis , ppairs , grotspd , shell_ids , flips , cutoffs , nbf , emu2 ) type ( basis_set ), intent ( in ) :: basis type ( int2_pair_storage ), intent ( in ) :: ppairs real ( kind = dp ), intent ( inout ) :: grotspd ( * ) integer , intent ( in ) :: shell_ids ( 4 ) integer , intent ( out ) :: flips ( 4 ) type ( int2_cutoffs_t ), intent ( in ) :: cutoffs integer , intent ( out ) :: nbf ( 4 ) real ( kind = dp ), optional :: emu2 end subroutine genr22_pure end interface real ( dp ), parameter :: acy_threshold = 1.0e-10_dp real ( dp ), parameter :: sqrt3 = sqrt ( 3.0_dp ) real ( dp ), parameter :: pi4 = pi / 4 integer , parameter :: in6 ( 6 ) = [ 1 , 4 , 5 , 2 , 6 , 3 ] integer , parameter :: max_contraction = 30 !< Max. degree of contraction type :: rotaxis_data_t logical :: lrint = . false . real ( kind = dp ) :: emu2 = 1.0d99 integer :: ngangb real ( kind = dp ) :: cutoff = 0 real ( kind = dp ) :: acy , acy2 , aqx , aqx2 , aqxy , y03 , y04 real ( kind = dp ) :: rab , x34 , x43 , aqz , qps , sq real ( kind = dp ) :: tx12 ( max_contraction ** 2 ), ty02 ( max_contraction ** 2 ), & sp ( max_contraction ** 2 ) real ( kind = dp ) :: fq ( 0 : 8 ), fq0 ( 5 ), fq1 ( 2 , 13 ), fq2 ( 3 , 16 ), fq3 ( 4 , 16 ), fq4 ( 5 , 16 ), & fq5 ( 6 , 11 ), fq6 ( 7 , 7 ), fq7 ( 8 , 3 ), fq8 ( 9 ) real ( kind = dp ) :: r00 ( 5 , 5 ), r01 ( 3 , 40 ), r02 ( 6 , 56 ), r03 ( 10 , 52 ), r04 ( 15 , 42 ), & r05 ( 21 , 24 ), r06 ( 28 , 12 ), r07 ( 36 , 4 ), r08 ( 45 ) end type contains ! > ! >    @brief   rotated axis integration involving s,p,l,d shells ! > ! >    @details rotated axis integration involving s,p,l,d shells, ! >             by a mix of rotated axis and mcmurchie/davidson. ! >                       k.ishimura, s.nagase ! >                theoret.chem.acc. 120, 185-189(2008) ! > ! >    @author  kazuya ishimura, at the institute for molecular science, ! >             sponsored by naregi nano science project, in 2004. ! >             extensively revised by jose sierra in 2013. ! > subroutine genr22 ( basis , ppairs , grotspd , shell_ids , flips , cutoffs , emu2 ) implicit none type ( basis_set ), intent ( in ) :: basis type ( int2_pair_storage ), intent ( in ) :: ppairs real ( kind = dp ), intent ( inout ) :: grotspd ( * ) integer , intent ( in ) :: shell_ids ( 4 ) integer , intent ( out ) :: flips ( 4 ) type ( int2_cutoffs_t ), intent ( in ) :: cutoffs real ( kind = dp ), optional :: emu2 real ( kind = dp ) :: prot ( 3 , 3 ) integer :: jtype call genr22_core ( basis , ppairs , grotspd , shell_ids , flips , cutoffs , prot , jtype , emu2 ) call r30s1d ( jtype , grotspd , prot ) end subroutine genr22 !> Shared body of the rotated-axis ERI evaluation: geometry setup, !> primitive q-loop accumulation, and assembly of the rotated-frame !> block via mcdv_all. Returns the (transposed) back-rotation matrix !> and jtype; the caller applies its own rotated->lab transformation. subroutine genr22_core ( basis , ppairs , grotspd , shell_ids , flips , cutoffs , prot , jtype_out , emu2 ) implicit none type ( basis_set ), intent ( in ) :: basis type ( int2_pair_storage ), intent ( in ) :: ppairs real ( kind = dp ), intent ( inout ) :: grotspd ( * ) integer , intent ( in ) :: shell_ids ( 4 ) integer , intent ( out ) :: flips ( 4 ) type ( int2_cutoffs_t ), intent ( in ) :: cutoffs real ( kind = dp ), intent ( out ) :: prot ( 3 , 3 ) integer , intent ( out ) :: jtype_out real ( kind = dp ), optional :: emu2 real ( kind = dp ) :: a ( 3 ), b ( 3 ), c ( 3 ), d ( 3 ), p ( 3 , 3 ), t ( 3 ) integer :: flips_inv ( 4 ) integer :: angm ( 4 ) integer :: shl_new ( 4 ) integer :: itype , jtype integer :: i integer :: ji real ( kind = dp ) :: acx , acz , cq , cqx , cqz , qx , qz real ( kind = dp ) :: cosg , sing real ( kind = dp ) :: rcd real ( kind = dp ) :: tmp real ( kind = dp ) :: x03 , x04 integer :: nga , ngb , ngc , ngd integer :: ppid_p , ppid_q , npp_p , npp_q integer :: id1 , id2 integer , parameter :: jtypes ( * ) = [ & 1 , 2 , 7 , 2 , 3 , & 8 , 7 , 8 , 10 , 2 , & 4 , 9 , 4 , 5 , 11 , & 9 , 11 , 14 , 7 , 9 , & 12 , 9 , 13 , 15 , 12 , & 15 , 17 , 2 , 4 , 9 , & 4 , 5 , 11 , 9 , 11 , & 14 , 3 , 5 , 13 , 5 , & 6 , 16 , 13 , 16 , 18 , & 8 , 11 , 15 , 11 , 16 , & 19 , 15 , 19 , 20 , 7 , & 9 , 12 , 9 , 13 , 15 , & 12 , 15 , 17 , 8 , 11 , & 15 , 11 , 16 , 19 , 15 , & 19 , 20 , 10 , 14 , 17 , & 14 , 18 , 20 , 17 , 20 , & 21 ] type ( rotaxis_data_t ) :: rdat angm = basis % am ( shell_ids ) itype = 1 + angm ( 4 ) + 3 * angm ( 3 ) + 9 * angm ( 2 ) + 27 * angm ( 1 ) jtype = jtypes ( itype ) flips = [ 1 , 2 , 3 , 4 ] if ( angm ( 1 ) > angm ( 2 )) then flips ( 1 : 2 ) = [ 2 , 1 ] angm ( 1 : 2 ) = angm ([ 2 , 1 ]) end if if ( angm ( 3 ) > angm ( 4 )) then flips ( 3 : 4 ) = [ 4 , 3 ] angm ( 3 : 4 ) = angm ([ 4 , 3 ]) end if if ( sum ( angm ( 1 : 2 )) > sum ( angm ( 3 : 4 )) . or . angm ( 2 ) > angm ( 4 )) then flips = flips ([ 3 , 4 , 1 , 2 ]) angm = angm ([ 3 , 4 , 1 , 2 ]) end if flips_inv ( flips ) = [ 1 , 2 , 3 , 4 ] shl_new = shell_ids ( flips_inv ) ! If (la/=angm(1).or.lb/=angm(2)) print *, la, angm(1), lb, angm(2) ! Empty integral summation storage call intclean ( rdat , jtype ) if ( present ( emu2 )) then rdat % lrint = . true . rdat % emu2 = emu2 end if id1 = maxval ( shl_new ([ 1 , 2 ])) id2 = minval ( shl_new ([ 1 , 2 ])) npp_p = ppairs % ppid ( 1 , id1 * ( id1 - 1 ) / 2 + id2 ) ppid_p = ppairs % ppid ( 2 , id1 * ( id1 - 1 ) / 2 + id2 ) id1 = maxval ( shl_new ([ 3 , 4 ])) id2 = minval ( shl_new ([ 3 , 4 ])) npp_q = ppairs % ppid ( 1 , id1 * ( id1 - 1 ) / 2 + id2 ) ppid_q = ppairs % ppid ( 2 , id1 * ( id1 - 1 ) / 2 + id2 ) ! If (npp_p == 0 .or. npp_q == 0) return ! Obtain information about shells: inew, knew, jnew, lnew ! Number of gaussians go into nga,... in common shllfo ! Shell angular quantum numbers la,... go into common shllfo ! Gaussian exponents go into arrays exa,exb,exc,exd in common shllfo ! Gaussian coefficients go into arrays csa,cpa,... in common shllfo ! Loop over gaussians in each shell ! First shell inew ! Coordinates of atoms associated with shells inew jnew knew and lnew a = ppairs % p (:, ppid_p ) - ppairs % pa (:, ppid_p ) b = ppairs % p (:, ppid_p ) - ppairs % pb (:, ppid_p ) c = ppairs % p (:, ppid_q ) - ppairs % pa (:, ppid_q ) d = ppairs % p (:, ppid_q ) - ppairs % pb (:, ppid_q ) ! Find direction cosines of penultimate axes from coordinates of ab ! P(1,1),p(1,2),... are direction cosines of axes at p.  z-axis along ab ! T(1),t(2),t(3)... are direction cosines of axes at q.  z-axis along cd ! Find direction cosines of ab and cd. these are local z-axes. ! If indeterminate take along space z-axis p (:, 3 ) = [ 0 , 0 , 1 ] rdat % rab = ppairs % rab ( ppid_p ) if ( rdat % rab > 0 ) then p (:, 3 ) = ( b - a ) * ppairs % uab ( ppid_p ) end if t = [ 0 , 0 , 1 ] rcd = ppairs % rab ( ppid_q ) if ( rcd > 0 ) then t = ( d - c ) * ppairs % uab ( ppid_q ) end if ! Find local y-axis as common perpendicular to ab and cd ! If indeterminate take perpendicular to ab and space z-axis ! If still indeterminate take perpendicular to ab and space x-axis cosg = dot_product ( t , p (:, 3 )) ! Modified rotation testing. ! This fix cures the small angle problem. p ( 1 , 2 ) = t ( 3 ) * p ( 2 , 3 ) - t ( 2 ) * p ( 3 , 3 ) p ( 2 , 2 ) = t ( 1 ) * p ( 3 , 3 ) - t ( 3 ) * p ( 1 , 3 ) p ( 3 , 2 ) = t ( 2 ) * p ( 1 , 3 ) - t ( 1 ) * p ( 2 , 3 ) if ( abs ( cosg ) > 0.9 ) then sing = norm2 ( p (:, 2 )) else sing = sqrt ( 1 - cosg * cosg ) end if if ( sing < 1 d - 12 ) then if ( abs ( p ( 1 , 3 )) < sqrt ( 0.5d0 )) then tmp = 1 / sqrt ( 1 - p ( 1 , 3 ) * p ( 1 , 3 )) p (:, 2 ) = [ 0 d0 , p ( 3 , 3 ), - p ( 2 , 3 )] * tmp else tmp = 1 / sqrt ( 1 - p ( 3 , 3 ) * p ( 3 , 3 )) p (:, 2 ) = [ p ( 2 , 3 ), - p ( 1 , 3 ), 0 d0 ] * tmp end if else p (:, 2 ) = p (:, 2 ) / sing end if p ( 1 , 1 ) = p ( 2 , 2 ) * p ( 3 , 3 ) - p ( 3 , 2 ) * p ( 2 , 3 ) p ( 2 , 1 ) = p ( 3 , 2 ) * p ( 1 , 3 ) - p ( 1 , 2 ) * p ( 3 , 3 ) p ( 3 , 1 ) = p ( 1 , 2 ) * p ( 2 , 3 ) - p ( 2 , 2 ) * p ( 1 , 3 ) ! Find coordinates of c relative to local axes at a t = c - a acx = dot_product ( t , p (:, 1 )) rdat % acy = dot_product ( t , p (:, 2 )) acz = dot_product ( t , p (:, 3 )) ! Set acy= 0  if close if ( abs ( rdat % acy ) <= acy_threshold ) then rdat % acy = 0.0_dp rdat % acy2 = 0.0_dp else rdat % acy2 = rdat % acy * rdat % acy end if ! Direction cosines of cd local axes with respect to ab local axes ! ( cosg,   0,-sing ) ! (    0,   1,    0 ) ! ( sing,   0, cosg ) ! Preliminary p loop ! Fill geompq with information about p in preliminary p-loop rdat % cutoff = cutoffs % quartet_cutoff_squared ji = 0 do i = 0 , npp_p - 1 if ( abs ( ppairs % k ( ppid_p + i ) * ppairs % ginv ( ppid_p + i )) < cutoffs % quartet_cutoff ) cycle ji = ji + 1 rdat % tx12 ( ji ) = ppairs % g ( ppid_p + i ) rdat % ty02 ( ji ) = ppairs % alpha_b ( ppid_p + i ) * ppairs % ginv ( ppid_p + i ) * rdat % rab rdat % sp ( ji ) = ppairs % k ( ppid_p + i ) * ppairs % ginv ( ppid_p + i ) end do rdat % ngangb = ji ! Begin q loop do i = 0 , npp_q - 1 if ( abs ( ppairs % k ( ppid_q + i ) * ppairs % ginv ( ppid_q + i )) < cutoffs % quartet_cutoff ) cycle x03 = ppairs % alpha_a ( ppid_q + i ) x04 = ppairs % alpha_b ( ppid_q + i ) rdat % x34 = ppairs % g ( ppid_q + i ) rdat % x43 = ppairs % ginv ( ppid_q + i ) rdat % y03 = x03 * rdat % x43 rdat % y04 = x04 * rdat % x43 rdat % sq = ppairs % k ( ppid_q + i ) * ppairs % ginv ( ppid_q + i ) ! Cqx = component of cq along penultimate x-axis ! Cqz = component of cq along penultimate z-axis cq = rcd * rdat % y04 cqx = cq * sing cqz = cq * cosg ! Find coordinates of q relative to axes at a ! Qpr is perpendicular from q to ab rdat % aqx = acx + cqx rdat % aqx2 = rdat % aqx * rdat % aqx rdat % aqxy = rdat % aqx * rdat % acy rdat % aqz = acz + cqz rdat % qps = rdat % aqx2 + rdat % acy2 ! Use special fast routine for inner loops for 0000 ... 1111 call spdgen ( jtype , rdat , 1 ) end do qx = rcd * sing qz = rcd * cosg call mcdv_all ( grotspd , rdat , qx , qz , jtype ) prot = transpose ( p ) jtype_out = jtype end subroutine genr22_core subroutine genr22_reduce_pure ( basis , shell_ids , flips , grotspd , nbf ) use int2_pure_generated , only : int2_project_pure_block implicit none type ( basis_set ), intent ( in ) :: basis integer , intent ( in ) :: shell_ids ( 4 ), flips ( 4 ) real ( kind = dp ), intent ( inout ) :: grotspd (:) integer , intent ( inout ) :: nbf ( 4 ) integer :: ids ( 4 ), am_s ( 4 ), pure_s ( 4 ), nbf_s ( 4 ), nbf_out_s ( 4 ) if (. not . HARMONIC_ACTIVE ) return ids = shell_ids ( flips ) am_s = basis % am ( ids ([ 4 , 3 , 2 , 1 ])) pure_s = basis % harmonic ( ids ([ 4 , 3 , 2 , 1 ])) if (. not . any ( pure_s == 1 . and . am_s >= 2 )) return nbf_s = nbf ([ 4 , 3 , 2 , 1 ]) call int2_project_pure_block ( grotspd , am_s , pure_s , nbf_s , nbf_out_s ) nbf = nbf_out_s ([ 4 , 3 , 2 , 1 ]) end subroutine genr22_reduce_pure subroutine intclean ( rdat , jtype ) implicit none type ( rotaxis_data_t ) :: rdat integer , intent ( in ) :: jtype select case ( jtype ) case ( 1 ) rdat % r00 ( 1 , 1 ) = 0.0_dp case ( 2 ) call intk_02 ( rdat , 0 ) case ( 3 ) call intk_03 ( rdat , 0 ) case ( 4 ) call intk_04 ( rdat , 0 ) case ( 5 ) call intk_05 ( rdat , 0 ) case ( 6 ) call intk_06 ( rdat , 0 ) case ( 7 ) call intk_07 ( rdat , 0 ) case ( 8 ) call intk_08 ( rdat , 0 ) case ( 9 ) call intk_09 ( rdat , 0 ) case ( 10 ) call intk_10 ( rdat , 0 ) case ( 11 ) call intk_11 ( rdat , 0 ) case ( 12 ) call intk_12 ( rdat , 0 ) case ( 13 ) call intk_13 ( rdat , 0 ) case ( 14 ) call intk_14 ( rdat , 0 ) case ( 15 ) call intk_15 ( rdat , 0 ) case ( 16 ) call intk_16 ( rdat , 0 ) case ( 17 ) call intk_17 ( rdat , 0 ) case ( 18 ) call intk_18 ( rdat , 0 ) case ( 19 ) call intk_19 ( rdat , 0 ) case ( 20 ) call intk_20 ( rdat , 0 ) case ( 21 ) call intk_21 ( rdat , 0 ) end select end subroutine subroutine mcdv_all ( grotspd , rdat , qx , qz , jtype ) implicit none type ( rotaxis_data_t ) :: rdat integer , intent ( in ) :: jtype real ( kind = dp ), intent ( in ) :: qx , qz real ( kind = dp ), intent ( inout ) :: grotspd ( * ) select case ( jtype ) case ( 1 ) grotspd ( 1 ) = rdat % r00 ( 1 , 1 ) return case ( 2 ) call mcdv_02 ( grotspd , rdat , qx , qz ) case ( 3 ) call mcdv_03 ( grotspd , rdat , qx , qz ) case ( 4 ) call mcdv_04 ( grotspd , rdat , qx , qz ) case ( 5 ) call mcdv_05 ( grotspd , rdat , qx , qz ) case ( 6 ) call mcdv_06 ( grotspd , rdat , qx , qz ) case ( 7 ) call mcdv_07 ( grotspd , rdat , qx , qz ) case ( 8 ) call mcdv_08 ( grotspd , rdat , qx , qz ) case ( 9 ) call mcdv_09 ( grotspd , rdat , qx , qz ) case ( 10 ) call mcdv_10 ( grotspd , rdat , qx , qz ) case ( 11 ) call mcdv_11 ( grotspd , rdat , qx , qz ) case ( 12 ) call mcdv_12 ( grotspd , rdat , qx , qz ) case ( 13 ) call mcdv_13 ( grotspd , rdat , qx , qz ) case ( 14 ) call mcdv_14 ( grotspd , rdat , qx , qz ) case ( 15 ) call mcdv_15 ( grotspd , rdat , qx , qz ) case ( 16 ) call mcdv_16 ( grotspd , rdat , qx , qz ) case ( 17 ) call mcdv_17 ( grotspd , rdat , qx , qz ) case ( 18 ) call mcdv_18 ( grotspd , rdat , qx , qz ) case ( 19 ) call mcdv_19 ( grotspd , rdat , qx , qz ) case ( 20 ) call mcdv_20 ( grotspd , rdat , qx , qz ) case ( 21 ) call mcdv_21 ( grotspd , rdat , qx , qz ) end select end subroutine ! >    @brief   s,p,d rotated axis type selection ! >    @details s,p,d rotated axis type selection subroutine spdgen ( jtype , rdat , ikl ) implicit none type ( rotaxis_data_t ) :: rdat integer :: jtype , ikl select case ( jtype ) case ( 1 ) call intj_01 ( rdat ) rdat % r00 ( 1 , 1 ) = rdat % r00 ( 1 , 1 ) + rdat % fq0 ( 1 ) case ( 2 ) call intj_02 ( rdat ) call intk_02 ( rdat , ikl ) case ( 3 ) call intj_03 ( rdat ) call intk_03 ( rdat , ikl ) case ( 4 ) call intj_04 ( rdat ) call intk_04 ( rdat , ikl ) case ( 5 ) call intj_05 ( rdat ) call intk_05 ( rdat , ikl ) case ( 6 ) call intj_06 ( rdat ) call intk_06 ( rdat , ikl ) case ( 7 ) call intj_07 ( rdat ) call intk_07 ( rdat , ikl ) case ( 8 ) call intj_08 ( rdat ) call intk_08 ( rdat , ikl ) case ( 9 ) call intj_09 ( rdat ) call intk_09 ( rdat , ikl ) case ( 10 ) call intj_10 ( rdat ) call intk_10 ( rdat , ikl ) case ( 11 ) call intj_11 ( rdat ) call intk_11 ( rdat , ikl ) case ( 12 ) call intj_12 ( rdat ) call intk_12 ( rdat , ikl ) case ( 13 ) call intj_13 ( rdat ) call intk_13 ( rdat , ikl ) case ( 14 ) call intj_14 ( rdat ) call intk_14 ( rdat , ikl ) case ( 15 ) call intj_15 ( rdat ) call intk_15 ( rdat , ikl ) case ( 16 ) call intj_16 ( rdat ) call intk_16 ( rdat , ikl ) case ( 17 ) call intj_17 ( rdat ) call intk_17 ( rdat , ikl ) case ( 18 ) call intj_18 ( rdat ) call intk_18 ( rdat , ikl ) case ( 19 ) call intj_19 ( rdat ) call intk_19 ( rdat , ikl ) case ( 20 ) call intj_20 ( rdat ) call intk_20 ( rdat , ikl ) case ( 21 ) call intj_21 ( rdat ) call intk_21 ( rdat , ikl ) end select end subroutine ! > ! >    @brief   rotate up to 1296 s,p,d integrals to space fixed axes ! > ! >    @details rotate up to 1296 s,p,d integrals to space fixed axes ! >             incoming and outgoing integrals in f, while p(1,1),... ! >             are direction cosines of space fixed axes wrt axes at p ! > subroutine r30s1d ( jtype , f , p ) implicit none integer :: jtype real ( kind = dp ) :: f ( * ), p ( 3 , 3 ) select case ( jtype ) case ( 2 ) call r30s1d_02 ( f , p ) case ( 3 ) call r30s1d_03 ( f , p ) case ( 4 ) call r30s1d_04 ( f , p ) case ( 5 ) call r30s1d_05 ( f , p ) case ( 6 ) call r30s1d_06 ( f , p ) case ( 7 ) call r30s1d_07 ( f , p ) case ( 8 ) call r30s1d_08 ( f , p ) case ( 9 ) call r30s1d_09 ( f , p ) case ( 10 ) call r30s1d_10 ( f , p ) case ( 11 ) call r30s1d_11 ( f , p ) case ( 12 ) call r30s1d_12 ( f , p ) case ( 13 ) call r30s1d_13 ( f , p ) case ( 14 ) call r30s1d_14 ( f , p ) case ( 15 ) call r30s1d_15 ( f , p ) case ( 16 ) call r30s1d_16 ( f , p ) case ( 17 ) call r30s1d_17 ( f , p ) case ( 18 ) call r30s1d_18 ( f , p ) case ( 19 ) call r30s1d_19 ( f , p ) case ( 20 ) call r30s1d_20 ( f , p ) case ( 21 ) call r30s1d_21 ( f , p ) end select end subroutine r30s1d ! > ! >    @brief   ssss case ! > ! >    @details integration of a ssss case ! > subroutine intj_01 ( rdat ) implicit none type ( rotaxis_data_t ) :: rdat ! Generate jtype= 1 integrals integer :: i , n , ip real ( kind = dp ) :: fqz , x41 , pqr , pqs , rho , xva real ( kind = dp ) :: tv , fx , efr , fqf , xin rdat % fq0 ( 1 ) = 0.0_dp do i = 1 , rdat % ngangb fqz = rdat % sp ( i ) * rdat % sq x41 = rdat % tx12 ( i ) + rdat % x34 if ( fqz * fqz < rdat % cutoff * x41 ) cycle x41 = 1 / x41 pqr = rdat % ty02 ( i ) - rdat % aqz pqs = pqr * pqr rho = rdat % tx12 ( i ) * rdat % x34 * x41 if ( rdat % lrint ) then efr = rdat % emu2 / ( rdat % emu2 + rho ) rho = rho * efr fqz = fqz * sqrt ( efr ) endif xva = ( pqs + rdat % qps ) * rho rho = rho + rho n = 0 if ( xva <= tmax ) then ! Fm(t) evaluation tv = xva * rfinc ( n ) ip = nint ( tv ) fx = fgrid ( 4 , ip , n ) * tv fx = ( fx + fgrid ( 3 , ip , n ) ) * tv fx = ( fx + fgrid ( 2 , ip , n ) ) * tv fx = ( fx + fgrid ( 1 , ip , n ) ) * tv fx = fx + fgrid ( 0 , ip , n ) rdat % fq ( n ) = fx ! T2= xva+xva ! Do m=n,1,-1 ! Rdat%fq(m-1)=(t2*rdat%fq(m)+et)*rmr(m) ! End do fqf = fqz * sqrt ( x41 ) rdat % fq ( 0 ) = rdat % fq ( 0 ) * fqf ! Do 210 m=0,n ! Rdat%fq(m)= rdat%fq(m)*fqf ! 210       fqf= fqf*rho else xin = 1.0_dp / xva rdat % fq ( 0 ) = fqz * sqrt ( pi4 * xin * x41 ) ! Rox= rho*xin ! Fqf= 0.5_dp*rox ! Do 220 m=1,n ! Rdat%fq(m)= rdat%fq(m-1)*fqf ! 220       fqf= fqf+rox endif rdat % fq0 ( 1 ) = rdat % fq0 ( 1 ) + rdat % fq ( 0 ) end do end subroutine intj_01 ! > ! >    @brief   psss case ! > ! >    @details integration of a psss case ! > subroutine intj_02 ( rdat ) implicit none type ( rotaxis_data_t ) :: rdat ! Generate jtype= 2 integrals integer :: i , n , ip real ( kind = dp ) :: fqz , x41 , pqr , pqs , rho , xva real ( kind = dp ) :: tv , fx , efr , fqf , xin , rox rdat % fq0 ( 1 ) = 0.0_dp rdat % fq1 ( 1 , 1 ) = 0.0_dp rdat % fq1 ( 2 , 1 ) = 0.0_dp ! Write(iw,*) 'rdat%ngangb',rdat%ngangb do i = 1 , rdat % ngangb fqz = rdat % sp ( i ) * rdat % sq x41 = rdat % tx12 ( i ) + rdat % x34 if ( fqz * fqz < rdat % cutoff * x41 ) cycle x41 = 1 / x41 pqr = rdat % ty02 ( i ) - rdat % aqz pqs = pqr * pqr rho = rdat % tx12 ( i ) * rdat % x34 * x41 if ( rdat % lrint ) then efr = rdat % emu2 / ( rdat % emu2 + rho ) rho = rho * efr fqz = fqz * sqrt ( efr ) endif xva = ( pqs + rdat % qps ) * rho rho = rho + rho n = 1 if ( xva <= tmax ) then ! Fm(t) evaluation tv = xva * rfinc ( 0 ) ip = nint ( tv ) fx = fgrid ( 4 , ip , 0 ) * tv fx = ( fx + fgrid ( 3 , ip , 0 ) ) * tv fx = ( fx + fgrid ( 2 , ip , 0 ) ) * tv fx = ( fx + fgrid ( 1 , ip , 0 ) ) * tv fx = fx + fgrid ( 0 , ip , 0 ) rdat % fq ( 0 ) = fx tv = xva * rfinc ( n ) ip = nint ( tv ) fx = fgrid ( 4 , ip , n ) * tv fx = ( fx + fgrid ( 3 , ip , n ) ) * tv fx = ( fx + fgrid ( 2 , ip , n ) ) * tv fx = ( fx + fgrid ( 1 , ip , n ) ) * tv fx = fx + fgrid ( 0 , ip , n ) rdat % fq ( n ) = fx ! T2= xva+xva ! Do m=n,1,-1 ! Rdat%fq(m-1)=(t2*rdat%fq(m)+et)*rmr(m) ! End do fqf = fqz * sqrt ( x41 ) rdat % fq ( 0 ) = rdat % fq ( 0 ) * fqf fqf = fqf * rho rdat % fq ( 1 ) = rdat % fq ( 1 ) * fqf ! Do 210 m=0,n ! Rdat%fq(m)= rdat%fq(m)*fqf ! 210       fqf= fqf*rho else xin = 1.0_dp / xva rdat % fq ( 0 ) = fqz * sqrt ( pi4 * xin * x41 ) rox = rho * xin fqf = 0.5_dp * rox rdat % fq ( 1 ) = rdat % fq ( 0 ) * fqf ! Do 220 m=1,n ! Rdat%fq(m)= rdat%fq(m-1)*fqf ! 220       fqf= fqf+rox endif rdat % fq0 ( 1 ) = rdat % fq0 ( 1 ) + rdat % fq ( 0 ) rdat % fq1 ( 1 , 1 ) = rdat % fq1 ( 1 , 1 ) + rdat % fq ( 1 ) rdat % fq1 ( 2 , 1 ) = rdat % fq1 ( 2 , 1 ) + rdat % fq ( 1 ) * pqr ! Write(*,*) 'intj_02',i,rdat%fq0(1),rdat%fq(0) end do end subroutine intj_02 ! > ! >    @brief   ppss case ! > ! >    @details integration of a ppss case ! > subroutine intj_03 ( rdat ) implicit none type ( rotaxis_data_t ) :: rdat ! Generate jtype= 3 integrals integer :: i , n , ip real ( kind = dp ) :: fqz , x41 , pqr , pqs , rho , xva real ( kind = dp ) :: tv , fx , efr , fqf , xin , rox , et , t2 rdat % fq0 ( 1 ) = 0.0_dp rdat % fq1 (:, 1 ) = 0.0_dp rdat % fq2 (:, 1 ) = 0.0_dp do i = 1 , rdat % ngangb fqz = rdat % sp ( i ) * rdat % sq x41 = rdat % tx12 ( i ) + rdat % x34 if ( fqz * fqz < rdat % cutoff * x41 ) cycle x41 = 1 / x41 pqr = rdat % ty02 ( i ) - rdat % aqz pqs = pqr * pqr rho = rdat % tx12 ( i ) * rdat % x34 * x41 if ( rdat % lrint ) then efr = rdat % emu2 / ( rdat % emu2 + rho ) rho = rho * efr fqz = fqz * sqrt ( efr ) endif xva = ( pqs + rdat % qps ) * rho rho = rho + rho n = 2 if ( xva <= tmax ) then ! Fm(t) evaluation tv = xva * rfinc ( n ) ip = nint ( tv ) fx = fgrid ( 4 , ip , n ) * tv fx = ( fx + fgrid ( 3 , ip , n ) ) * tv fx = ( fx + fgrid ( 2 , ip , n ) ) * tv fx = ( fx + fgrid ( 1 , ip , n ) ) * tv fx = fx + fgrid ( 0 , ip , n ) tv = xva * rxinc ip = nint ( tv ) et = xgrid ( 4 , ip ) * tv et = ( et + xgrid ( 3 , ip ) ) * tv et = ( et + xgrid ( 2 , ip ) ) * tv et = ( et + xgrid ( 1 , ip ) ) * tv et = et + xgrid ( 0 , ip ) rdat % fq ( n ) = fx t2 = xva + xva rdat % fq ( 2 - 1 ) = ( t2 * rdat % fq ( 2 ) + et ) * rmr ( 2 ) rdat % fq ( 1 - 1 ) = ( t2 * rdat % fq ( 1 ) + et ) * rmr ( 1 ) ! Do m=n,1,-1 ! Rdat%fq(m-1)=(t2*rdat%fq(m)+et)*rmr(m) ! End do fqf = fqz * sqrt ( x41 ) rdat % fq ( 0 ) = rdat % fq ( 0 ) * fqf fqf = fqf * rho rdat % fq ( 1 ) = rdat % fq ( 1 ) * fqf fqf = fqf * rho rdat % fq ( 2 ) = rdat % fq ( 2 ) * fqf ! Do 210 m=0,n ! Rdat%fq(m)= rdat%fq(m)*fqf ! 210       fqf= fqf*rho else xin = 1.0_dp / xva rdat % fq ( 0 ) = fqz * sqrt ( pi4 * xin * x41 ) rox = rho * xin fqf = 0.5_dp * rox rdat % fq ( 1 ) = rdat % fq ( 0 ) * fqf fqf = fqf + rox rdat % fq ( 2 ) = rdat % fq ( 1 ) * fqf ! Do 220 m=1,n ! Rdat%fq(m)= rdat%fq(m-1)*fqf ! 220       fqf= fqf+rox endif rdat % fq0 ( 1 ) = rdat % fq0 ( 1 ) + rdat % fq ( 0 ) rdat % fq1 ( 1 , 1 ) = rdat % fq1 ( 1 , 1 ) + rdat % fq ( 1 ) rdat % fq1 ( 2 , 1 ) = rdat % fq1 ( 2 , 1 ) + rdat % fq ( 1 ) * pqr rdat % fq2 ( 1 , 1 ) = rdat % fq2 ( 1 , 1 ) + rdat % fq ( 2 ) rdat % fq2 ( 2 , 1 ) = rdat % fq2 ( 2 , 1 ) + rdat % fq ( 2 ) * pqr rdat % fq2 ( 3 , 1 ) = rdat % fq2 ( 3 , 1 ) + rdat % fq ( 2 ) * pqs end do end subroutine intj_03 ! > ! >    @brief   psps case ! > ! >    @details integration of a psps case ! > subroutine intj_04 ( rdat ) implicit none type ( rotaxis_data_t ) :: rdat ! Generate jtype= 4 integrals integer :: i , n , ip real ( kind = dp ) :: fqz , x41 , pqr , pqs , rho , xva real ( kind = dp ) :: tv , fx , efr , fqf , xin , rox , et , t2 real ( kind = dp ) :: xmd1 , y01 , tmp1 , tmp2 rdat % fq0 ( 1 : 2 ) = 0.0_dp rdat % fq1 (:, 1 : 3 ) = 0.0_dp rdat % fq2 ( 1 : 3 , 1 ) = 0.0_dp do i = 1 , rdat % ngangb fqz = rdat % sp ( i ) * rdat % sq x41 = rdat % tx12 ( i ) + rdat % x34 if ( fqz * fqz < rdat % cutoff * x41 ) cycle x41 = 1 / x41 pqr = rdat % ty02 ( i ) - rdat % aqz pqs = pqr * pqr rho = rdat % tx12 ( i ) * rdat % x34 * x41 if ( rdat % lrint ) then efr = rdat % emu2 / ( rdat % emu2 + rho ) rho = rho * efr fqz = fqz * sqrt ( efr ) endif xva = ( pqs + rdat % qps ) * rho rho = rho + rho n = 2 if ( xva <= tmax ) then ! Fm(t) evaluation tv = xva * rfinc ( n ) ip = nint ( tv ) fx = fgrid ( 4 , ip , n ) * tv fx = ( fx + fgrid ( 3 , ip , n ) ) * tv fx = ( fx + fgrid ( 2 , ip , n ) ) * tv fx = ( fx + fgrid ( 1 , ip , n ) ) * tv fx = fx + fgrid ( 0 , ip , n ) tv = xva * rxinc ip = nint ( tv ) et = xgrid ( 4 , ip ) * tv et = ( et + xgrid ( 3 , ip ) ) * tv et = ( et + xgrid ( 2 , ip ) ) * tv et = ( et + xgrid ( 1 , ip ) ) * tv et = et + xgrid ( 0 , ip ) rdat % fq ( n ) = fx t2 = xva + xva rdat % fq ( 2 - 1 ) = ( t2 * rdat % fq ( 2 ) + et ) * rmr ( 2 ) rdat % fq ( 1 - 1 ) = ( t2 * rdat % fq ( 1 ) + et ) * rmr ( 1 ) ! Do m=n,1,-1 ! Rdat%fq(m-1)=(t2*rdat%fq(m)+et)*rmr(m) ! End do fqf = fqz * sqrt ( x41 ) rdat % fq ( 0 ) = rdat % fq ( 0 ) * fqf fqf = fqf * rho rdat % fq ( 1 ) = rdat % fq ( 1 ) * fqf fqf = fqf * rho rdat % fq ( 2 ) = rdat % fq ( 2 ) * fqf ! Do 210 m=0,n ! Rdat%fq(m)= rdat%fq(m)*fqf ! 210       fqf= fqf*rho else xin = 1.0_dp / xva rdat % fq ( 0 ) = fqz * sqrt ( pi4 * xin * x41 ) rox = rho * xin fqf = 0.5_dp * rox rdat % fq ( 1 ) = rdat % fq ( 0 ) * fqf fqf = fqf + rox rdat % fq ( 2 ) = rdat % fq ( 1 ) * fqf ! Do 220 m=1,n ! Rdat%fq(m)= rdat%fq(m-1)*fqf ! 220       fqf= fqf+rox endif xmd1 = 0.5_dp / rdat % tx12 ( i ) y01 = rdat % ty02 ( i ) - rdat % rab tmp1 = xmd1 * pqr tmp2 = xmd1 * pqs rdat % fq0 ( 1 ) = rdat % fq0 ( 1 ) + rdat % fq ( 0 ) rdat % fq0 ( 2 ) = rdat % fq0 ( 2 ) + rdat % fq ( 0 ) * y01 rdat % fq1 ( 1 , 1 ) = rdat % fq1 ( 1 , 1 ) + rdat % fq ( 1 ) rdat % fq1 ( 2 , 1 ) = rdat % fq1 ( 2 , 1 ) + rdat % fq ( 1 ) * pqr rdat % fq1 ( 1 , 2 ) = rdat % fq1 ( 1 , 2 ) + rdat % fq ( 1 ) * xmd1 rdat % fq1 ( 2 , 2 ) = rdat % fq1 ( 2 , 2 ) + rdat % fq ( 1 ) * tmp1 rdat % fq1 ( 1 , 3 ) = rdat % fq1 ( 1 , 3 ) + rdat % fq ( 1 ) * y01 rdat % fq1 ( 2 , 3 ) = rdat % fq1 ( 2 , 3 ) + rdat % fq ( 1 ) * y01 * pqr rdat % fq2 ( 1 , 1 ) = rdat % fq2 ( 1 , 1 ) + rdat % fq ( 2 ) * xmd1 rdat % fq2 ( 2 , 1 ) = rdat % fq2 ( 2 , 1 ) + rdat % fq ( 2 ) * tmp1 rdat % fq2 ( 3 , 1 ) = rdat % fq2 ( 3 , 1 ) + rdat % fq ( 2 ) * tmp2 end do end subroutine intj_04 ! > ! >    @brief   ppps case ! > ! >    @details integration of a ppps case ! > subroutine intj_05 ( rdat ) implicit none type ( rotaxis_data_t ) :: rdat ! Generate jtype= 5 integrals integer :: i , n , ip real ( kind = dp ) :: fqz , x41 , pqr , pqs , rho , xva real ( kind = dp ) :: tv , fx , efr , fqf , xin , rox , et , t2 real ( kind = dp ) :: xmd1 , y01 real ( kind = dp ) :: work ( 3 , 3 ) rdat % fq0 ( 1 : 2 ) = 0.0_dp rdat % fq0 ( 2 ) = 0.0_dp rdat % fq1 (:, 1 : 3 ) = 0.0_dp rdat % fq2 (:, 1 : 3 ) = 0.0_dp rdat % fq3 ( 1 : 4 , 1 ) = 0.0_dp do i = 1 , rdat % ngangb fqz = rdat % sp ( i ) * rdat % sq x41 = rdat % tx12 ( i ) + rdat % x34 if ( fqz * fqz < rdat % cutoff * x41 ) cycle x41 = 1 / x41 pqr = rdat % ty02 ( i ) - rdat % aqz pqs = pqr * pqr rho = rdat % tx12 ( i ) * rdat % x34 * x41 if ( rdat % lrint ) then efr = rdat % emu2 / ( rdat % emu2 + rho ) rho = rho * efr fqz = fqz * sqrt ( efr ) endif xva = ( pqs + rdat % qps ) * rho rho = rho + rho n = 3 if ( xva <= tmax ) then ! Fm(t) evaluation...downward recursion for jtype >= 5 tv = xva * rfinc ( n ) ip = nint ( tv ) fx = fgrid ( 4 , ip , n ) * tv fx = ( fx + fgrid ( 3 , ip , n ) ) * tv fx = ( fx + fgrid ( 2 , ip , n ) ) * tv fx = ( fx + fgrid ( 1 , ip , n ) ) * tv fx = fx + fgrid ( 0 , ip , n ) tv = xva * rxinc ip = nint ( tv ) et = xgrid ( 4 , ip ) * tv et = ( et + xgrid ( 3 , ip ) ) * tv et = ( et + xgrid ( 2 , ip ) ) * tv et = ( et + xgrid ( 1 , ip ) ) * tv et = et + xgrid ( 0 , ip ) rdat % fq ( n ) = fx t2 = xva + xva rdat % fq ( 3 - 1 ) = ( t2 * rdat % fq ( 3 ) + et ) * rmr ( 3 ) rdat % fq ( 2 - 1 ) = ( t2 * rdat % fq ( 2 ) + et ) * rmr ( 2 ) rdat % fq ( 1 - 1 ) = ( t2 * rdat % fq ( 1 ) + et ) * rmr ( 1 ) ! Do m=n,1,-1 ! Rdat%fq(m-1)=(t2*rdat%fq(m)+et)*rmr(m) ! End do fqf = fqz * sqrt ( x41 ) rdat % fq ( 0 ) = rdat % fq ( 0 ) * fqf fqf = fqf * rho rdat % fq ( 1 ) = rdat % fq ( 1 ) * fqf fqf = fqf * rho rdat % fq ( 2 ) = rdat % fq ( 2 ) * fqf fqf = fqf * rho rdat % fq ( 3 ) = rdat % fq ( 3 ) * fqf ! Do 210 m=0,n ! Rdat%fq(m)= rdat%fq(m)*fqf ! 210       fqf= fqf*rho else xin = 1.0_dp / xva rdat % fq ( 0 ) = fqz * sqrt ( pi4 * xin * x41 ) rox = rho * xin fqf = 0.5_dp * rox rdat % fq ( 1 ) = rdat % fq ( 0 ) * fqf fqf = fqf + rox rdat % fq ( 2 ) = rdat % fq ( 1 ) * fqf fqf = fqf + rox rdat % fq ( 3 ) = rdat % fq ( 2 ) * fqf ! Do 220 m=1,n ! Rdat%fq(m)= rdat%fq(m-1)*fqf ! 220       fqf= fqf+rox endif xmd1 = 0.5_dp / rdat % tx12 ( i ) y01 = rdat % ty02 ( i ) - rdat % rab work ( 1 , 1 ) = 1.0d0 work ( 1 , 2 ) = y01 work ( 1 , 3 ) = xmd1 work ( 2 , 1 : 3 ) = work ( 1 , 1 : 3 ) * pqr work ( 3 , 1 : 3 ) = work ( 1 , 1 : 3 ) * pqs rdat % fq0 ( 1 : 2 ) = rdat % fq0 ( 1 : 2 ) + rdat % fq ( 0 ) * work ( 1 , 1 : 2 ) rdat % fq1 ( 1 : 2 , 1 : 3 ) = rdat % fq1 ( 1 : 2 , 1 : 3 ) + rdat % fq ( 1 ) * work ( 1 : 2 , 1 : 3 ) rdat % fq2 ( 1 : 3 , 1 : 3 ) = rdat % fq2 ( 1 : 3 , 1 : 3 ) + rdat % fq ( 2 ) * work ( 1 : 3 , 1 : 3 ) rdat % fq3 ( 1 : 3 , 1 ) = rdat % fq3 ( 1 : 3 , 1 ) + rdat % fq ( 3 ) * work ( 1 : 3 , 3 ) rdat % fq3 ( 4 , 1 ) = rdat % fq3 ( 4 , 1 ) + rdat % fq ( 3 ) * work ( 3 , 3 ) * pqr end do end subroutine intj_05 ! > ! >    @brief   pppp case ! > ! >    @details integration of a pppp case ! > subroutine intj_06 ( rdat ) implicit none type ( rotaxis_data_t ) :: rdat ! Generate jtype= 6 integrals integer :: i , n , ip , m real ( kind = dp ) :: fqz , x41 , pqr , pqs , rho , xva real ( kind = dp ) :: tv , fx , efr , fqf , xin , rox , et , t2 real ( kind = dp ) :: xmd1 , y01 real ( kind = dp ) :: pqt real ( kind = dp ) :: work ( 4 , 9 ) rdat % fq0 = 0.0_dp rdat % fq1 = 0.0_dp rdat % fq2 = 0.0_dp rdat % fq3 = 0.0_dp rdat % fq4 = 0.0_dp do i = 1 , rdat % ngangb fqz = rdat % sp ( i ) * rdat % sq x41 = rdat % tx12 ( i ) + rdat % x34 if ( fqz * fqz < rdat % cutoff * x41 ) cycle x41 = 1 / x41 pqr = rdat % ty02 ( i ) - rdat % aqz pqs = pqr * pqr rho = rdat % tx12 ( i ) * rdat % x34 * x41 if ( rdat % lrint ) then efr = rdat % emu2 / ( rdat % emu2 + rho ) rho = rho * efr fqz = fqz * sqrt ( efr ) endif xva = ( pqs + rdat % qps ) * rho rho = rho + rho n = 4 if ( xva <= tmax ) then ! Fm(t) evaluation...downward recursion for jtype >= 5 tv = xva * rfinc ( n ) ip = nint ( tv ) fx = fgrid ( 4 , ip , n ) * tv fx = ( fx + fgrid ( 3 , ip , n ) ) * tv fx = ( fx + fgrid ( 2 , ip , n ) ) * tv fx = ( fx + fgrid ( 1 , ip , n ) ) * tv fx = fx + fgrid ( 0 , ip , n ) tv = xva * rxinc ip = nint ( tv ) et = xgrid ( 4 , ip ) * tv et = ( et + xgrid ( 3 , ip ) ) * tv et = ( et + xgrid ( 2 , ip ) ) * tv et = ( et + xgrid ( 1 , ip ) ) * tv et = et + xgrid ( 0 , ip ) rdat % fq ( n ) = fx t2 = xva + xva do m = n , 1 , - 1 rdat % fq ( m - 1 ) = ( t2 * rdat % fq ( m ) + et ) * rmr ( m ) enddo fqf = fqz * sqrt ( x41 ) do m = 0 , n rdat % fq ( m ) = rdat % fq ( m ) * fqf fqf = fqf * rho end do else xin = 1.0_dp / xva rdat % fq ( 0 ) = fqz * sqrt ( pi4 * xin * x41 ) rox = rho * xin fqf = 0.5_dp * rox do m = 1 , n rdat % fq ( m ) = rdat % fq ( m - 1 ) * fqf fqf = fqf + rox end do endif pqt = pqr * pqs xmd1 = 0.5_dp / rdat % tx12 ( i ) y01 = rdat % ty02 ( i ) - rdat % rab work ( 1 , 1 ) = 1.0d0 work ( 1 , 2 ) = y01 work ( 1 , 3 ) = rdat % ty02 ( i ) work ( 1 , 4 ) = y01 * rdat % ty02 ( i ) work ( 1 , 5 ) = xmd1 work ( 1 , 6 ) = xmd1 work ( 1 , 7 ) = xmd1 work ( 1 , 8 ) = xmd1 * y01 work ( 1 , 9 ) = xmd1 * xmd1 work ( 2 , 1 : 9 ) = work ( 1 , 1 : 9 ) * pqr work ( 3 , 1 : 9 ) = work ( 1 , 1 : 9 ) * pqs work ( 4 , 5 : 9 ) = work ( 1 , 5 : 9 ) * pqt rdat % fq0 ( 1 : 5 ) = rdat % fq0 ( 1 : 5 ) + rdat % fq ( 0 ) * work ( 1 , 1 : 5 ) rdat % fq1 ( 1 : 2 , 1 : 8 ) = rdat % fq1 ( 1 : 2 , 1 : 8 ) + rdat % fq ( 1 ) * work ( 1 : 2 , 1 : 8 ) rdat % fq1 ( 1 , 9 ) = rdat % fq1 ( 1 , 9 ) + rdat % fq ( 1 ) * work ( 1 , 9 ) rdat % fq2 ( 1 : 3 , 1 : 9 ) = rdat % fq2 ( 1 : 3 , 1 : 9 ) + rdat % fq ( 2 ) * work ( 1 : 3 , 1 : 9 ) rdat % fq3 ( 1 : 4 , 1 : 5 ) = rdat % fq3 ( 1 : 4 , 1 : 5 ) + rdat % fq ( 3 ) * work ( 1 : 4 , 5 : 9 ) rdat % fq4 ( 1 : 4 , 1 ) = rdat % fq4 ( 1 : 4 , 1 ) + rdat % fq ( 4 ) * work ( 1 : 4 , 9 ) rdat % fq4 ( 5 , 1 ) = rdat % fq4 ( 5 , 1 ) + rdat % fq ( 4 ) * work ( 4 , 9 ) * pqr end do end subroutine intj_06 ! > ! >    @brief   dsss case ! > ! >    @details integration of the dsss case ! > subroutine intj_07 ( rdat ) implicit none type ( rotaxis_data_t ) :: rdat ! Generate jtype= 7 integrals integer :: i , n , ip real ( kind = dp ) :: fqz , x41 , pqr , pqs , rho , xva real ( kind = dp ) :: tv , fx , efr , fqf , xin , rox , et , t2 rdat % fq0 ( 1 ) = 0.0_dp rdat % fq1 ( 1 : 2 , 1 ) = 0.0_dp rdat % fq2 ( 1 : 3 , 1 ) = 0.0_dp do i = 1 , rdat % ngangb fqz = rdat % sp ( i ) * rdat % sq x41 = rdat % tx12 ( i ) + rdat % x34 if ( fqz * fqz < rdat % cutoff * x41 ) cycle x41 = 1 / x41 pqr = rdat % ty02 ( i ) - rdat % aqz pqs = pqr * pqr rho = rdat % tx12 ( i ) * rdat % x34 * x41 if ( rdat % lrint ) then efr = rdat % emu2 / ( rdat % emu2 + rho ) rho = rho * efr fqz = fqz * sqrt ( efr ) endif xva = ( pqs + rdat % qps ) * rho rho = rho + rho n = 2 if ( xva <= tmax ) then ! Fm(t) evaluation tv = xva * rfinc ( n ) ip = nint ( tv ) fx = fgrid ( 4 , ip , n ) * tv fx = ( fx + fgrid ( 3 , ip , n )) * tv fx = ( fx + fgrid ( 2 , ip , n )) * tv fx = ( fx + fgrid ( 1 , ip , n )) * tv fx = fx + fgrid ( 0 , ip , n ) tv = xva * rxinc ip = nint ( tv ) et = xgrid ( 4 , ip ) * tv et = ( et + xgrid ( 3 , ip )) * tv et = ( et + xgrid ( 2 , ip )) * tv et = ( et + xgrid ( 1 , ip )) * tv et = et + xgrid ( 0 , ip ) rdat % fq ( n ) = fx t2 = xva + xva rdat % fq ( 2 - 1 ) = ( t2 * rdat % fq ( 2 ) + et ) * rmr ( 2 ) rdat % fq ( 1 - 1 ) = ( t2 * rdat % fq ( 1 ) + et ) * rmr ( 1 ) ! Do m=n,1,-1 ! Rdat%fq(m-1)=(t2*rdat%fq(m)+et)*rmr(m) ! End do fqf = fqz * sqrt ( x41 ) rdat % fq ( 0 ) = rdat % fq ( 0 ) * fqf fqf = fqf * rho rdat % fq ( 1 ) = rdat % fq ( 1 ) * fqf fqf = fqf * rho rdat % fq ( 2 ) = rdat % fq ( 2 ) * fqf ! Do 210 m=0,n ! Rdat%fq(m)= rdat%fq(m)*fqf ! 210       fqf= fqf*rho else xin = 1.0_dp / xva rdat % fq ( 0 ) = fqz * sqrt ( pi4 * xin * x41 ) rox = rho * xin fqf = 0.5_dp * rox rdat % fq ( 1 ) = rdat % fq ( 0 ) * fqf fqf = fqf + rox rdat % fq ( 2 ) = rdat % fq ( 1 ) * fqf ! Do 220 m=1,n ! Rdat%fq(m)= rdat%fq(m-1)*fqf ! 220       fqf= fqf+rox endif rdat % fq0 ( 1 ) = rdat % fq0 ( 1 ) + rdat % fq ( 0 ) rdat % fq1 ( 1 , 1 ) = rdat % fq1 ( 1 , 1 ) + rdat % fq ( 1 ) rdat % fq1 ( 2 , 1 ) = rdat % fq1 ( 2 , 1 ) + rdat % fq ( 1 ) * pqr rdat % fq2 ( 1 , 1 ) = rdat % fq2 ( 1 , 1 ) + rdat % fq ( 2 ) rdat % fq2 ( 2 , 1 ) = rdat % fq2 ( 2 , 1 ) + rdat % fq ( 2 ) * pqr rdat % fq2 ( 3 , 1 ) = rdat % fq2 ( 3 , 1 ) + rdat % fq ( 2 ) * pqs end do end subroutine intj_07 ! > ! >    @brief   dpss case ! > ! >    @details integration of the dpss case ! > subroutine intj_08 ( rdat ) implicit none type ( rotaxis_data_t ) :: rdat ! Generate jtype= 8 integrals integer :: i , n , ip real ( kind = dp ) :: fqz , x41 , pqr , pqs , rho , xva real ( kind = dp ) :: tv , fx , efr , fqf , xin , rox , et , t2 rdat % fq0 ( 1 ) = 0.0_dp rdat % fq1 ( 1 : 2 , 1 ) = 0.0_dp rdat % fq2 ( 1 : 3 , 1 ) = 0.0_dp rdat % fq3 ( 1 : 4 , 1 ) = 0.0_dp do i = 1 , rdat % ngangb fqz = rdat % sp ( i ) * rdat % sq x41 = rdat % tx12 ( i ) + rdat % x34 if ( fqz * fqz < rdat % cutoff * x41 ) cycle x41 = 1 / x41 pqr = rdat % ty02 ( i ) - rdat % aqz pqs = pqr * pqr rho = rdat % tx12 ( i ) * rdat % x34 * x41 if ( rdat % lrint ) then efr = rdat % emu2 / ( rdat % emu2 + rho ) rho = rho * efr fqz = fqz * sqrt ( efr ) endif xva = ( pqs + rdat % qps ) * rho rho = rho + rho n = 3 if ( xva <= tmax ) then ! Fm(t) evaluation...downward recursion for m=3 tv = xva * rfinc ( n ) ip = nint ( tv ) fx = fgrid ( 4 , ip , n ) * tv fx = ( fx + fgrid ( 3 , ip , n )) * tv fx = ( fx + fgrid ( 2 , ip , n )) * tv fx = ( fx + fgrid ( 1 , ip , n )) * tv fx = fx + fgrid ( 0 , ip , n ) tv = xva * rxinc ip = nint ( tv ) et = xgrid ( 4 , ip ) * tv et = ( et + xgrid ( 3 , ip )) * tv et = ( et + xgrid ( 2 , ip )) * tv et = ( et + xgrid ( 1 , ip )) * tv et = et + xgrid ( 0 , ip ) rdat % fq ( n ) = fx t2 = xva + xva rdat % fq ( 3 - 1 ) = ( t2 * rdat % fq ( 3 ) + et ) * rmr ( 3 ) rdat % fq ( 2 - 1 ) = ( t2 * rdat % fq ( 2 ) + et ) * rmr ( 2 ) rdat % fq ( 1 - 1 ) = ( t2 * rdat % fq ( 1 ) + et ) * rmr ( 1 ) ! Do m=n,1,-1 ! Rdat%fq(m-1)=(t2*rdat%fq(m)+et)*rmr(m) ! End do fqf = fqz * sqrt ( x41 ) rdat % fq ( 0 ) = rdat % fq ( 0 ) * fqf fqf = fqf * rho rdat % fq ( 1 ) = rdat % fq ( 1 ) * fqf fqf = fqf * rho rdat % fq ( 2 ) = rdat % fq ( 2 ) * fqf fqf = fqf * rho rdat % fq ( 3 ) = rdat % fq ( 3 ) * fqf ! Do 210 m=0,n ! Rdat%fq(m)= rdat%fq(m)*fqf ! 210       fqf= fqf*rho else xin = 1.0_dp / xva rdat % fq ( 0 ) = fqz * sqrt ( pi4 * xin * x41 ) rox = rho * xin fqf = 0.5_dp * rox rdat % fq ( 1 ) = rdat % fq ( 0 ) * fqf fqf = fqf + rox rdat % fq ( 2 ) = rdat % fq ( 1 ) * fqf fqf = fqf + rox rdat % fq ( 3 ) = rdat % fq ( 2 ) * fqf ! Do 220 m=1,n ! Rdat%fq(m)= rdat%fq(m-1)*fqf ! 220       fqf= fqf+rox endif rdat % fq0 ( 1 ) = rdat % fq0 ( 1 ) + rdat % fq ( 0 ) rdat % fq1 ( 1 , 1 ) = rdat % fq1 ( 1 , 1 ) + rdat % fq ( 1 ) rdat % fq1 ( 2 , 1 ) = rdat % fq1 ( 2 , 1 ) + rdat % fq ( 1 ) * pqr rdat % fq2 ( 1 , 1 ) = rdat % fq2 ( 1 , 1 ) + rdat % fq ( 2 ) rdat % fq2 ( 2 , 1 ) = rdat % fq2 ( 2 , 1 ) + rdat % fq ( 2 ) * pqr rdat % fq2 ( 3 , 1 ) = rdat % fq2 ( 3 , 1 ) + rdat % fq ( 2 ) * pqs rdat % fq3 ( 1 , 1 ) = rdat % fq3 ( 1 , 1 ) + rdat % fq ( 3 ) rdat % fq3 ( 2 , 1 ) = rdat % fq3 ( 2 , 1 ) + rdat % fq ( 3 ) * pqr rdat % fq3 ( 3 , 1 ) = rdat % fq3 ( 3 , 1 ) + rdat % fq ( 3 ) * pqs rdat % fq3 ( 4 , 1 ) = rdat % fq3 ( 4 , 1 ) + rdat % fq ( 3 ) * pqs * pqr end do end subroutine intj_08 ! > ! >    @brief   dsps case ! > ! >    @details integration of the dsps case ! > subroutine intj_09 ( rdat ) implicit none type ( rotaxis_data_t ) :: rdat ! Generate jtype= 9 integrals integer :: i , n , ip real ( kind = dp ) :: fqz , x41 , pqr , pqs , rho , xva real ( kind = dp ) :: tv , fx , efr , fqf , xin , rox , et , t2 real ( kind = dp ) :: work dimension work ( 3 , 3 ) rdat % fq0 ( 1 : 2 ) = 0.0_dp rdat % fq1 ( 1 : 2 , 1 : 3 ) = 0.0_dp rdat % fq2 ( 1 : 3 , 1 : 3 ) = 0.0_dp rdat % fq3 ( 1 : 4 , 1 ) = 0.0_dp do i = 1 , rdat % ngangb fqz = rdat % sp ( i ) * rdat % sq x41 = rdat % tx12 ( i ) + rdat % x34 if ( fqz * fqz < rdat % cutoff * x41 ) cycle x41 = 1 / x41 pqr = rdat % ty02 ( i ) - rdat % aqz pqs = pqr * pqr rho = rdat % tx12 ( i ) * rdat % x34 * x41 if ( rdat % lrint ) then efr = rdat % emu2 / ( rdat % emu2 + rho ) rho = rho * efr fqz = fqz * sqrt ( efr ) endif xva = ( pqs + rdat % qps ) * rho rho = rho + rho n = 3 if ( xva <= tmax ) then ! Fm(t) evaluation...downward recursion for m=3 tv = xva * rfinc ( n ) ip = nint ( tv ) fx = fgrid ( 4 , ip , n ) * tv fx = ( fx + fgrid ( 3 , ip , n )) * tv fx = ( fx + fgrid ( 2 , ip , n )) * tv fx = ( fx + fgrid ( 1 , ip , n )) * tv fx = fx + fgrid ( 0 , ip , n ) tv = xva * rxinc ip = nint ( tv ) et = xgrid ( 4 , ip ) * tv et = ( et + xgrid ( 3 , ip )) * tv et = ( et + xgrid ( 2 , ip )) * tv et = ( et + xgrid ( 1 , ip )) * tv et = et + xgrid ( 0 , ip ) rdat % fq ( n ) = fx t2 = xva + xva rdat % fq ( 3 - 1 ) = ( t2 * rdat % fq ( 3 ) + et ) * rmr ( 3 ) rdat % fq ( 2 - 1 ) = ( t2 * rdat % fq ( 2 ) + et ) * rmr ( 2 ) rdat % fq ( 1 - 1 ) = ( t2 * rdat % fq ( 1 ) + et ) * rmr ( 1 ) ! Do m=n,1,-1 ! Rdat%fq(m-1)=(t2*rdat%fq(m)+et)*rmr(m) ! End do fqf = fqz * sqrt ( x41 ) rdat % fq ( 0 ) = rdat % fq ( 0 ) * fqf fqf = fqf * rho rdat % fq ( 1 ) = rdat % fq ( 1 ) * fqf fqf = fqf * rho rdat % fq ( 2 ) = rdat % fq ( 2 ) * fqf fqf = fqf * rho rdat % fq ( 3 ) = rdat % fq ( 3 ) * fqf ! Do 210 m=0,n ! Rdat%fq(m)= rdat%fq(m)*fqf ! 210       fqf= fqf*rho else xin = 1.0_dp / xva rdat % fq ( 0 ) = fqz * sqrt ( pi4 * xin * x41 ) rox = rho * xin fqf = 0.5_dp * rox rdat % fq ( 1 ) = rdat % fq ( 0 ) * fqf fqf = fqf + rox rdat % fq ( 2 ) = rdat % fq ( 1 ) * fqf fqf = fqf + rox rdat % fq ( 3 ) = rdat % fq ( 2 ) * fqf ! Do 220 m=1,n ! Rdat%fq(m)= rdat%fq(m-1)*fqf ! 220       fqf= fqf+rox endif work ( 1 , 1 ) = 1.0d0 work ( 1 , 2 ) = rdat % ty02 ( i ) - rdat % rab work ( 1 , 3 ) = 0.5_dp / rdat % tx12 ( i ) work ( 2 , 1 : 3 ) = work ( 1 , 1 : 3 ) * pqr work ( 3 , 1 : 3 ) = work ( 1 , 1 : 3 ) * pqs rdat % fq0 ( 1 : 2 ) = rdat % fq0 ( 1 : 2 ) + rdat % fq ( 0 ) * work ( 1 , 1 : 2 ) rdat % fq1 ( 1 : 2 , 1 : 3 ) = rdat % fq1 ( 1 : 2 , 1 : 3 ) + rdat % fq ( 1 ) * work ( 1 : 2 , 1 : 3 ) rdat % fq2 ( 1 : 3 , 1 : 3 ) = rdat % fq2 ( 1 : 3 , 1 : 3 ) + rdat % fq ( 2 ) * work ( 1 : 3 , 1 : 3 ) rdat % fq3 ( 1 : 3 , 1 ) = rdat % fq3 ( 1 : 3 , 1 ) + rdat % fq ( 3 ) * work ( 1 : 3 , 3 ) rdat % fq3 ( 4 , 1 ) = rdat % fq3 ( 4 , 1 ) + rdat % fq ( 3 ) * work ( 3 , 3 ) * pqr end do end subroutine intj_09 ! > ! >    @brief   ddss case ! > ! >    @details integration of the ddss case ! > subroutine intj_10 ( rdat ) implicit none type ( rotaxis_data_t ) :: rdat ! Generate jtype=10 integrals integer :: i , n , ip , m real ( kind = dp ) :: fqz , x41 , pqr , pqs , rho , xva real ( kind = dp ) :: tv , fx , efr , fqf , xin , rox , et , t2 real ( kind = dp ) :: pqq , pqt rdat % fq0 ( 1 ) = 0.0_dp rdat % fq1 ( 1 : 2 , 1 ) = 0.0_dp rdat % fq2 ( 1 : 3 , 1 ) = 0.0_dp rdat % fq3 ( 1 : 4 , 1 ) = 0.0_dp rdat % fq4 ( 1 : 5 , 1 ) = 0.0_dp do i = 1 , rdat % ngangb fqz = rdat % sp ( i ) * rdat % sq x41 = rdat % tx12 ( i ) + rdat % x34 if ( fqz * fqz < rdat % cutoff * x41 ) cycle x41 = 1 / x41 pqr = rdat % ty02 ( i ) - rdat % aqz pqs = pqr * pqr rho = rdat % tx12 ( i ) * rdat % x34 * x41 if ( rdat % lrint ) then efr = rdat % emu2 / ( rdat % emu2 + rho ) rho = rho * efr fqz = fqz * sqrt ( efr ) endif xva = ( pqs + rdat % qps ) * rho rho = rho + rho n = 4 if ( xva <= tmax ) then ! Fm(t) evaluation...downward recursion for m=4 tv = xva * rfinc ( n ) ip = nint ( tv ) fx = fgrid ( 4 , ip , n ) * tv fx = ( fx + fgrid ( 3 , ip , n )) * tv fx = ( fx + fgrid ( 2 , ip , n )) * tv fx = ( fx + fgrid ( 1 , ip , n )) * tv fx = fx + fgrid ( 0 , ip , n ) tv = xva * rxinc ip = nint ( tv ) et = xgrid ( 4 , ip ) * tv et = ( et + xgrid ( 3 , ip )) * tv et = ( et + xgrid ( 2 , ip )) * tv et = ( et + xgrid ( 1 , ip )) * tv et = et + xgrid ( 0 , ip ) rdat % fq ( n ) = fx t2 = xva + xva do m = n , 1 , - 1 rdat % fq ( m - 1 ) = ( t2 * rdat % fq ( m ) + et ) * rmr ( m ) end do fqf = fqz * sqrt ( x41 ) do m = 0 , n rdat % fq ( m ) = rdat % fq ( m ) * fqf fqf = fqf * rho end do else xin = 1.0_dp / xva rdat % fq ( 0 ) = fqz * sqrt ( pi4 * xin * x41 ) rox = rho * xin fqf = 0.5_dp * rox do m = 1 , n rdat % fq ( m ) = rdat % fq ( m - 1 ) * fqf fqf = fqf + rox end do endif pqt = pqs * pqr pqq = pqs * pqs rdat % fq0 ( 1 ) = rdat % fq0 ( 1 ) + rdat % fq ( 0 ) rdat % fq1 ( 1 , 1 ) = rdat % fq1 ( 1 , 1 ) + rdat % fq ( 1 ) rdat % fq1 ( 2 , 1 ) = rdat % fq1 ( 2 , 1 ) + rdat % fq ( 1 ) * pqr rdat % fq2 ( 1 , 1 ) = rdat % fq2 ( 1 , 1 ) + rdat % fq ( 2 ) rdat % fq2 ( 2 , 1 ) = rdat % fq2 ( 2 , 1 ) + rdat % fq ( 2 ) * pqr rdat % fq2 ( 3 , 1 ) = rdat % fq2 ( 3 , 1 ) + rdat % fq ( 2 ) * pqs rdat % fq3 ( 1 , 1 ) = rdat % fq3 ( 1 , 1 ) + rdat % fq ( 3 ) rdat % fq3 ( 2 , 1 ) = rdat % fq3 ( 2 , 1 ) + rdat % fq ( 3 ) * pqr rdat % fq3 ( 3 , 1 ) = rdat % fq3 ( 3 , 1 ) + rdat % fq ( 3 ) * pqs rdat % fq3 ( 4 , 1 ) = rdat % fq3 ( 4 , 1 ) + rdat % fq ( 3 ) * pqt rdat % fq4 ( 1 , 1 ) = rdat % fq4 ( 1 , 1 ) + rdat % fq ( 4 ) rdat % fq4 ( 2 , 1 ) = rdat % fq4 ( 2 , 1 ) + rdat % fq ( 4 ) * pqr rdat % fq4 ( 3 , 1 ) = rdat % fq4 ( 3 , 1 ) + rdat % fq ( 4 ) * pqs rdat % fq4 ( 4 , 1 ) = rdat % fq4 ( 4 , 1 ) + rdat % fq ( 4 ) * pqt rdat % fq4 ( 5 , 1 ) = rdat % fq4 ( 5 , 1 ) + rdat % fq ( 4 ) * pqq end do end subroutine intj_10 ! > ! >    @brief   dpps case ! > ! >    @details integration of the dpps case ! > subroutine intj_11 ( rdat ) implicit none type ( rotaxis_data_t ) :: rdat ! Generate jtype=11 integrals integer :: i , n , ip , j , m real ( kind = dp ) :: fqz , x41 , pqr , pqs , rho , xva real ( kind = dp ) :: tv , fx , efr , fqf , xin , rox , et , t2 real ( kind = dp ) :: pqt , work dimension work ( 4 , 3 ) rdat % fq0 ( 1 : 2 ) = 0.0_dp rdat % fq1 (:, 1 : 3 ) = 0.0_dp rdat % fq2 (:, 1 : 3 ) = 0.0_dp rdat % fq3 (:, 1 : 3 ) = 0.0_dp rdat % fq4 (:, 1 ) = 0.0_dp do i = 1 , rdat % ngangb fqz = rdat % sp ( i ) * rdat % sq x41 = rdat % tx12 ( i ) + rdat % x34 if ( fqz * fqz < rdat % cutoff * x41 ) cycle x41 = 1 / x41 pqr = rdat % ty02 ( i ) - rdat % aqz pqs = pqr * pqr rho = rdat % tx12 ( i ) * rdat % x34 * x41 if ( rdat % lrint ) then efr = rdat % emu2 / ( rdat % emu2 + rho ) rho = rho * efr fqz = fqz * sqrt ( efr ) endif xva = ( pqs + rdat % qps ) * rho rho = rho + rho n = 4 if ( xva <= tmax ) then ! Fm(t) evaluation...downward recursion for m=4 tv = xva * rfinc ( n ) ip = nint ( tv ) fx = fgrid ( 4 , ip , n ) * tv fx = ( fx + fgrid ( 3 , ip , n )) * tv fx = ( fx + fgrid ( 2 , ip , n )) * tv fx = ( fx + fgrid ( 1 , ip , n )) * tv fx = fx + fgrid ( 0 , ip , n ) tv = xva * rxinc ip = nint ( tv ) et = xgrid ( 4 , ip ) * tv et = ( et + xgrid ( 3 , ip )) * tv et = ( et + xgrid ( 2 , ip )) * tv et = ( et + xgrid ( 1 , ip )) * tv et = et + xgrid ( 0 , ip ) rdat % fq ( n ) = fx t2 = xva + xva do m = n , 1 , - 1 rdat % fq ( m - 1 ) = ( t2 * rdat % fq ( m ) + et ) * rmr ( m ) end do fqf = fqz * sqrt ( x41 ) do m = 0 , n rdat % fq ( m ) = rdat % fq ( m ) * fqf fqf = fqf * rho end do else xin = 1.0_dp / xva rdat % fq ( 0 ) = fqz * sqrt ( pi4 * xin * x41 ) rox = rho * xin fqf = 0.5_dp * rox do m = 1 , n rdat % fq ( m ) = rdat % fq ( m - 1 ) * fqf fqf = fqf + rox end do endif pqt = pqr * pqs work ( 1 , 1 ) = 1.0d0 work ( 1 , 2 ) = rdat % ty02 ( i ) - rdat % rab work ( 1 , 3 ) = 0.5_dp / rdat % tx12 ( i ) do j = 1 , 3 work ( 2 , j ) = work ( 1 , j ) * pqr work ( 3 , j ) = work ( 1 , j ) * pqs work ( 4 , j ) = work ( 1 , j ) * pqt enddo rdat % fq0 ( 1 ) = rdat % fq0 ( 1 ) + rdat % fq ( 0 ) * work ( 1 , 1 ) rdat % fq0 ( 2 ) = rdat % fq0 ( 2 ) + rdat % fq ( 0 ) * work ( 1 , 2 ) rdat % fq1 (:, 1 : 3 ) = rdat % fq1 (:, 1 : 3 ) + rdat % fq ( 1 ) * work ( 1 : 2 , 1 : 3 ) rdat % fq2 (:, 1 : 3 ) = rdat % fq2 (:, 1 : 3 ) + rdat % fq ( 2 ) * work ( 1 : 3 , 1 : 3 ) rdat % fq3 (:, 1 : 3 ) = rdat % fq3 (:, 1 : 3 ) + rdat % fq ( 3 ) * work (:, 1 : 3 ) rdat % fq4 ( 1 : 4 , 1 ) = rdat % fq4 ( 1 : 4 , 1 ) + rdat % fq ( 4 ) * work ( 1 : 4 , 3 ) rdat % fq4 ( 5 , 1 ) = rdat % fq4 ( 5 , 1 ) + rdat % fq ( 4 ) * work ( 4 , 3 ) * pqr end do end subroutine intj_11 ! > ! >    @brief   dsds case ! > ! >    @details integration of the dsds case ! > subroutine intj_12 ( rdat ) implicit none type ( rotaxis_data_t ) :: rdat ! Generate jtype=12 integrals integer :: i , n , ip , j , m real ( kind = dp ) :: fqz , x41 , pqr , pqs , rho , xva real ( kind = dp ) :: tv , fx , efr , fqf , xin , rox , et , t2 real ( kind = dp ) :: pqt , xmd1 , y01 , work dimension work ( 4 , 4 ) rdat % fq0 ( 1 : 2 ) = 0.0_dp rdat % fq1 (:, 1 : 4 ) = 0.0_dp rdat % fq2 (:, 1 : 4 ) = 0.0_dp rdat % fq3 (:, 1 : 2 ) = 0.0_dp rdat % fq4 (:, 1 ) = 0.0_dp do i = 1 , rdat % ngangb fqz = rdat % sp ( i ) * rdat % sq x41 = rdat % tx12 ( i ) + rdat % x34 if ( fqz * fqz < rdat % cutoff * x41 ) cycle x41 = 1 / x41 pqr = rdat % ty02 ( i ) - rdat % aqz pqs = pqr * pqr rho = rdat % tx12 ( i ) * rdat % x34 * x41 if ( rdat % lrint ) then efr = rdat % emu2 / ( rdat % emu2 + rho ) rho = rho * efr fqz = fqz * sqrt ( efr ) endif xva = ( pqs + rdat % qps ) * rho rho = rho + rho n = 4 if ( xva <= tmax ) then ! Fm(t) evaluation...downward recursion for m=4 tv = xva * rfinc ( n ) ip = nint ( tv ) fx = fgrid ( 4 , ip , n ) * tv fx = ( fx + fgrid ( 3 , ip , n )) * tv fx = ( fx + fgrid ( 2 , ip , n )) * tv fx = ( fx + fgrid ( 1 , ip , n )) * tv fx = fx + fgrid ( 0 , ip , n ) tv = xva * rxinc ip = nint ( tv ) et = xgrid ( 4 , ip ) * tv et = ( et + xgrid ( 3 , ip )) * tv et = ( et + xgrid ( 2 , ip )) * tv et = ( et + xgrid ( 1 , ip )) * tv et = et + xgrid ( 0 , ip ) rdat % fq ( n ) = fx t2 = xva + xva do m = n , 1 , - 1 rdat % fq ( m - 1 ) = ( t2 * rdat % fq ( m ) + et ) * rmr ( m ) end do fqf = fqz * sqrt ( x41 ) do m = 0 , n rdat % fq ( m ) = rdat % fq ( m ) * fqf fqf = fqf * rho end do else xin = 1.0_dp / xva rdat % fq ( 0 ) = fqz * sqrt ( pi4 * xin * x41 ) rox = rho * xin fqf = 0.5_dp * rox do m = 1 , n rdat % fq ( m ) = rdat % fq ( m - 1 ) * fqf fqf = fqf + rox end do endif pqt = pqr * pqs xmd1 = 0.5_dp / rdat % tx12 ( i ) y01 = rdat % ty02 ( i ) - rdat % rab work ( 1 , 1 ) = xmd1 work ( 1 , 2 ) = y01 * y01 work ( 1 , 3 ) = xmd1 * y01 work ( 1 , 4 ) = xmd1 * xmd1 do j = 1 , 4 work ( 2 , j ) = work ( 1 , j ) * pqr work ( 3 , j ) = work ( 1 , j ) * pqs enddo work ( 4 , 3 ) = work ( 1 , 3 ) * pqt work ( 4 , 4 ) = work ( 1 , 4 ) * pqt rdat % fq0 ( 1 : 2 ) = rdat % fq0 ( 1 : 2 ) + rdat % fq ( 0 ) * work ( 1 , 1 : 2 ) rdat % fq1 (:, 1 : 3 ) = rdat % fq1 (:, 1 : 3 ) + rdat % fq ( 1 ) * work ( 1 : 2 , 1 : 3 ) rdat % fq1 ( 1 , 4 ) = rdat % fq1 ( 1 , 4 ) + rdat % fq ( 1 ) * work ( 1 , 4 ) rdat % fq2 (:, 1 : 4 ) = rdat % fq2 (:, 1 : 4 ) + rdat % fq ( 2 ) * work ( 1 : 3 , 1 : 4 ) rdat % fq3 (:, 1 : 2 ) = rdat % fq3 (:, 1 : 2 ) + rdat % fq ( 3 ) * work (:, 3 : 4 ) rdat % fq4 ( 1 : 4 , 1 ) = rdat % fq4 ( 1 : 4 , 1 ) + rdat % fq ( 4 ) * work ( 1 : 4 , 4 ) rdat % fq4 ( 5 , 1 ) = rdat % fq4 ( 5 , 1 ) + rdat % fq ( 4 ) * work ( 4 , 4 ) * pqr end do end subroutine intj_12 ! > ! >    @brief   dspp case ! > ! >    @details integration of the dspp case ! > subroutine intj_13 ( rdat ) implicit none type ( rotaxis_data_t ) :: rdat ! Generate jtype=13 integrals integer :: i , n , ip , m real ( kind = dp ) :: fqz , x41 , pqr , pqs , rho , xva real ( kind = dp ) :: tv , fx , efr , fqf , xin , rox , et , t2 real ( kind = dp ) :: pqt , xmd1 , y01 , work dimension work ( 4 , 9 ) rdat % fq0 (:) = 0.0_dp rdat % fq1 (:, 1 : 9 ) = 0.0_dp rdat % fq2 (:, 1 : 9 ) = 0.0_dp rdat % fq3 (:, 1 : 5 ) = 0.0_dp rdat % fq4 ( 1 : 5 , 1 ) = 0.0_dp do i = 1 , rdat % ngangb fqz = rdat % sp ( i ) * rdat % sq x41 = rdat % tx12 ( i ) + rdat % x34 if ( fqz * fqz < rdat % cutoff * x41 ) cycle x41 = 1 / x41 pqr = rdat % ty02 ( i ) - rdat % aqz pqs = pqr * pqr rho = rdat % tx12 ( i ) * rdat % x34 * x41 if ( rdat % lrint ) then efr = rdat % emu2 / ( rdat % emu2 + rho ) rho = rho * efr fqz = fqz * sqrt ( efr ) endif xva = ( pqs + rdat % qps ) * rho rho = rho + rho n = 4 if ( xva <= tmax ) then ! Fm(t) evaluation...downward recursion for m=4 tv = xva * rfinc ( n ) ip = nint ( tv ) fx = fgrid ( 4 , ip , n ) * tv fx = ( fx + fgrid ( 3 , ip , n )) * tv fx = ( fx + fgrid ( 2 , ip , n )) * tv fx = ( fx + fgrid ( 1 , ip , n )) * tv fx = fx + fgrid ( 0 , ip , n ) tv = xva * rxinc ip = nint ( tv ) et = xgrid ( 4 , ip ) * tv et = ( et + xgrid ( 3 , ip )) * tv et = ( et + xgrid ( 2 , ip )) * tv et = ( et + xgrid ( 1 , ip )) * tv et = et + xgrid ( 0 , ip ) rdat % fq ( n ) = fx t2 = xva + xva do m = n , 1 , - 1 rdat % fq ( m - 1 ) = ( t2 * rdat % fq ( m ) + et ) * rmr ( m ) end do fqf = fqz * sqrt ( x41 ) do m = 0 , n rdat % fq ( m ) = rdat % fq ( m ) * fqf fqf = fqf * rho end do else xin = 1.0_dp / xva rdat % fq ( 0 ) = fqz * sqrt ( pi4 * xin * x41 ) rox = rho * xin fqf = 0.5_dp * rox do m = 1 , n rdat % fq ( m ) = rdat % fq ( m - 1 ) * fqf fqf = fqf + rox end do endif pqt = pqr * pqs xmd1 = 0.5_dp / rdat % tx12 ( i ) y01 = rdat % ty02 ( i ) - rdat % rab work ( 1 , 1 ) = 1.0d0 work ( 1 , 2 ) = y01 work ( 1 , 3 ) = rdat % ty02 ( i ) work ( 1 , 4 ) = y01 * rdat % ty02 ( i ) work ( 1 , 5 ) = xmd1 work ( 1 , 6 ) = xmd1 work ( 1 , 7 ) = xmd1 work ( 1 , 8 ) = xmd1 * y01 work ( 1 , 9 ) = xmd1 * xmd1 work ( 2 , 1 : 9 ) = work ( 1 , 1 : 9 ) * pqr work ( 3 , 1 : 9 ) = work ( 1 , 1 : 9 ) * pqs work ( 4 , 5 : 9 ) = work ( 1 , 5 : 9 ) * pqt rdat % fq0 ( 1 : 5 ) = rdat % fq0 ( 1 : 5 ) + rdat % fq ( 0 ) * work ( 1 , 1 : 5 ) rdat % fq1 (:, 1 : 8 ) = rdat % fq1 (:, 1 : 8 ) + rdat % fq ( 1 ) * work ( 1 : 2 , 1 : 8 ) rdat % fq1 ( 1 , 9 ) = rdat % fq1 ( 1 , 9 ) + rdat % fq ( 1 ) * work ( 1 , 9 ) rdat % fq2 (:, 1 : 9 ) = rdat % fq2 (:, 1 : 9 ) + rdat % fq ( 2 ) * work ( 1 : 3 , 1 : 9 ) rdat % fq3 (:, 1 : 5 ) = rdat % fq3 (:, 1 : 5 ) + rdat % fq ( 3 ) * work ( 1 : 4 , 5 : 9 ) rdat % fq4 ( 1 : 4 , 1 ) = rdat % fq4 ( 1 : 4 , 1 ) + rdat % fq ( 4 ) * work ( 1 : 4 , 9 ) rdat % fq4 ( 5 , 1 ) = rdat % fq4 ( 5 , 1 ) + rdat % fq ( 4 ) * work ( 4 , 9 ) * pqr end do end subroutine intj_13 ! > ! >    @brief   ddps case ! > ! >    @details integration of the ddps case ! > subroutine intj_14 ( rdat ) implicit none type ( rotaxis_data_t ) :: rdat ! Generate jtype=14 integrals integer :: i , n , ip , j , m real ( kind = dp ) :: fqz , x41 , pqr , pqs , rho , xva real ( kind = dp ) :: tv , fx , efr , fqf , xin , rox , et , t2 real ( kind = dp ) :: pqt , pqq , work dimension work ( 5 , 3 ) rdat % fq0 ( 1 : 2 ) = 0.0_dp rdat % fq1 (:, 1 : 3 ) = 0.0_dp rdat % fq2 (:, 1 : 3 ) = 0.0_dp rdat % fq3 (:, 1 : 3 ) = 0.0_dp rdat % fq4 (:, 1 : 3 ) = 0.0_dp rdat % fq5 (:, 1 ) = 0.0_dp do i = 1 , rdat % ngangb fqz = rdat % sp ( i ) * rdat % sq x41 = rdat % tx12 ( i ) + rdat % x34 if ( fqz * fqz < rdat % cutoff * x41 ) cycle x41 = 1 / x41 pqr = rdat % ty02 ( i ) - rdat % aqz pqs = pqr * pqr rho = rdat % tx12 ( i ) * rdat % x34 * x41 if ( rdat % lrint ) then efr = rdat % emu2 / ( rdat % emu2 + rho ) rho = rho * efr fqz = fqz * sqrt ( efr ) endif xva = ( pqs + rdat % qps ) * rho rho = rho + rho n = 5 if ( xva <= tmax ) then ! Fm(t) m=5 interpolation, generating wasted m=8,7,6 data ! Fgrid(,,x) for  x=0,1,2,3,4,5, 6, 7 holds necessary data to ! Interpolate for m=0,1,2,3,4,8,12,16. ! Here m=5, so we must generate m=8,7,6 values we don't use. ! Downward recursion is used for greater numerical stability. ! Note that we also use an interpolation for exp(-t) here. tv = xva * rfinc ( n ) ip = nint ( tv ) fx = fgrid ( 4 , ip , n ) * tv fx = ( fx + fgrid ( 3 , ip , n )) * tv fx = ( fx + fgrid ( 2 , ip , n )) * tv fx = ( fx + fgrid ( 1 , ip , n )) * tv fx = fx + fgrid ( 0 , ip , n ) tv = xva * rxinc ip = nint ( tv ) et = xgrid ( 4 , ip ) * tv et = ( et + xgrid ( 3 , ip )) * tv et = ( et + xgrid ( 2 , ip )) * tv et = ( et + xgrid ( 1 , ip )) * tv et = et + xgrid ( 0 , ip ) rdat % fq ( 8 ) = fx t2 = xva + xva do m = 8 , 1 , - 1 rdat % fq ( m - 1 ) = ( t2 * rdat % fq ( m ) + et ) * rmr ( m ) end do ! This is other parts of the integral, not fm(t) fqf = fqz * sqrt ( x41 ) do m = 0 , n rdat % fq ( m ) = rdat % fq ( m ) * fqf fqf = fqf * rho end do else xin = 1.0_dp / xva rdat % fq ( 0 ) = fqz * sqrt ( pi4 * xin * x41 ) rox = rho * xin fqf = 0.5_dp * rox do m = 1 , n rdat % fq ( m ) = rdat % fq ( m - 1 ) * fqf fqf = fqf + rox end do endif pqt = pqr * pqs pqq = pqs * pqs work ( 1 , 1 ) = 1.0d0 work ( 1 , 2 ) = rdat % ty02 ( i ) - rdat % rab work ( 1 , 3 ) = 0.5_dp / rdat % tx12 ( i ) do j = 1 , 3 work ( 2 , j ) = work ( 1 , j ) * pqr work ( 3 , j ) = work ( 1 , j ) * pqs work ( 4 , j ) = work ( 1 , j ) * pqt work ( 5 , j ) = work ( 1 , j ) * pqq enddo rdat % fq0 ( 1 : 2 ) = rdat % fq0 ( 1 : 2 ) + rdat % fq ( 0 ) * work ( 1 , 1 : 2 ) rdat % fq1 (:, 1 : 3 ) = rdat % fq1 (:, 1 : 3 ) + rdat % fq ( 1 ) * work ( 1 : 2 , 1 : 3 ) rdat % fq2 (:, 1 : 3 ) = rdat % fq2 (:, 1 : 3 ) + rdat % fq ( 2 ) * work ( 1 : 3 , 1 : 3 ) rdat % fq3 (:, 1 : 3 ) = rdat % fq3 (:, 1 : 3 ) + rdat % fq ( 3 ) * work ( 1 : 4 , 1 : 3 ) rdat % fq4 (:, 1 : 3 ) = rdat % fq4 (:, 1 : 3 ) + rdat % fq ( 4 ) * work ( 1 : 5 , 1 : 3 ) rdat % fq5 ( 1 : 5 , 1 ) = rdat % fq5 ( 1 : 5 , 1 ) + rdat % fq ( 5 ) * work ( 1 : 5 , 3 ) rdat % fq5 ( 6 , 1 ) = rdat % fq5 ( 6 , 1 ) + rdat % fq ( 5 ) * work ( 5 , 3 ) * pqr end do end subroutine intj_14 ! > ! >    @brief   dpds case ! > ! >    @details integration of the dpds case ! > subroutine intj_15 ( rdat ) implicit none type ( rotaxis_data_t ) :: rdat ! Generate jtype=15 integrals integer :: i , n , ip , j , m real ( kind = dp ) :: fqz , x41 , pqr , pqs , rho , xva real ( kind = dp ) :: tv , fx , efr , fqf , xin , rox , et , t2 real ( kind = dp ) :: pqt , xmd1 , y01 , work dimension work ( 5 , 4 ) rdat % fq0 ( 1 : 2 ) = 0.0_dp rdat % fq1 (:, 1 : 4 ) = 0.0_dp rdat % fq2 (:, 1 : 4 ) = 0.0_dp rdat % fq3 (:, 1 : 4 ) = 0.0_dp rdat % fq4 (:, 1 : 2 ) = 0.0_dp rdat % fq5 (:, 1 ) = 0.0_dp do i = 1 , rdat % ngangb fqz = rdat % sp ( i ) * rdat % sq x41 = rdat % tx12 ( i ) + rdat % x34 if ( fqz * fqz < rdat % cutoff * x41 ) cycle x41 = 1 / x41 pqr = rdat % ty02 ( i ) - rdat % aqz pqs = pqr * pqr rho = rdat % tx12 ( i ) * rdat % x34 * x41 if ( rdat % lrint ) then efr = rdat % emu2 / ( rdat % emu2 + rho ) rho = rho * efr fqz = fqz * sqrt ( efr ) endif xva = ( pqs + rdat % qps ) * rho rho = rho + rho n = 5 if ( xva <= tmax ) then ! Fm(t) m=5 interpolation, generating wasted m=8,7,6 data tv = xva * rfinc ( n ) ip = nint ( tv ) fx = fgrid ( 4 , ip , n ) * tv fx = ( fx + fgrid ( 3 , ip , n )) * tv fx = ( fx + fgrid ( 2 , ip , n )) * tv fx = ( fx + fgrid ( 1 , ip , n )) * tv fx = fx + fgrid ( 0 , ip , n ) tv = xva * rxinc ip = nint ( tv ) et = xgrid ( 4 , ip ) * tv et = ( et + xgrid ( 3 , ip )) * tv et = ( et + xgrid ( 2 , ip )) * tv et = ( et + xgrid ( 1 , ip )) * tv et = et + xgrid ( 0 , ip ) rdat % fq ( 8 ) = fx t2 = xva + xva do m = 8 , 1 , - 1 rdat % fq ( m - 1 ) = ( t2 * rdat % fq ( m ) + et ) * rmr ( m ) end do fqf = fqz * sqrt ( x41 ) do m = 0 , n rdat % fq ( m ) = rdat % fq ( m ) * fqf fqf = fqf * rho end do else xin = 1.0_dp / xva rdat % fq ( 0 ) = fqz * sqrt ( pi4 * xin * x41 ) rox = rho * xin fqf = 0.5_dp * rox do m = 1 , n rdat % fq ( m ) = rdat % fq ( m - 1 ) * fqf fqf = fqf + rox end do endif pqt = pqr * pqs xmd1 = 0.5_dp / rdat % tx12 ( i ) y01 = rdat % ty02 ( i ) - rdat % rab work ( 1 , 1 ) = xmd1 work ( 1 , 2 ) = y01 * y01 work ( 1 , 3 ) = xmd1 * y01 work ( 1 , 4 ) = xmd1 * xmd1 do j = 1 , 4 work ( 2 , j ) = work ( 1 , j ) * pqr work ( 3 , j ) = work ( 1 , j ) * pqs work ( 4 , j ) = work ( 1 , j ) * pqt enddo work ( 5 , 3 ) = work ( 4 , 3 ) * pqr work ( 5 , 4 ) = work ( 4 , 4 ) * pqr rdat % fq0 ( 1 ) = rdat % fq0 ( 1 ) + rdat % fq ( 0 ) * work ( 1 , 1 ) rdat % fq0 ( 2 ) = rdat % fq0 ( 2 ) + rdat % fq ( 0 ) * work ( 1 , 2 ) do j = 1 , 3 rdat % fq1 ( 1 , j ) = rdat % fq1 ( 1 , j ) + rdat % fq ( 1 ) * work ( 1 , j ) rdat % fq1 ( 2 , j ) = rdat % fq1 ( 2 , j ) + rdat % fq ( 1 ) * work ( 2 , j ) enddo rdat % fq1 ( 1 , 4 ) = rdat % fq1 ( 1 , 4 ) + rdat % fq ( 1 ) * work ( 1 , 4 ) do j = 1 , 4 rdat % fq2 ( 1 , j ) = rdat % fq2 ( 1 , j ) + rdat % fq ( 2 ) * work ( 1 , j ) rdat % fq2 ( 2 , j ) = rdat % fq2 ( 2 , j ) + rdat % fq ( 2 ) * work ( 2 , j ) rdat % fq2 ( 3 , j ) = rdat % fq2 ( 3 , j ) + rdat % fq ( 2 ) * work ( 3 , j ) rdat % fq3 ( 1 , j ) = rdat % fq3 ( 1 , j ) + rdat % fq ( 3 ) * work ( 1 , j ) rdat % fq3 ( 2 , j ) = rdat % fq3 ( 2 , j ) + rdat % fq ( 3 ) * work ( 2 , j ) rdat % fq3 ( 3 , j ) = rdat % fq3 ( 3 , j ) + rdat % fq ( 3 ) * work ( 3 , j ) rdat % fq3 ( 4 , j ) = rdat % fq3 ( 4 , j ) + rdat % fq ( 3 ) * work ( 4 , j ) enddo do j = 1 , 2 rdat % fq4 ( 1 , j ) = rdat % fq4 ( 1 , j ) + rdat % fq ( 4 ) * work ( 1 , j + 2 ) rdat % fq4 ( 2 , j ) = rdat % fq4 ( 2 , j ) + rdat % fq ( 4 ) * work ( 2 , j + 2 ) rdat % fq4 ( 3 , j ) = rdat % fq4 ( 3 , j ) + rdat % fq ( 4 ) * work ( 3 , j + 2 ) rdat % fq4 ( 4 , j ) = rdat % fq4 ( 4 , j ) + rdat % fq ( 4 ) * work ( 4 , j + 2 ) rdat % fq4 ( 5 , j ) = rdat % fq4 ( 5 , j ) + rdat % fq ( 4 ) * work ( 5 , j + 2 ) enddo rdat % fq5 ( 1 : 5 , 1 ) = rdat % fq5 ( 1 : 5 , 1 ) + rdat % fq ( 5 ) * work ( 1 : 5 , 4 ) rdat % fq5 ( 6 , 1 ) = rdat % fq5 ( 6 , 1 ) + rdat % fq ( 5 ) * work ( 5 , 4 ) * pqr end do end subroutine intj_15 ! > ! >    @brief   dppp case ! > ! >    @details integration of the dppp case ! > subroutine intj_16 ( rdat ) implicit none type ( rotaxis_data_t ) :: rdat ! Generate jtype=16 integrals integer :: i , n , ip , j , m , k real ( kind = dp ) :: fqz , x41 , pqr , pqs , rho , xva real ( kind = dp ) :: tv , fx , efr , fqf , xin , rox , et , t2 real ( kind = dp ) :: pqt , xmd1 , y01 , pqq , work dimension work ( 5 , 9 ) rdat % fq0 ( 1 : 5 ) = 0.0_dp rdat % fq1 (:, 1 : 9 ) = 0.0_dp rdat % fq2 (:, 1 : 9 ) = 0.0_dp rdat % fq3 (:, 1 : 9 ) = 0.0_dp rdat % fq4 (:, 1 : 5 ) = 0.0_dp rdat % fq5 (:, 1 ) = 0.0_dp do i = 1 , rdat % ngangb fqz = rdat % sp ( i ) * rdat % sq x41 = rdat % tx12 ( i ) + rdat % x34 if ( fqz * fqz < rdat % cutoff * x41 ) cycle x41 = 1 / x41 pqr = rdat % ty02 ( i ) - rdat % aqz pqs = pqr * pqr rho = rdat % tx12 ( i ) * rdat % x34 * x41 if ( rdat % lrint ) then efr = rdat % emu2 / ( rdat % emu2 + rho ) rho = rho * efr fqz = fqz * sqrt ( efr ) endif xva = ( pqs + rdat % qps ) * rho rho = rho + rho n = 5 if ( xva <= tmax ) then ! Fm(t) m=5 interpolation, generating wasted m=8,7,6 data tv = xva * rfinc ( n ) ip = nint ( tv ) fx = fgrid ( 4 , ip , n ) * tv fx = ( fx + fgrid ( 3 , ip , n )) * tv fx = ( fx + fgrid ( 2 , ip , n )) * tv fx = ( fx + fgrid ( 1 , ip , n )) * tv fx = fx + fgrid ( 0 , ip , n ) tv = xva * rxinc ip = nint ( tv ) et = xgrid ( 4 , ip ) * tv et = ( et + xgrid ( 3 , ip )) * tv et = ( et + xgrid ( 2 , ip )) * tv et = ( et + xgrid ( 1 , ip )) * tv et = et + xgrid ( 0 , ip ) rdat % fq ( 8 ) = fx t2 = xva + xva do m = 8 , 1 , - 1 rdat % fq ( m - 1 ) = ( t2 * rdat % fq ( m ) + et ) * rmr ( m ) end do fqf = fqz * sqrt ( x41 ) do m = 0 , n rdat % fq ( m ) = rdat % fq ( m ) * fqf fqf = fqf * rho end do else xin = 1.0_dp / xva rdat % fq ( 0 ) = fqz * sqrt ( pi4 * xin * x41 ) rox = rho * xin fqf = 0.5_dp * rox do m = 1 , n rdat % fq ( m ) = rdat % fq ( m - 1 ) * fqf fqf = fqf + rox end do endif pqt = pqr * pqs pqq = pqs * pqs xmd1 = 0.5_dp / rdat % tx12 ( i ) y01 = rdat % ty02 ( i ) - rdat % rab work ( 1 , 1 ) = 1.0d0 work ( 1 , 2 ) = y01 work ( 1 , 3 ) = rdat % ty02 ( i ) work ( 1 , 4 ) = y01 * rdat % ty02 ( i ) work ( 1 , 5 ) = xmd1 work ( 1 , 6 ) = xmd1 work ( 1 , 7 ) = xmd1 work ( 1 , 8 ) = xmd1 * y01 work ( 1 , 9 ) = xmd1 * xmd1 do j = 1 , 9 work ( 2 , j ) = work ( 1 , j ) * pqr work ( 3 , j ) = work ( 1 , j ) * pqs work ( 4 , j ) = work ( 1 , j ) * pqt enddo do j = 5 , 9 work ( 5 , j ) = work ( 1 , j ) * pqq enddo do j = 1 , 5 rdat % fq0 ( j ) = rdat % fq0 ( j ) + rdat % fq ( 0 ) * work ( 1 , j ) enddo do j = 1 , 8 rdat % fq1 ( 1 , j ) = rdat % fq1 ( 1 , j ) + rdat % fq ( 1 ) * work ( 1 , j ) rdat % fq1 ( 2 , j ) = rdat % fq1 ( 2 , j ) + rdat % fq ( 1 ) * work ( 2 , j ) enddo rdat % fq1 ( 1 , 9 ) = rdat % fq1 ( 1 , 9 ) + rdat % fq ( 1 ) * work ( 1 , 9 ) do j = 1 , 9 rdat % fq2 ( 1 , j ) = rdat % fq2 ( 1 , j ) + rdat % fq ( 2 ) * work ( 1 , j ) rdat % fq2 ( 2 , j ) = rdat % fq2 ( 2 , j ) + rdat % fq ( 2 ) * work ( 2 , j ) rdat % fq2 ( 3 , j ) = rdat % fq2 ( 3 , j ) + rdat % fq ( 2 ) * work ( 3 , j ) rdat % fq3 ( 1 , j ) = rdat % fq3 ( 1 , j ) + rdat % fq ( 3 ) * work ( 1 , j ) rdat % fq3 ( 2 , j ) = rdat % fq3 ( 2 , j ) + rdat % fq ( 3 ) * work ( 2 , j ) rdat % fq3 ( 3 , j ) = rdat % fq3 ( 3 , j ) + rdat % fq ( 3 ) * work ( 3 , j ) rdat % fq3 ( 4 , j ) = rdat % fq3 ( 4 , j ) + rdat % fq ( 3 ) * work ( 4 , j ) enddo do j = 1 , 5 rdat % fq4 ( 1 , j ) = rdat % fq4 ( 1 , j ) + rdat % fq ( 4 ) * work ( 1 , j + 4 ) rdat % fq4 ( 2 , j ) = rdat % fq4 ( 2 , j ) + rdat % fq ( 4 ) * work ( 2 , j + 4 ) rdat % fq4 ( 3 , j ) = rdat % fq4 ( 3 , j ) + rdat % fq ( 4 ) * work ( 3 , j + 4 ) rdat % fq4 ( 4 , j ) = rdat % fq4 ( 4 , j ) + rdat % fq ( 4 ) * work ( 4 , j + 4 ) rdat % fq4 ( 5 , j ) = rdat % fq4 ( 5 , j ) + rdat % fq ( 4 ) * work ( 5 , j + 4 ) enddo do k = 1 , 5 rdat % fq5 ( k , 1 ) = rdat % fq5 ( k , 1 ) + rdat % fq ( 5 ) * work ( k , 9 ) enddo rdat % fq5 ( 6 , 1 ) = rdat % fq5 ( 6 , 1 ) + rdat % fq ( 5 ) * work ( 5 , 9 ) * pqr end do end subroutine intj_16 ! > ! >    @brief   ddds case ! > ! >    @details integration of the ddds case ! > subroutine intj_17 ( rdat ) implicit none type ( rotaxis_data_t ) :: rdat ! Generate jtype=17 integrals integer :: i , n , ip , j , m , k real ( kind = dp ) :: fqz , x41 , pqr , pqs , rho , xva real ( kind = dp ) :: tv , fx , efr , fqf , xin , rox , et , t2 real ( kind = dp ) :: pqt , xmd1 , y01 , pqq , work dimension work ( 6 , 4 ) rdat % fq0 ( 1 ) = 0.0_dp rdat % fq0 ( 2 ) = 0.0_dp do j = 1 , 4 rdat % fq1 ( 1 , j ) = 0.0_dp rdat % fq1 ( 2 , j ) = 0.0_dp rdat % fq2 ( 1 , j ) = 0.0_dp rdat % fq2 ( 2 , j ) = 0.0_dp rdat % fq2 ( 3 , j ) = 0.0_dp rdat % fq3 ( 1 , j ) = 0.0_dp rdat % fq3 ( 2 , j ) = 0.0_dp rdat % fq3 ( 3 , j ) = 0.0_dp rdat % fq3 ( 4 , j ) = 0.0_dp rdat % fq4 ( 1 , j ) = 0.0_dp rdat % fq4 ( 2 , j ) = 0.0_dp rdat % fq4 ( 3 , j ) = 0.0_dp rdat % fq4 ( 4 , j ) = 0.0_dp rdat % fq4 ( 5 , j ) = 0.0_dp enddo do j = 1 , 2 do k = 1 , 6 rdat % fq5 ( k , j ) = 0.0_dp enddo enddo rdat % fq6 (:, 1 ) = 0.0_dp do i = 1 , rdat % ngangb fqz = rdat % sp ( i ) * rdat % sq x41 = rdat % tx12 ( i ) + rdat % x34 if ( fqz * fqz < rdat % cutoff * x41 ) cycle x41 = 1 / x41 pqr = rdat % ty02 ( i ) - rdat % aqz pqs = pqr * pqr rho = rdat % tx12 ( i ) * rdat % x34 * x41 if ( rdat % lrint ) then efr = rdat % emu2 / ( rdat % emu2 + rho ) rho = rho * efr fqz = fqz * sqrt ( efr ) endif xva = ( pqs + rdat % qps ) * rho rho = rho + rho n = 6 if ( xva <= tmax ) then ! Fm(t) m=6 interpolation, generating wasted m=8,7 data m = 5 tv = xva * rfinc ( m ) ip = nint ( tv ) fx = fgrid ( 4 , ip , m ) * tv fx = ( fx + fgrid ( 3 , ip , m )) * tv fx = ( fx + fgrid ( 2 , ip , m )) * tv fx = ( fx + fgrid ( 1 , ip , m )) * tv fx = fx + fgrid ( 0 , ip , m ) tv = xva * rxinc ip = nint ( tv ) et = xgrid ( 4 , ip ) * tv et = ( et + xgrid ( 3 , ip )) * tv et = ( et + xgrid ( 2 , ip )) * tv et = ( et + xgrid ( 1 , ip )) * tv et = et + xgrid ( 0 , ip ) rdat % fq ( 8 ) = fx t2 = xva + xva do m = 8 , 1 , - 1 rdat % fq ( m - 1 ) = ( t2 * rdat % fq ( m ) + et ) * rmr ( m ) end do fqf = fqz * sqrt ( x41 ) do m = 0 , n rdat % fq ( m ) = rdat % fq ( m ) * fqf fqf = fqf * rho end do else xin = 1.0_dp / xva rdat % fq ( 0 ) = fqz * sqrt ( pi4 * xin * x41 ) rox = rho * xin fqf = 0.5_dp * rox do m = 1 , n rdat % fq ( m ) = rdat % fq ( m - 1 ) * fqf fqf = fqf + rox end do endif pqt = pqr * pqs pqq = pqs * pqs xmd1 = 0.5_dp / rdat % tx12 ( i ) y01 = rdat % ty02 ( i ) - rdat % rab work ( 1 , 1 ) = xmd1 work ( 1 , 2 ) = y01 * y01 work ( 1 , 3 ) = xmd1 * y01 work ( 1 , 4 ) = xmd1 * xmd1 do j = 1 , 4 work ( 2 , j ) = work ( 1 , j ) * pqr work ( 3 , j ) = work ( 1 , j ) * pqs work ( 4 , j ) = work ( 1 , j ) * pqt work ( 5 , j ) = work ( 1 , j ) * pqq enddo work ( 6 , 3 ) = work ( 5 , 3 ) * pqr work ( 6 , 4 ) = work ( 5 , 4 ) * pqr rdat % fq0 ( 1 ) = rdat % fq0 ( 1 ) + rdat % fq ( 0 ) * work ( 1 , 1 ) rdat % fq0 ( 2 ) = rdat % fq0 ( 2 ) + rdat % fq ( 0 ) * work ( 1 , 2 ) do j = 1 , 3 rdat % fq1 ( 1 , j ) = rdat % fq1 ( 1 , j ) + rdat % fq ( 1 ) * work ( 1 , j ) rdat % fq1 ( 2 , j ) = rdat % fq1 ( 2 , j ) + rdat % fq ( 1 ) * work ( 2 , j ) enddo rdat % fq1 ( 1 , 4 ) = rdat % fq1 ( 1 , 4 ) + rdat % fq ( 1 ) * work ( 1 , 4 ) do j = 1 , 4 rdat % fq2 ( 1 , j ) = rdat % fq2 ( 1 , j ) + rdat % fq ( 2 ) * work ( 1 , j ) rdat % fq2 ( 2 , j ) = rdat % fq2 ( 2 , j ) + rdat % fq ( 2 ) * work ( 2 , j ) rdat % fq2 ( 3 , j ) = rdat % fq2 ( 3 , j ) + rdat % fq ( 2 ) * work ( 3 , j ) rdat % fq3 ( 1 , j ) = rdat % fq3 ( 1 , j ) + rdat % fq ( 3 ) * work ( 1 , j ) rdat % fq3 ( 2 , j ) = rdat % fq3 ( 2 , j ) + rdat % fq ( 3 ) * work ( 2 , j ) rdat % fq3 ( 3 , j ) = rdat % fq3 ( 3 , j ) + rdat % fq ( 3 ) * work ( 3 , j ) rdat % fq3 ( 4 , j ) = rdat % fq3 ( 4 , j ) + rdat % fq ( 3 ) * work ( 4 , j ) rdat % fq4 ( 1 , j ) = rdat % fq4 ( 1 , j ) + rdat % fq ( 4 ) * work ( 1 , j ) rdat % fq4 ( 2 , j ) = rdat % fq4 ( 2 , j ) + rdat % fq ( 4 ) * work ( 2 , j ) rdat % fq4 ( 3 , j ) = rdat % fq4 ( 3 , j ) + rdat % fq ( 4 ) * work ( 3 , j ) rdat % fq4 ( 4 , j ) = rdat % fq4 ( 4 , j ) + rdat % fq ( 4 ) * work ( 4 , j ) rdat % fq4 ( 5 , j ) = rdat % fq4 ( 5 , j ) + rdat % fq ( 4 ) * work ( 5 , j ) enddo do j = 1 , 2 do k = 1 , 6 rdat % fq5 ( k , j ) = rdat % fq5 ( k , j ) + rdat % fq ( 5 ) * work ( k , j + 2 ) enddo enddo do k = 1 , 6 rdat % fq6 ( k , 1 ) = rdat % fq6 ( k , 1 ) + rdat % fq ( 6 ) * work ( k , 4 ) enddo rdat % fq6 ( 7 , 1 ) = rdat % fq6 ( 7 , 1 ) + rdat % fq ( 6 ) * work ( 6 , 4 ) * pqr end do end subroutine intj_17 ! > ! >    @brief   ddpp case ! > ! >    @details integration of the ddpp case ! > subroutine intj_18 ( rdat ) implicit none type ( rotaxis_data_t ) :: rdat ! Generate jtype=18 integrals integer :: i , n , ip , j , m , k real ( kind = dp ) :: fqz , x41 , pqr , pqs , rho , xva real ( kind = dp ) :: tv , fx , efr , fqf , xin , rox , et , t2 real ( kind = dp ) :: pqt , xmd1 , y01 , pqq , pq5 , work dimension work ( 6 , 9 ) do j = 1 , 5 rdat % fq0 ( j ) = 0.0_dp enddo do j = 1 , 9 rdat % fq1 ( 1 , j ) = 0.0_dp rdat % fq1 ( 2 , j ) = 0.0_dp rdat % fq2 ( 1 , j ) = 0.0_dp rdat % fq2 ( 2 , j ) = 0.0_dp rdat % fq2 ( 3 , j ) = 0.0_dp rdat % fq3 ( 1 , j ) = 0.0_dp rdat % fq3 ( 2 , j ) = 0.0_dp rdat % fq3 ( 3 , j ) = 0.0_dp rdat % fq3 ( 4 , j ) = 0.0_dp rdat % fq4 ( 1 , j ) = 0.0_dp rdat % fq4 ( 2 , j ) = 0.0_dp rdat % fq4 ( 3 , j ) = 0.0_dp rdat % fq4 ( 4 , j ) = 0.0_dp rdat % fq4 ( 5 , j ) = 0.0_dp enddo do j = 1 , 5 do k = 1 , 6 rdat % fq5 ( k , j ) = 0.0_dp enddo enddo rdat % fq6 (:, 1 ) = 0.0_dp do i = 1 , rdat % ngangb fqz = rdat % sp ( i ) * rdat % sq x41 = rdat % tx12 ( i ) + rdat % x34 if ( fqz * fqz < rdat % cutoff * x41 ) cycle x41 = 1 / x41 pqr = rdat % ty02 ( i ) - rdat % aqz pqs = pqr * pqr rho = rdat % tx12 ( i ) * rdat % x34 * x41 if ( rdat % lrint ) then efr = rdat % emu2 / ( rdat % emu2 + rho ) rho = rho * efr fqz = fqz * sqrt ( efr ) endif xva = ( pqs + rdat % qps ) * rho rho = rho + rho n = 6 if ( xva <= tmax ) then ! Fm(t) m=6 interpolation, generating wasted m=8,7 data m = 5 tv = xva * rfinc ( m ) ip = nint ( tv ) fx = fgrid ( 4 , ip , m ) * tv fx = ( fx + fgrid ( 3 , ip , m )) * tv fx = ( fx + fgrid ( 2 , ip , m )) * tv fx = ( fx + fgrid ( 1 , ip , m )) * tv fx = fx + fgrid ( 0 , ip , m ) tv = xva * rxinc ip = nint ( tv ) et = xgrid ( 4 , ip ) * tv et = ( et + xgrid ( 3 , ip )) * tv et = ( et + xgrid ( 2 , ip )) * tv et = ( et + xgrid ( 1 , ip )) * tv et = et + xgrid ( 0 , ip ) rdat % fq ( 8 ) = fx t2 = xva + xva do m = 8 , 1 , - 1 rdat % fq ( m - 1 ) = ( t2 * rdat % fq ( m ) + et ) * rmr ( m ) end do fqf = fqz * sqrt ( x41 ) do m = 0 , n rdat % fq ( m ) = rdat % fq ( m ) * fqf fqf = fqf * rho end do else xin = 1.0_dp / xva rdat % fq ( 0 ) = fqz * sqrt ( pi4 * xin * x41 ) rox = rho * xin fqf = 0.5_dp * rox do m = 1 , n rdat % fq ( m ) = rdat % fq ( m - 1 ) * fqf fqf = fqf + rox end do endif pqt = pqr * pqs pqq = pqs * pqs pq5 = pqt * pqs xmd1 = 0.5_dp / rdat % tx12 ( i ) y01 = rdat % ty02 ( i ) - rdat % rab work ( 1 , 1 ) = 1.0d0 work ( 1 , 2 ) = y01 work ( 1 , 3 ) = rdat % ty02 ( i ) work ( 1 , 4 ) = y01 * rdat % ty02 ( i ) work ( 1 , 5 ) = xmd1 work ( 1 , 6 ) = xmd1 work ( 1 , 7 ) = xmd1 work ( 1 , 8 ) = xmd1 * y01 work ( 1 , 9 ) = xmd1 * xmd1 do j = 1 , 9 work ( 2 , j ) = work ( 1 , j ) * pqr work ( 3 , j ) = work ( 1 , j ) * pqs work ( 4 , j ) = work ( 1 , j ) * pqt work ( 5 , j ) = work ( 1 , j ) * pqq enddo do j = 5 , 9 work ( 6 , j ) = work ( 1 , j ) * pq5 enddo do j = 1 , 5 rdat % fq0 ( j ) = rdat % fq0 ( j ) + rdat % fq ( 0 ) * work ( 1 , j ) enddo do j = 1 , 8 rdat % fq1 ( 1 , j ) = rdat % fq1 ( 1 , j ) + rdat % fq ( 1 ) * work ( 1 , j ) rdat % fq1 ( 2 , j ) = rdat % fq1 ( 2 , j ) + rdat % fq ( 1 ) * work ( 2 , j ) enddo rdat % fq1 ( 1 , 9 ) = rdat % fq1 ( 1 , 9 ) + rdat % fq ( 1 ) * work ( 1 , 9 ) do j = 1 , 9 rdat % fq2 ( 1 , j ) = rdat % fq2 ( 1 , j ) + rdat % fq ( 2 ) * work ( 1 , j ) rdat % fq2 ( 2 , j ) = rdat % fq2 ( 2 , j ) + rdat % fq ( 2 ) * work ( 2 , j ) rdat % fq2 ( 3 , j ) = rdat % fq2 ( 3 , j ) + rdat % fq ( 2 ) * work ( 3 , j ) rdat % fq3 ( 1 , j ) = rdat % fq3 ( 1 , j ) + rdat % fq ( 3 ) * work ( 1 , j ) rdat % fq3 ( 2 , j ) = rdat % fq3 ( 2 , j ) + rdat % fq ( 3 ) * work ( 2 , j ) rdat % fq3 ( 3 , j ) = rdat % fq3 ( 3 , j ) + rdat % fq ( 3 ) * work ( 3 , j ) rdat % fq3 ( 4 , j ) = rdat % fq3 ( 4 , j ) + rdat % fq ( 3 ) * work ( 4 , j ) rdat % fq4 ( 1 , j ) = rdat % fq4 ( 1 , j ) + rdat % fq ( 4 ) * work ( 1 , j ) rdat % fq4 ( 2 , j ) = rdat % fq4 ( 2 , j ) + rdat % fq ( 4 ) * work ( 2 , j ) rdat % fq4 ( 3 , j ) = rdat % fq4 ( 3 , j ) + rdat % fq ( 4 ) * work ( 3 , j ) rdat % fq4 ( 4 , j ) = rdat % fq4 ( 4 , j ) + rdat % fq ( 4 ) * work ( 4 , j ) rdat % fq4 ( 5 , j ) = rdat % fq4 ( 5 , j ) + rdat % fq ( 4 ) * work ( 5 , j ) enddo do j = 1 , 5 do k = 1 , 6 rdat % fq5 ( k , j ) = rdat % fq5 ( k , j ) + rdat % fq ( 5 ) * work ( k , j + 4 ) enddo enddo do k = 1 , 6 rdat % fq6 ( k , 1 ) = rdat % fq6 ( k , 1 ) + rdat % fq ( 6 ) * work ( k , 9 ) enddo rdat % fq6 ( 7 , 1 ) = rdat % fq6 ( 7 , 1 ) + rdat % fq ( 6 ) * work ( 6 , 9 ) * pqr end do end subroutine intj_18 ! > ! >    @brief   dpdp case ! > ! >    @details integration of the dpdp case ! > subroutine intj_19 ( rdat ) implicit none type ( rotaxis_data_t ) :: rdat ! Generate jtype=19 integrals integer :: i , n , ip , j , m , k real ( kind = dp ) :: fqz , x41 , pqr , pqs , rho , xva real ( kind = dp ) :: tv , fx , efr , fqf , xin , rox , et , t2 real ( kind = dp ) :: pqt , xmd1 , y01 , pqq , xmd2 , y11 , pq5 , work dimension work ( 6 , 11 ) do j = 1 , 5 rdat % fq0 ( j ) = 0.0_dp enddo do j = 1 , 10 rdat % fq1 ( 1 , j ) = 0.0_dp rdat % fq1 ( 2 , j ) = 0.0_dp enddo do j = 1 , 11 rdat % fq2 ( 1 , j ) = 0.0_dp rdat % fq2 ( 2 , j ) = 0.0_dp rdat % fq2 ( 3 , j ) = 0.0_dp rdat % fq3 ( 1 , j ) = 0.0_dp rdat % fq3 ( 2 , j ) = 0.0_dp rdat % fq3 ( 3 , j ) = 0.0_dp rdat % fq3 ( 4 , j ) = 0.0_dp enddo do j = 1 , 7 rdat % fq4 ( 1 , j ) = 0.0_dp rdat % fq4 ( 2 , j ) = 0.0_dp rdat % fq4 ( 3 , j ) = 0.0_dp rdat % fq4 ( 4 , j ) = 0.0_dp rdat % fq4 ( 5 , j ) = 0.0_dp enddo do j = 1 , 4 do k = 1 , 6 rdat % fq5 ( k , j ) = 0.0_dp enddo enddo rdat % fq6 (:, 1 ) = 0.0_dp do i = 1 , rdat % ngangb fqz = rdat % sp ( i ) * rdat % sq x41 = rdat % tx12 ( i ) + rdat % x34 if ( fqz * fqz < rdat % cutoff * x41 ) cycle x41 = 1 / x41 pqr = rdat % ty02 ( i ) - rdat % aqz pqs = pqr * pqr rho = rdat % tx12 ( i ) * rdat % x34 * x41 if ( rdat % lrint ) then efr = rdat % emu2 / ( rdat % emu2 + rho ) rho = rho * efr fqz = fqz * sqrt ( efr ) endif xva = ( pqs + rdat % qps ) * rho rho = rho + rho n = 6 if ( xva <= tmax ) then ! Fm(t) m=6 interpolation, generating wasted m=8,7 data m = 5 tv = xva * rfinc ( m ) ip = nint ( tv ) fx = fgrid ( 4 , ip , m ) * tv fx = ( fx + fgrid ( 3 , ip , m )) * tv fx = ( fx + fgrid ( 2 , ip , m )) * tv fx = ( fx + fgrid ( 1 , ip , m )) * tv fx = fx + fgrid ( 0 , ip , m ) tv = xva * rxinc ip = nint ( tv ) et = xgrid ( 4 , ip ) * tv et = ( et + xgrid ( 3 , ip )) * tv et = ( et + xgrid ( 2 , ip )) * tv et = ( et + xgrid ( 1 , ip )) * tv et = et + xgrid ( 0 , ip ) rdat % fq ( 8 ) = fx t2 = xva + xva do m = 8 , 1 , - 1 rdat % fq ( m - 1 ) = ( t2 * rdat % fq ( m ) + et ) * rmr ( m ) end do fqf = fqz * sqrt ( x41 ) do m = 0 , n rdat % fq ( m ) = rdat % fq ( m ) * fqf fqf = fqf * rho end do else xin = 1.0_dp / xva rdat % fq ( 0 ) = fqz * sqrt ( pi4 * xin * x41 ) rox = rho * xin fqf = 0.5_dp * rox do m = 1 , n rdat % fq ( m ) = rdat % fq ( m - 1 ) * fqf fqf = fqf + rox end do endif pqt = pqr * pqs pqq = pqs * pqs pq5 = pqt * pqs xmd1 = 0.5_dp / rdat % tx12 ( i ) xmd2 = xmd1 * xmd1 y01 = rdat % ty02 ( i ) - rdat % rab y11 = y01 * y01 work ( 1 , 1 ) = xmd1 work ( 1 , 2 ) = y11 work ( 1 , 3 ) = y11 * rdat % ty02 ( i ) work ( 1 , 4 ) = xmd1 * rdat % ty02 ( i ) work ( 1 , 5 ) = xmd1 * y01 work ( 1 , 6 ) = xmd1 * y01 work ( 1 , 7 ) = xmd1 * y11 work ( 1 , 8 ) = xmd2 work ( 1 , 9 ) = xmd2 work ( 1 , 10 ) = xmd2 * y01 work ( 1 , 11 ) = xmd2 * xmd1 do j = 1 , 11 work ( 2 , j ) = work ( 1 , j ) * pqr work ( 3 , j ) = work ( 1 , j ) * pqs work ( 4 , j ) = work ( 1 , j ) * pqt enddo do j = 5 , 11 work ( 5 , j ) = work ( 1 , j ) * pqq enddo do j = 8 , 11 work ( 6 , j ) = work ( 1 , j ) * pq5 enddo do j = 1 , 5 rdat % fq0 ( j ) = rdat % fq0 ( j ) + rdat % fq ( 0 ) * work ( 1 , j ) enddo do j = 1 , 8 rdat % fq1 ( 1 , j ) = rdat % fq1 ( 1 , j ) + rdat % fq ( 1 ) * work ( 1 , j ) rdat % fq1 ( 2 , j ) = rdat % fq1 ( 2 , j ) + rdat % fq ( 1 ) * work ( 2 , j ) enddo rdat % fq1 ( 1 , 9 ) = rdat % fq1 ( 1 , 9 ) + rdat % fq ( 1 ) * work ( 1 , 9 ) rdat % fq1 ( 1 , 10 ) = rdat % fq1 ( 1 , 10 ) + rdat % fq ( 1 ) * work ( 1 , 10 ) do j = 1 , 11 rdat % fq2 ( 1 , j ) = rdat % fq2 ( 1 , j ) + rdat % fq ( 2 ) * work ( 1 , j ) rdat % fq2 ( 2 , j ) = rdat % fq2 ( 2 , j ) + rdat % fq ( 2 ) * work ( 2 , j ) rdat % fq2 ( 3 , j ) = rdat % fq2 ( 3 , j ) + rdat % fq ( 2 ) * work ( 3 , j ) rdat % fq3 ( 1 , j ) = rdat % fq3 ( 1 , j ) + rdat % fq ( 3 ) * work ( 1 , j ) rdat % fq3 ( 2 , j ) = rdat % fq3 ( 2 , j ) + rdat % fq ( 3 ) * work ( 2 , j ) rdat % fq3 ( 3 , j ) = rdat % fq3 ( 3 , j ) + rdat % fq ( 3 ) * work ( 3 , j ) rdat % fq3 ( 4 , j ) = rdat % fq3 ( 4 , j ) + rdat % fq ( 3 ) * work ( 4 , j ) enddo do j = 1 , 7 rdat % fq4 ( 1 , j ) = rdat % fq4 ( 1 , j ) + rdat % fq ( 4 ) * work ( 1 , j + 4 ) rdat % fq4 ( 2 , j ) = rdat % fq4 ( 2 , j ) + rdat % fq ( 4 ) * work ( 2 , j + 4 ) rdat % fq4 ( 3 , j ) = rdat % fq4 ( 3 , j ) + rdat % fq ( 4 ) * work ( 3 , j + 4 ) rdat % fq4 ( 4 , j ) = rdat % fq4 ( 4 , j ) + rdat % fq ( 4 ) * work ( 4 , j + 4 ) rdat % fq4 ( 5 , j ) = rdat % fq4 ( 5 , j ) + rdat % fq ( 4 ) * work ( 5 , j + 4 ) enddo do j = 1 , 4 do k = 1 , 6 rdat % fq5 ( k , j ) = rdat % fq5 ( k , j ) + rdat % fq ( 5 ) * work ( k , j + 7 ) enddo enddo do k = 1 , 6 rdat % fq6 ( k , 1 ) = rdat % fq6 ( k , 1 ) + rdat % fq ( 6 ) * work ( k , 11 ) enddo rdat % fq6 ( 7 , 1 ) = rdat % fq6 ( 7 , 1 ) + rdat % fq ( 6 ) * work ( 6 , 11 ) * pqr end do end subroutine intj_19 ! > ! >    @brief   dddp case ! > ! >    @details integration of the dddp case ! > subroutine intj_20 ( rdat ) implicit none type ( rotaxis_data_t ) :: rdat ! Generate jtype=20 integrals integer :: i , n , ip , j , m , k real ( kind = dp ) :: fqz , x41 , pqr , pqs , rho , xva real ( kind = dp ) :: tv , fx , efr , fqf , xin , rox , et , t2 real ( kind = dp ) :: pqt , xmd1 , y01 , pqq , xmd2 , y11 , pq5 , pq6 , work dimension work ( 7 , 11 ) do j = 1 , 5 rdat % fq0 ( j ) = 0.0_dp enddo do j = 1 , 10 rdat % fq1 ( 1 , j ) = 0.0_dp rdat % fq1 ( 2 , j ) = 0.0_dp enddo do j = 1 , 11 rdat % fq2 ( 1 , j ) = 0.0_dp rdat % fq2 ( 2 , j ) = 0.0_dp rdat % fq2 ( 3 , j ) = 0.0_dp rdat % fq3 ( 1 , j ) = 0.0_dp rdat % fq3 ( 2 , j ) = 0.0_dp rdat % fq3 ( 3 , j ) = 0.0_dp rdat % fq3 ( 4 , j ) = 0.0_dp rdat % fq4 ( 1 , j ) = 0.0_dp rdat % fq4 ( 2 , j ) = 0.0_dp rdat % fq4 ( 3 , j ) = 0.0_dp rdat % fq4 ( 4 , j ) = 0.0_dp rdat % fq4 ( 5 , j ) = 0.0_dp enddo do j = 1 , 7 do k = 1 , 6 rdat % fq5 ( k , j ) = 0.0_dp enddo enddo do j = 1 , 4 do k = 1 , 7 rdat % fq6 ( k , j ) = 0.0_dp enddo enddo rdat % fq7 (:, 1 ) = 0.0_dp do i = 1 , rdat % ngangb fqz = rdat % sp ( i ) * rdat % sq x41 = rdat % tx12 ( i ) + rdat % x34 if ( fqz * fqz < rdat % cutoff * x41 ) cycle x41 = 1 / x41 pqr = rdat % ty02 ( i ) - rdat % aqz pqs = pqr * pqr rho = rdat % tx12 ( i ) * rdat % x34 * x41 if ( rdat % lrint ) then efr = rdat % emu2 / ( rdat % emu2 + rho ) rho = rho * efr fqz = fqz * sqrt ( efr ) endif xva = ( pqs + rdat % qps ) * rho rho = rho + rho n = 7 if ( xva <= tmax ) then ! Fm(t) m=7 interpolation, generating wasted m=8 data m = 5 tv = xva * rfinc ( m ) ip = nint ( tv ) fx = fgrid ( 4 , ip , m ) * tv fx = ( fx + fgrid ( 3 , ip , m )) * tv fx = ( fx + fgrid ( 2 , ip , m )) * tv fx = ( fx + fgrid ( 1 , ip , m )) * tv fx = fx + fgrid ( 0 , ip , m ) tv = xva * rxinc ip = nint ( tv ) et = xgrid ( 4 , ip ) * tv et = ( et + xgrid ( 3 , ip )) * tv et = ( et + xgrid ( 2 , ip )) * tv et = ( et + xgrid ( 1 , ip )) * tv et = et + xgrid ( 0 , ip ) rdat % fq ( 8 ) = fx t2 = xva + xva do m = 8 , 1 , - 1 rdat % fq ( m - 1 ) = ( t2 * rdat % fq ( m ) + et ) * rmr ( m ) end do fqf = fqz * sqrt ( x41 ) do m = 0 , n rdat % fq ( m ) = rdat % fq ( m ) * fqf fqf = fqf * rho end do else xin = 1.0_dp / xva rdat % fq ( 0 ) = fqz * sqrt ( pi4 * xin * x41 ) rox = rho * xin fqf = 0.5_dp * rox do m = 1 , n rdat % fq ( m ) = rdat % fq ( m - 1 ) * fqf fqf = fqf + rox end do endif pqt = pqr * pqs pqq = pqs * pqs pq5 = pqt * pqs pq6 = pqq * pqs xmd1 = 0.5_dp / rdat % tx12 ( i ) xmd2 = xmd1 * xmd1 y01 = rdat % ty02 ( i ) - rdat % rab y11 = y01 * y01 work ( 1 , 1 ) = xmd1 work ( 1 , 2 ) = y11 work ( 1 , 3 ) = y11 * rdat % ty02 ( i ) work ( 1 , 4 ) = xmd1 * rdat % ty02 ( i ) work ( 1 , 5 ) = xmd1 * y01 work ( 1 , 6 ) = xmd1 * y01 work ( 1 , 7 ) = xmd1 * y11 work ( 1 , 8 ) = xmd2 work ( 1 , 9 ) = xmd2 work ( 1 , 10 ) = xmd2 * y01 work ( 1 , 11 ) = xmd2 * xmd1 do j = 1 , 11 work ( 2 , j ) = work ( 1 , j ) * pqr work ( 3 , j ) = work ( 1 , j ) * pqs work ( 4 , j ) = work ( 1 , j ) * pqt work ( 5 , j ) = work ( 1 , j ) * pqq enddo do j = 5 , 11 work ( 6 , j ) = work ( 1 , j ) * pq5 enddo do j = 8 , 11 work ( 7 , j ) = work ( 1 , j ) * pq6 enddo do j = 1 , 5 rdat % fq0 ( j ) = rdat % fq0 ( j ) + rdat % fq ( 0 ) * work ( 1 , j ) enddo do j = 1 , 8 rdat % fq1 ( 1 , j ) = rdat % fq1 ( 1 , j ) + rdat % fq ( 1 ) * work ( 1 , j ) rdat % fq1 ( 2 , j ) = rdat % fq1 ( 2 , j ) + rdat % fq ( 1 ) * work ( 2 , j ) enddo rdat % fq1 ( 1 , 9 ) = rdat % fq1 ( 1 , 9 ) + rdat % fq ( 1 ) * work ( 1 , 9 ) rdat % fq1 ( 1 , 10 ) = rdat % fq1 ( 1 , 10 ) + rdat % fq ( 1 ) * work ( 1 , 10 ) do j = 1 , 11 rdat % fq2 ( 1 , j ) = rdat % fq2 ( 1 , j ) + rdat % fq ( 2 ) * work ( 1 , j ) rdat % fq2 ( 2 , j ) = rdat % fq2 ( 2 , j ) + rdat % fq ( 2 ) * work ( 2 , j ) rdat % fq2 ( 3 , j ) = rdat % fq2 ( 3 , j ) + rdat % fq ( 2 ) * work ( 3 , j ) rdat % fq3 ( 1 , j ) = rdat % fq3 ( 1 , j ) + rdat % fq ( 3 ) * work ( 1 , j ) rdat % fq3 ( 2 , j ) = rdat % fq3 ( 2 , j ) + rdat % fq ( 3 ) * work ( 2 , j ) rdat % fq3 ( 3 , j ) = rdat % fq3 ( 3 , j ) + rdat % fq ( 3 ) * work ( 3 , j ) rdat % fq3 ( 4 , j ) = rdat % fq3 ( 4 , j ) + rdat % fq ( 3 ) * work ( 4 , j ) rdat % fq4 ( 1 , j ) = rdat % fq4 ( 1 , j ) + rdat % fq ( 4 ) * work ( 1 , j ) rdat % fq4 ( 2 , j ) = rdat % fq4 ( 2 , j ) + rdat % fq ( 4 ) * work ( 2 , j ) rdat % fq4 ( 3 , j ) = rdat % fq4 ( 3 , j ) + rdat % fq ( 4 ) * work ( 3 , j ) rdat % fq4 ( 4 , j ) = rdat % fq4 ( 4 , j ) + rdat % fq ( 4 ) * work ( 4 , j ) rdat % fq4 ( 5 , j ) = rdat % fq4 ( 5 , j ) + rdat % fq ( 4 ) * work ( 5 , j ) enddo do j = 1 , 7 do k = 1 , 6 rdat % fq5 ( k , j ) = rdat % fq5 ( k , j ) + rdat % fq ( 5 ) * work ( k , j + 4 ) enddo enddo do j = 1 , 4 do k = 1 , 7 rdat % fq6 ( k , j ) = rdat % fq6 ( k , j ) + rdat % fq ( 6 ) * work ( k , j + 7 ) enddo enddo do k = 1 , 7 rdat % fq7 ( k , 1 ) = rdat % fq7 ( k , 1 ) + rdat % fq ( 7 ) * work ( k , 11 ) enddo rdat % fq7 ( 8 , 1 ) = rdat % fq7 ( 8 , 1 ) + rdat % fq ( 7 ) * work ( 7 , 11 ) * pqr end do end subroutine intj_20 ! > ! >    @brief   dddd case ! > ! >    @details integration of the dddd case ! > subroutine intj_21 ( rdat ) implicit none type ( rotaxis_data_t ) :: rdat ! Generate jtype=21 integrals integer :: i , n , ip , j , m , k real ( kind = dp ) :: fqz , x41 , pqr , pqs , rho , xva real ( kind = dp ) :: tv , fx , efr , fqf , xin , rox , et , t2 real ( kind = dp ) :: xmd1 , y01 , xmd2 , y11 , pqwk , xmd3 , y12 , y22 , work dimension pqwk ( 2 : 8 ), work ( 8 , 16 ) do j = 1 , 5 rdat % fq0 ( j ) = 0.0_dp enddo do j = 1 , 13 rdat % fq1 ( 1 , j ) = 0.0_dp rdat % fq1 ( 2 , j ) = 0.0_dp enddo do j = 1 , 16 rdat % fq2 ( 1 , j ) = 0.0_dp rdat % fq2 ( 2 , j ) = 0.0_dp rdat % fq2 ( 3 , j ) = 0.0_dp rdat % fq3 ( 1 , j ) = 0.0_dp rdat % fq3 ( 2 , j ) = 0.0_dp rdat % fq3 ( 3 , j ) = 0.0_dp rdat % fq3 ( 4 , j ) = 0.0_dp rdat % fq4 ( 1 , j ) = 0.0_dp rdat % fq4 ( 2 , j ) = 0.0_dp rdat % fq4 ( 3 , j ) = 0.0_dp rdat % fq4 ( 4 , j ) = 0.0_dp rdat % fq4 ( 5 , j ) = 0.0_dp enddo do j = 1 , 11 do k = 1 , 6 rdat % fq5 ( k , j ) = 0.0_dp enddo enddo do j = 1 , 7 do k = 1 , 7 rdat % fq6 ( k , j ) = 0.0_dp enddo enddo do j = 1 , 3 do k = 1 , 8 rdat % fq7 ( k , j ) = 0.0_dp enddo enddo do k = 1 , 9 rdat % fq8 ( k ) = 0.0_dp enddo do i = 1 , rdat % ngangb fqz = rdat % sp ( i ) * rdat % sq x41 = rdat % tx12 ( i ) + rdat % x34 if ( fqz * fqz < rdat % cutoff * x41 ) cycle x41 = 1 / x41 pqr = rdat % ty02 ( i ) - rdat % aqz pqs = pqr * pqr rho = rdat % tx12 ( i ) * rdat % x34 * x41 if ( rdat % lrint ) then efr = rdat % emu2 / ( rdat % emu2 + rho ) rho = rho * efr fqz = fqz * sqrt ( efr ) endif xva = ( pqs + rdat % qps ) * rho rho = rho + rho n = 8 if ( xva <= tmax ) then ! Fm(t) m=8 interpolation m = 5 tv = xva * rfinc ( m ) ip = nint ( tv ) fx = fgrid ( 4 , ip , m ) * tv fx = ( fx + fgrid ( 3 , ip , m )) * tv fx = ( fx + fgrid ( 2 , ip , m )) * tv fx = ( fx + fgrid ( 1 , ip , m )) * tv fx = fx + fgrid ( 0 , ip , m ) tv = xva * rxinc ip = nint ( tv ) et = xgrid ( 4 , ip ) * tv et = ( et + xgrid ( 3 , ip )) * tv et = ( et + xgrid ( 2 , ip )) * tv et = ( et + xgrid ( 1 , ip )) * tv et = et + xgrid ( 0 , ip ) rdat % fq ( 8 ) = fx t2 = xva + xva do m = 8 , 1 , - 1 rdat % fq ( m - 1 ) = ( t2 * rdat % fq ( m ) + et ) * rmr ( m ) end do fqf = fqz * sqrt ( x41 ) do m = 0 , n rdat % fq ( m ) = rdat % fq ( m ) * fqf fqf = fqf * rho end do else xin = 1.0_dp / xva rdat % fq ( 0 ) = fqz * sqrt ( pi4 * xin * x41 ) rox = rho * xin fqf = 0.5_dp * rox do m = 1 , n rdat % fq ( m ) = rdat % fq ( m - 1 ) * fqf fqf = fqf + rox end do endif pqwk ( 2 ) = pqr pqwk ( 3 ) = pqs pqwk ( 4 ) = pqs * pqr pqwk ( 5 ) = pqs * pqs pqwk ( 6 ) = pqwk ( 4 ) * pqs pqwk ( 7 ) = pqwk ( 5 ) * pqs pqwk ( 8 ) = pqwk ( 6 ) * pqs xmd1 = 0.5_dp / rdat % tx12 ( i ) xmd2 = xmd1 * xmd1 xmd3 = xmd2 * xmd1 y01 = rdat % ty02 ( i ) - rdat % rab y11 = y01 * y01 y12 = y01 * rdat % ty02 ( i ) y22 = rdat % ty02 ( i ) * rdat % ty02 ( i ) work ( 1 , 1 ) = xmd2 work ( 1 , 2 ) = xmd1 * y11 work ( 1 , 3 ) = xmd1 * y12 work ( 1 , 4 ) = xmd1 * y22 work ( 1 , 5 ) = y11 * y22 work ( 1 , 6 ) = xmd2 * y01 work ( 1 , 7 ) = xmd2 * rdat % ty02 ( i ) work ( 1 , 8 ) = xmd1 * y11 * rdat % ty02 ( i ) work ( 1 , 9 ) = xmd1 * y12 * rdat % ty02 ( i ) work ( 1 , 10 ) = xmd3 work ( 1 , 11 ) = xmd2 * y11 work ( 1 , 12 ) = xmd2 * y12 work ( 1 , 13 ) = xmd2 * y22 work ( 1 , 14 ) = xmd3 * y01 work ( 1 , 15 ) = xmd3 * rdat % ty02 ( i ) work ( 1 , 16 ) = xmd3 * xmd1 do j = 1 , 5 do k = 2 , 5 work ( k , j ) = work ( 1 , j ) * pqwk ( k ) enddo enddo do j = 6 , 9 do k = 2 , 6 work ( k , j ) = work ( 1 , j ) * pqwk ( k ) enddo enddo do j = 10 , 13 do k = 2 , 7 work ( k , j ) = work ( 1 , j ) * pqwk ( k ) enddo enddo do j = 14 , 16 do k = 2 , 8 work ( k , j ) = work ( 1 , j ) * pqwk ( k ) enddo enddo do j = 1 , 5 rdat % fq0 ( j ) = rdat % fq0 ( j ) + rdat % fq ( 0 ) * work ( 1 , j ) enddo do j = 1 , 13 rdat % fq1 ( 1 , j ) = rdat % fq1 ( 1 , j ) + rdat % fq ( 1 ) * work ( 1 , j ) rdat % fq1 ( 2 , j ) = rdat % fq1 ( 2 , j ) + rdat % fq ( 1 ) * work ( 2 , j ) enddo do j = 1 , 16 rdat % fq2 ( 1 , j ) = rdat % fq2 ( 1 , j ) + rdat % fq ( 2 ) * work ( 1 , j ) rdat % fq2 ( 2 , j ) = rdat % fq2 ( 2 , j ) + rdat % fq ( 2 ) * work ( 2 , j ) rdat % fq2 ( 3 , j ) = rdat % fq2 ( 3 , j ) + rdat % fq ( 2 ) * work ( 3 , j ) rdat % fq3 ( 1 , j ) = rdat % fq3 ( 1 , j ) + rdat % fq ( 3 ) * work ( 1 , j ) rdat % fq3 ( 2 , j ) = rdat % fq3 ( 2 , j ) + rdat % fq ( 3 ) * work ( 2 , j ) rdat % fq3 ( 3 , j ) = rdat % fq3 ( 3 , j ) + rdat % fq ( 3 ) * work ( 3 , j ) rdat % fq3 ( 4 , j ) = rdat % fq3 ( 4 , j ) + rdat % fq ( 3 ) * work ( 4 , j ) rdat % fq4 ( 1 , j ) = rdat % fq4 ( 1 , j ) + rdat % fq ( 4 ) * work ( 1 , j ) rdat % fq4 ( 2 , j ) = rdat % fq4 ( 2 , j ) + rdat % fq ( 4 ) * work ( 2 , j ) rdat % fq4 ( 3 , j ) = rdat % fq4 ( 3 , j ) + rdat % fq ( 4 ) * work ( 3 , j ) rdat % fq4 ( 4 , j ) = rdat % fq4 ( 4 , j ) + rdat % fq ( 4 ) * work ( 4 , j ) rdat % fq4 ( 5 , j ) = rdat % fq4 ( 5 , j ) + rdat % fq ( 4 ) * work ( 5 , j ) enddo do j = 1 , 11 do k = 1 , 6 rdat % fq5 ( k , j ) = rdat % fq5 ( k , j ) + rdat % fq ( 5 ) * work ( k , j + 5 ) enddo enddo do j = 1 , 7 do k = 1 , 7 rdat % fq6 ( k , j ) = rdat % fq6 ( k , j ) + rdat % fq ( 6 ) * work ( k , j + 9 ) enddo enddo do j = 1 , 3 do k = 1 , 8 rdat % fq7 ( k , j ) = rdat % fq7 ( k , j ) + rdat % fq ( 7 ) * work ( k , j + 13 ) enddo enddo do k = 1 , 8 rdat % fq8 ( k ) = rdat % fq8 ( k ) + rdat % fq ( 8 ) * work ( k , 16 ) enddo rdat % fq8 ( 9 ) = rdat % fq8 ( 9 ) + rdat % fq ( 8 ) * work ( 8 , 16 ) * pqr end do end subroutine intj_21 ! > ! >    @brief   psss case ! > ! >    @details integration of a psss case ! > subroutine intk_02 ( rdat , ikl ) implicit none type ( rotaxis_data_t ) :: rdat integer :: ikl real ( kind = dp ) :: xmd2 , xmdt ! Generate jtype= 2 integrals if ( ikl == 0 ) then rdat % r00 ( 1 : 2 , 1 ) = 0.0_dp rdat % r01 ( 1 , 1 ) = 0.0_dp rdat % r01 ( 2 , 1 ) = 0.0_dp rdat % r01 ( 3 , 1 ) = 0.0_dp return endif xmd2 = rdat % x43 * 0.5d+00 xmdt = xmd2 rdat % r00 ( 1 , 1 ) = rdat % r00 ( 1 , 1 ) + rdat % fq0 ( 1 ) rdat % r00 ( 2 , 1 ) = rdat % r00 ( 2 , 1 ) - rdat % fq0 ( 1 ) * rdat % y03 ! Write(iw,*) 'intk_02 rdat%r00',rdat%r00(1),rdat%r00(2) ! Write(iw,*) 'rdat%fq0 rdat%sq',rdat%fq0(1),rdat%sq ! Write(iw,*) 'rdat%r00',rdat%sq,rdat%y03 rdat % r01 ( 1 , 1 ) = rdat % r01 ( 1 , 1 ) - rdat % fq1 ( 1 , 1 ) * rdat % aqx * xmdt rdat % r01 ( 2 , 1 ) = rdat % r01 ( 2 , 1 ) - rdat % fq1 ( 1 , 1 ) * rdat % acy * xmdt rdat % r01 ( 3 , 1 ) = rdat % r01 ( 3 , 1 ) + rdat % fq1 ( 2 , 1 ) * xmdt end subroutine intk_02 ! > ! >    @brief   ppss case ! > ! >    @details integration of a ppss case ! > subroutine intk_03 ( rdat , ikl ) implicit none type ( rotaxis_data_t ) :: rdat ! Generate jtype= 3 integrals integer :: ikl , i real ( dp ) :: fq11 , fq12 , fq13 , work ( 4 ), xmd2 , xmd3 , xmdt if ( ikl == 0 ) then rdat % r00 ( 1 : 5 , 1 ) = 0.0_dp rdat % r01 ( 1 : 3 , 1 : 4 ) = 0.0_dp rdat % r02 ( 1 : 6 , 1 ) = 0.0_dp return endif xmd2 = rdat % x43 * 0.5d+00 xmd3 = xmd2 xmdt = xmd3 * xmd2 work ( 1 ) = xmd2 work ( 2 ) = xmd2 work ( 3 ) = - xmd3 * rdat % y03 work ( 4 ) = xmd3 * rdat % y04 rdat % r00 ( 1 , 1 ) = rdat % r00 ( 1 , 1 ) + rdat % fq0 ( 1 ) rdat % r00 ( 2 , 1 ) = rdat % r00 ( 2 , 1 ) - rdat % fq0 ( 1 ) * rdat % y03 rdat % r00 ( 3 , 1 ) = rdat % r00 ( 3 , 1 ) + rdat % fq0 ( 1 ) * rdat % y04 rdat % r00 ( 4 , 1 ) = rdat % r00 ( 4 , 1 ) + rdat % fq0 ( 1 ) * xmd3 rdat % r00 ( 5 , 1 ) = rdat % r00 ( 5 , 1 ) - rdat % fq0 ( 1 ) * rdat % y03 * rdat % y04 fq11 = - rdat % fq1 ( 1 , 1 ) * rdat % aqx fq12 = - rdat % fq1 ( 1 , 1 ) * rdat % acy fq13 = rdat % fq1 ( 2 , 1 ) do i = 1 , 4 rdat % r01 ( 1 , i ) = rdat % r01 ( 1 , i ) + fq11 * work ( i ) rdat % r01 ( 2 , i ) = rdat % r01 ( 2 , i ) + fq12 * work ( i ) rdat % r01 ( 3 , i ) = rdat % r01 ( 3 , i ) + fq13 * work ( i ) enddo rdat % r02 ( 1 , 1 ) = rdat % r02 ( 1 , 1 ) + ( rdat % fq2 ( 1 , 1 ) * rdat % aqx2 - rdat % fq1 ( 1 , 1 ) ) * xmdt rdat % r02 ( 2 , 1 ) = rdat % r02 ( 2 , 1 ) + ( rdat % fq2 ( 1 , 1 ) * rdat % acy2 - rdat % fq1 ( 1 , 1 ) ) * xmdt rdat % r02 ( 3 , 1 ) = rdat % r02 ( 3 , 1 ) + ( rdat % fq2 ( 3 , 1 ) - rdat % fq1 ( 1 , 1 ) ) * xmdt rdat % r02 ( 4 , 1 ) = rdat % r02 ( 4 , 1 ) + rdat % fq2 ( 1 , 1 ) * rdat % aqxy * xmdt rdat % r02 ( 5 , 1 ) = rdat % r02 ( 5 , 1 ) - rdat % fq2 ( 2 , 1 ) * rdat % aqx * xmdt rdat % r02 ( 6 , 1 ) = rdat % r02 ( 6 , 1 ) - rdat % fq2 ( 2 , 1 ) * rdat % acy * xmdt end subroutine intk_03 ! > ! >    @brief   psps case ! > ! >    @details integration of a psps case ! > subroutine intk_04 ( rdat , ikl ) implicit none type ( rotaxis_data_t ) :: rdat integer :: ikl real ( kind = dp ) :: xmd2 real ( kind = dp ) :: work integer :: i ! Generate jtype= 4 integrals dimension work ( 4 ) if ( ikl == 0 ) then rdat % r00 ( 1 : 4 , 1 ) = 0.0_dp rdat % r01 ( 1 : 3 , 1 : 4 ) = 0.0_dp rdat % r02 ( 1 : 6 , 1 ) = 0.0_dp return endif xmd2 = rdat % x43 * 0.5d+00 work ( 1 ) = xmd2 work ( 2 ) = 1.0d0 work ( 3 ) = work ( 1 ) work ( 4 ) = - rdat % y03 rdat % r00 ( 1 , 1 ) = rdat % r00 ( 1 , 1 ) + rdat % fq0 ( 1 ) * work ( 2 ) rdat % r00 ( 2 , 1 ) = rdat % r00 ( 2 , 1 ) + rdat % fq0 ( 1 ) * work ( 4 ) rdat % r00 ( 3 , 1 ) = rdat % r00 ( 3 , 1 ) + rdat % fq0 ( 2 ) * work ( 2 ) rdat % r00 ( 4 , 1 ) = rdat % r00 ( 4 , 1 ) + rdat % fq0 ( 2 ) * work ( 4 ) do i = 1 , 3 rdat % r01 ( 1 , i ) = rdat % r01 ( 1 , i ) - rdat % fq1 ( 1 , i ) * rdat % aqx * work ( i ) rdat % r01 ( 2 , i ) = rdat % r01 ( 2 , i ) - rdat % fq1 ( 1 , i ) * rdat % acy * work ( i ) rdat % r01 ( 3 , i ) = rdat % r01 ( 3 , i ) + rdat % fq1 ( 2 , i ) * work ( i ) enddo rdat % r01 ( 1 , 4 ) = rdat % r01 ( 1 , 4 ) - rdat % fq1 ( 1 , 2 ) * rdat % aqx * work ( 4 ) rdat % r01 ( 2 , 4 ) = rdat % r01 ( 2 , 4 ) - rdat % fq1 ( 1 , 2 ) * rdat % acy * work ( 4 ) rdat % r01 ( 3 , 4 ) = rdat % r01 ( 3 , 4 ) + rdat % fq1 ( 2 , 2 ) * work ( 4 ) rdat % r02 ( 1 , 1 ) = rdat % r02 ( 1 , 1 ) + ( rdat % fq2 ( 1 , 1 ) * rdat % aqx2 - rdat % fq1 ( 1 , 2 ) ) * work ( 1 ) rdat % r02 ( 2 , 1 ) = rdat % r02 ( 2 , 1 ) + ( rdat % fq2 ( 1 , 1 ) * rdat % acy2 - rdat % fq1 ( 1 , 2 ) ) * work ( 1 ) rdat % r02 ( 3 , 1 ) = rdat % r02 ( 3 , 1 ) + ( rdat % fq2 ( 3 , 1 ) - rdat % fq1 ( 1 , 2 ) ) * work ( 1 ) rdat % r02 ( 4 , 1 ) = rdat % r02 ( 4 , 1 ) + rdat % fq2 ( 1 , 1 ) * rdat % aqxy * work ( 1 ) rdat % r02 ( 5 , 1 ) = rdat % r02 ( 5 , 1 ) - rdat % fq2 ( 2 , 1 ) * rdat % aqx * work ( 1 ) rdat % r02 ( 6 , 1 ) = rdat % r02 ( 6 , 1 ) - rdat % fq2 ( 2 , 1 ) * rdat % acy * work ( 1 ) end subroutine intk_04 ! > ! >    @brief   ppps case ! > ! >    @details integration of a ppps case ! > subroutine intk_05 ( rdat , ikl ) implicit none type ( rotaxis_data_t ) :: rdat integer :: ikl real ( kind = dp ) :: xmd2 , xmd3 , xmdt , xmdtx , xmdtxy , xmdty real ( kind = dp ) :: work , fwk integer :: i , j ! Generate jtype= 5 integrals dimension work ( 9 ), fwk ( 6 , 3 ) if ( ikl == 0 ) then do i = 1 , 2 rdat % r00 ( 1 , i ) = 0.0_dp rdat % r00 ( 2 , i ) = 0.0_dp rdat % r00 ( 3 , i ) = 0.0_dp rdat % r00 ( 4 , i ) = 0.0_dp rdat % r00 ( 5 , i ) = 0.0_dp enddo do i = 1 , 13 rdat % r01 ( 1 , i ) = 0.0_dp rdat % r01 ( 2 , i ) = 0.0_dp rdat % r01 ( 3 , i ) = 0.0_dp enddo do i = 1 , 6 rdat % r02 ( 1 , i ) = 0.0_dp rdat % r02 ( 2 , i ) = 0.0_dp rdat % r02 ( 3 , i ) = 0.0_dp rdat % r02 ( 4 , i ) = 0.0_dp rdat % r02 ( 5 , i ) = 0.0_dp rdat % r02 ( 6 , i ) = 0.0_dp enddo do j = 1 , 10 rdat % r03 ( j , 1 ) = 0.0_dp enddo return endif xmd2 = rdat % x43 * 0.5d+00 xmd3 = xmd2 xmdt = xmd3 * xmd2 xmdty = - xmdt * rdat % acy xmdtx = - xmdt * rdat % aqx xmdtxy = xmdt * rdat % aqxy work ( 1 ) = 1.0d0 work ( 2 ) = - rdat % y03 work ( 3 ) = rdat % y04 work ( 4 ) = - rdat % y03 * rdat % y04 work ( 5 ) = xmd3 work ( 6 ) = xmd2 work ( 7 ) = xmd2 work ( 8 ) = - xmd3 * rdat % y03 work ( 9 ) = xmd3 * rdat % y04 do i = 1 , 2 rdat % r00 ( 1 : 5 , i ) = rdat % r00 ( 1 : 5 , i ) + rdat % fq0 ( i ) * work ( 1 : 5 ) end do do i = 1 , 3 fwk ( 1 , i ) = - rdat % fq1 ( 1 , i ) * rdat % aqx fwk ( 2 , i ) = - rdat % fq1 ( 1 , i ) * rdat % acy fwk ( 3 , i ) = rdat % fq1 ( 2 , i ) enddo do i = 1 , 4 rdat % r01 ( 1 , i ) = rdat % r01 ( 1 , i ) + fwk ( 1 , 1 ) * work ( i + 5 ) rdat % r01 ( 2 , i ) = rdat % r01 ( 2 , i ) + fwk ( 2 , 1 ) * work ( i + 5 ) rdat % r01 ( 3 , i ) = rdat % r01 ( 3 , i ) + fwk ( 3 , 1 ) * work ( i + 5 ) enddo do i = 5 , 8 rdat % r01 ( 1 , i ) = rdat % r01 ( 1 , i ) + fwk ( 1 , 2 ) * work ( i + 1 ) rdat % r01 ( 2 , i ) = rdat % r01 ( 2 , i ) + fwk ( 2 , 2 ) * work ( i + 1 ) rdat % r01 ( 3 , i ) = rdat % r01 ( 3 , i ) + fwk ( 3 , 2 ) * work ( i + 1 ) enddo do i = 9 , 13 rdat % r01 ( 1 , i ) = rdat % r01 ( 1 , i ) + fwk ( 1 , 3 ) * work ( i - 8 ) rdat % r01 ( 2 , i ) = rdat % r01 ( 2 , i ) + fwk ( 2 , 3 ) * work ( i - 8 ) rdat % r01 ( 3 , i ) = rdat % r01 ( 3 , i ) + fwk ( 3 , 3 ) * work ( i - 8 ) enddo do i = 1 , 2 rdat % r02 ( 1 , i ) = rdat % r02 ( 1 , i ) + ( rdat % fq2 ( 1 , i ) * rdat % aqx2 - rdat % fq1 ( 1 , i ) ) & * xmdt rdat % r02 ( 2 , i ) = rdat % r02 ( 2 , i ) + ( rdat % fq2 ( 1 , i ) * rdat % acy2 - rdat % fq1 ( 1 , i ) ) & * xmdt rdat % r02 ( 3 , i ) = rdat % r02 ( 3 , i ) + ( rdat % fq2 ( 3 , i ) - rdat % fq1 ( 1 , i ) ) * xmdt rdat % r02 ( 4 , i ) = rdat % r02 ( 4 , i ) + rdat % fq2 ( 1 , i ) * xmdtxy rdat % r02 ( 5 , i ) = rdat % r02 ( 5 , i ) + rdat % fq2 ( 2 , i ) * xmdtx rdat % r02 ( 6 , i ) = rdat % r02 ( 6 , i ) + rdat % fq2 ( 2 , i ) * xmdty enddo fwk ( 1 , 3 ) = rdat % fq2 ( 1 , 3 ) * rdat % aqx2 - rdat % fq1 ( 1 , 3 ) fwk ( 2 , 3 ) = rdat % fq2 ( 1 , 3 ) * rdat % acy2 - rdat % fq1 ( 1 , 3 ) fwk ( 3 , 3 ) = rdat % fq2 ( 3 , 3 ) - rdat % fq1 ( 1 , 3 ) fwk ( 4 , 3 ) = rdat % fq2 ( 1 , 3 ) * rdat % aqxy fwk ( 5 , 3 ) = - rdat % fq2 ( 2 , 3 ) * rdat % aqx fwk ( 6 , 3 ) = - rdat % fq2 ( 2 , 3 ) * rdat % acy do i = 3 , 6 do j = 1 , 6 rdat % r02 ( j , i ) = rdat % r02 ( j , i ) + fwk ( j , 3 ) * work ( i + 3 ) enddo enddo rdat % r03 ( 1 , 1 ) = rdat % r03 ( 1 , 1 ) + ( rdat % fq3 ( 1 , 1 ) * rdat % aqx2 - rdat % fq2 ( 1 , 3 ) * 3 ) & * xmdtx rdat % r03 ( 2 , 1 ) = rdat % r03 ( 2 , 1 ) + ( rdat % fq3 ( 1 , 1 ) * rdat % aqx2 - rdat % fq2 ( 1 , 3 ) ) & * xmdty rdat % r03 ( 3 , 1 ) = rdat % r03 ( 3 , 1 ) + ( rdat % fq3 ( 2 , 1 ) * rdat % aqx2 - rdat % fq2 ( 2 , 3 ) ) & * xmdt rdat % r03 ( 4 , 1 ) = rdat % r03 ( 4 , 1 ) + ( rdat % fq3 ( 1 , 1 ) * rdat % acy2 - rdat % fq2 ( 1 , 3 ) ) & * xmdtx rdat % r03 ( 5 , 1 ) = rdat % r03 ( 5 , 1 ) + rdat % fq3 ( 2 , 1 ) * xmdtxy rdat % r03 ( 6 , 1 ) = rdat % r03 ( 6 , 1 ) + ( rdat % fq3 ( 3 , 1 ) - rdat % fq2 ( 1 , 3 ) ) * xmdtx rdat % r03 ( 7 , 1 ) = rdat % r03 ( 7 , 1 ) + ( rdat % fq3 ( 1 , 1 ) * rdat % acy2 - rdat % fq2 ( 1 , 3 ) * 3 ) & * xmdty rdat % r03 ( 8 , 1 ) = rdat % r03 ( 8 , 1 ) + ( rdat % fq3 ( 2 , 1 ) * rdat % acy2 - rdat % fq2 ( 2 , 3 ) ) & * xmdt rdat % r03 ( 9 , 1 ) = rdat % r03 ( 9 , 1 ) + ( rdat % fq3 ( 3 , 1 ) - rdat % fq2 ( 1 , 3 ) ) * xmdty rdat % r03 ( 10 , 1 ) = rdat % r03 ( 10 , 1 ) + ( rdat % fq3 ( 4 , 1 ) - rdat % fq2 ( 2 , 3 ) * 3 ) & * xmdt end subroutine intk_05 ! > ! >    @brief   pppp case ! > ! >    @details integration of a pppp case ! > subroutine intk_06 ( rdat , ikl ) implicit none type ( rotaxis_data_t ) :: rdat integer :: ikl real ( kind = dp ) :: xmd2 , xmd3 , xmdt , xmdtx , xmdtxy , xmdty real ( kind = dp ) :: tmp0 , tmp1 , tmp2 , tmp3 , aqx4 , acy4 , q2c2 , x2y2 real ( kind = dp ) :: work , fwk , fqw integer :: i , j ! Generate jtype= 6 integrals dimension work ( 9 ), fwk ( 10 ), fqw ( 6 , 9 ) if ( ikl == 0 ) then do i = 1 , 5 rdat % r00 ( 1 , i ) = 0.0_dp rdat % r00 ( 2 , i ) = 0.0_dp rdat % r00 ( 3 , i ) = 0.0_dp rdat % r00 ( 4 , i ) = 0.0_dp rdat % r00 ( 5 , i ) = 0.0_dp enddo do i = 1 , 40 rdat % r01 ( 1 , i ) = 0.0_dp rdat % r01 ( 2 , i ) = 0.0_dp rdat % r01 ( 3 , i ) = 0.0_dp enddo do i = 1 , 26 rdat % r02 ( 1 , i ) = 0.0_dp rdat % r02 ( 2 , i ) = 0.0_dp rdat % r02 ( 3 , i ) = 0.0_dp rdat % r02 ( 4 , i ) = 0.0_dp rdat % r02 ( 5 , i ) = 0.0_dp rdat % r02 ( 6 , i ) = 0.0_dp enddo do i = 1 , 8 do j = 1 , 10 rdat % r03 ( j , i ) = 0.0_dp enddo enddo do j = 1 , 15 rdat % r04 ( j , 1 ) = 0.0_dp enddo return endif xmd2 = rdat % x43 * 0.5d+00 xmd3 = xmd2 xmdt = xmd3 * xmd2 xmdty = - xmdt * rdat % acy xmdtx = - xmdt * rdat % aqx xmdtxy = xmdt * rdat % aqxy work ( 1 ) = 1.0d0 work ( 2 ) = - rdat % y03 work ( 3 ) = rdat % y04 work ( 4 ) = - rdat % y03 * rdat % y04 work ( 5 ) = xmd3 work ( 6 ) = xmd2 work ( 7 ) = xmd2 work ( 8 ) = - xmd3 * rdat % y03 work ( 9 ) = xmd3 * rdat % y04 do j = 1 , 5 do i = 1 , 5 rdat % r00 ( i , j ) = rdat % r00 ( i , j ) + rdat % fq0 ( j ) * work ( i ) end do end do do i = 1 , 8 fqw ( 1 , i ) = - rdat % fq1 ( 1 , i ) * rdat % aqx fqw ( 2 , i ) = - rdat % fq1 ( 1 , i ) * rdat % acy fqw ( 3 , i ) = rdat % fq1 ( 2 , i ) enddo tmp1 = rdat % fq1 ( 1 , 5 ) * rdat % rab + rdat % fq1 ( 1 , 8 ) tmp2 = rdat % fq1 ( 2 , 5 ) * rdat % rab + rdat % fq1 ( 2 , 8 ) fqw ( 1 , 9 ) = - tmp1 * rdat % aqx fqw ( 2 , 9 ) = - tmp1 * rdat % acy fqw ( 3 , 9 ) = tmp2 do i = 1 , 4 rdat % r01 ( 1 , i ) = rdat % r01 ( 1 , i ) + fqw ( 1 , 1 ) * work ( i + 5 ) rdat % r01 ( 2 , i ) = rdat % r01 ( 2 , i ) + fqw ( 2 , 1 ) * work ( i + 5 ) rdat % r01 ( 3 , i ) = rdat % r01 ( 3 , i ) + fqw ( 3 , 1 ) * work ( i + 5 ) enddo do i = 5 , 8 rdat % r01 ( 1 , i ) = rdat % r01 ( 1 , i ) + fqw ( 1 , 2 ) * work ( i + 1 ) rdat % r01 ( 2 , i ) = rdat % r01 ( 2 , i ) + fqw ( 2 , 2 ) * work ( i + 1 ) rdat % r01 ( 3 , i ) = rdat % r01 ( 3 , i ) + fqw ( 3 , 2 ) * work ( i + 1 ) enddo do i = 9 , 12 rdat % r01 ( 1 , i ) = rdat % r01 ( 1 , i ) + fqw ( 1 , 3 ) * work ( i - 3 ) rdat % r01 ( 2 , i ) = rdat % r01 ( 2 , i ) + fqw ( 2 , 3 ) * work ( i - 3 ) rdat % r01 ( 3 , i ) = rdat % r01 ( 3 , i ) + fqw ( 3 , 3 ) * work ( i - 3 ) enddo do i = 13 , 16 rdat % r01 ( 1 , i ) = rdat % r01 ( 1 , i ) + fqw ( 1 , 4 ) * work ( i - 7 ) rdat % r01 ( 2 , i ) = rdat % r01 ( 2 , i ) + fqw ( 2 , 4 ) * work ( i - 7 ) rdat % r01 ( 3 , i ) = rdat % r01 ( 3 , i ) + fqw ( 3 , 4 ) * work ( i - 7 ) enddo do i = 17 , 20 rdat % r01 ( 1 , i ) = rdat % r01 ( 1 , i ) + fqw ( 1 , 5 ) * work ( i - 11 ) rdat % r01 ( 2 , i ) = rdat % r01 ( 2 , i ) + fqw ( 2 , 5 ) * work ( i - 11 ) rdat % r01 ( 3 , i ) = rdat % r01 ( 3 , i ) + fqw ( 3 , 5 ) * work ( i - 11 ) enddo do i = 21 , 25 rdat % r01 ( 1 , i ) = rdat % r01 ( 1 , i ) + fqw ( 1 , 6 ) * work ( i - 20 ) rdat % r01 ( 2 , i ) = rdat % r01 ( 2 , i ) + fqw ( 2 , 6 ) * work ( i - 20 ) rdat % r01 ( 3 , i ) = rdat % r01 ( 3 , i ) + fqw ( 3 , 6 ) * work ( i - 20 ) enddo do i = 26 , 30 rdat % r01 ( 1 , i ) = rdat % r01 ( 1 , i ) + fqw ( 1 , 7 ) * work ( i - 25 ) rdat % r01 ( 2 , i ) = rdat % r01 ( 2 , i ) + fqw ( 2 , 7 ) * work ( i - 25 ) rdat % r01 ( 3 , i ) = rdat % r01 ( 3 , i ) + fqw ( 3 , 7 ) * work ( i - 25 ) enddo do i = 31 , 35 rdat % r01 ( 1 , i ) = rdat % r01 ( 1 , i ) + fqw ( 1 , 8 ) * work ( i - 30 ) rdat % r01 ( 2 , i ) = rdat % r01 ( 2 , i ) + fqw ( 2 , 8 ) * work ( i - 30 ) rdat % r01 ( 3 , i ) = rdat % r01 ( 3 , i ) + fqw ( 3 , 8 ) * work ( i - 30 ) enddo do i = 36 , 40 rdat % r01 ( 1 , i ) = rdat % r01 ( 1 , i ) + fqw ( 1 , 9 ) * work ( i - 35 ) rdat % r01 ( 2 , i ) = rdat % r01 ( 2 , i ) + fqw ( 2 , 9 ) * work ( i - 35 ) rdat % r01 ( 3 , i ) = rdat % r01 ( 3 , i ) + fqw ( 3 , 9 ) * work ( i - 35 ) enddo do i = 1 , 5 rdat % r02 ( 1 , i ) = rdat % r02 ( 1 , i ) + ( rdat % fq2 ( 1 , i ) * rdat % aqx2 - rdat % fq1 ( 1 , i ) ) & * xmdt rdat % r02 ( 2 , i ) = rdat % r02 ( 2 , i ) + ( rdat % fq2 ( 1 , i ) * rdat % acy2 - rdat % fq1 ( 1 , i ) ) & * xmdt rdat % r02 ( 3 , i ) = rdat % r02 ( 3 , i ) + ( rdat % fq2 ( 3 , i ) - rdat % fq1 ( 1 , i ) ) * xmdt rdat % r02 ( 4 , i ) = rdat % r02 ( 4 , i ) + rdat % fq2 ( 1 , i ) * xmdtxy rdat % r02 ( 5 , i ) = rdat % r02 ( 5 , i ) + rdat % fq2 ( 2 , i ) * xmdtx rdat % r02 ( 6 , i ) = rdat % r02 ( 6 , i ) + rdat % fq2 ( 2 , i ) * xmdty enddo tmp0 = rdat % fq1 ( 1 , 5 ) * rdat % rab + rdat % fq1 ( 1 , 8 ) tmp1 = rdat % fq2 ( 1 , 5 ) * rdat % rab + rdat % fq2 ( 1 , 8 ) tmp2 = rdat % fq2 ( 2 , 5 ) * rdat % rab + rdat % fq2 ( 2 , 8 ) tmp3 = rdat % fq2 ( 3 , 5 ) * rdat % rab + rdat % fq2 ( 3 , 8 ) fqw ( 1 , 5 ) = tmp1 * rdat % aqx2 - tmp0 fqw ( 2 , 5 ) = tmp1 * rdat % acy2 - tmp0 fqw ( 3 , 5 ) = tmp3 - tmp0 fqw ( 4 , 5 ) = tmp1 * rdat % aqxy fqw ( 5 , 5 ) = - tmp2 * rdat % aqx fqw ( 6 , 5 ) = - tmp2 * rdat % acy do i = 6 , 9 fqw ( 1 , i ) = rdat % fq2 ( 1 , i ) * rdat % aqx2 - rdat % fq1 ( 1 , i ) fqw ( 2 , i ) = rdat % fq2 ( 1 , i ) * rdat % acy2 - rdat % fq1 ( 1 , i ) fqw ( 3 , i ) = rdat % fq2 ( 3 , i ) - rdat % fq1 ( 1 , i ) fqw ( 4 , i ) = rdat % fq2 ( 1 , i ) * rdat % aqxy fqw ( 5 , i ) = - rdat % fq2 ( 2 , i ) * rdat % aqx fqw ( 6 , i ) = - rdat % fq2 ( 2 , i ) * rdat % acy enddo do i = 6 , 9 do j = 1 , 6 rdat % r02 ( j , i ) = rdat % r02 ( j , i ) + fqw ( j , 6 ) * work ( i ) end do end do do i = 10 , 13 do j = 1 , 6 rdat % r02 ( j , i ) = rdat % r02 ( j , i ) + fqw ( j , 7 ) * work ( i - 4 ) end do end do do i = 14 , 17 do j = 1 , 6 rdat % r02 ( j , i ) = rdat % r02 ( j , i ) + fqw ( j , 8 ) * work ( i - 8 ) end do end do do i = 18 , 21 do j = 1 , 6 rdat % r02 ( j , i ) = rdat % r02 ( j , i ) + fqw ( j , 5 ) * work ( i - 12 ) end do end do do i = 22 , 26 do j = 1 , 6 rdat % r02 ( j , i ) = rdat % r02 ( j , i ) + fqw ( j , 9 ) * work ( i - 21 ) end do end do rdat % fq2 ( 1 , 5 ) = rdat % fq2 ( 1 , 5 ) * rdat % rab + rdat % fq2 ( 1 , 8 ) rdat % fq2 ( 2 , 5 ) = rdat % fq2 ( 2 , 5 ) * rdat % rab + rdat % fq2 ( 2 , 8 ) rdat % fq3 ( 1 , 1 ) = rdat % fq3 ( 1 , 1 ) * rdat % rab + rdat % fq3 ( 1 , 4 ) rdat % fq3 ( 2 , 1 ) = rdat % fq3 ( 2 , 1 ) * rdat % rab + rdat % fq3 ( 2 , 4 ) rdat % fq3 ( 3 , 1 ) = rdat % fq3 ( 3 , 1 ) * rdat % rab + rdat % fq3 ( 3 , 4 ) rdat % fq3 ( 4 , 1 ) = rdat % fq3 ( 4 , 1 ) * rdat % rab + rdat % fq3 ( 4 , 4 ) do i = 1 , 4 rdat % r03 ( 1 , i ) = rdat % r03 ( 1 , i ) + ( rdat % fq3 ( 1 , i ) * rdat % aqx2 - rdat % fq2 ( 1 , i + 4 ) & * 3 ) * xmdtx rdat % r03 ( 2 , i ) = rdat % r03 ( 2 , i ) + ( rdat % fq3 ( 1 , i ) * rdat % aqx2 - rdat % fq2 ( 1 , i + 4 ) ) & * xmdty rdat % r03 ( 3 , i ) = rdat % r03 ( 3 , i ) + ( rdat % fq3 ( 2 , i ) * rdat % aqx2 - rdat % fq2 ( 2 , i + 4 ) ) & * xmdt rdat % r03 ( 4 , i ) = rdat % r03 ( 4 , i ) + ( rdat % fq3 ( 1 , i ) * rdat % acy2 - rdat % fq2 ( 1 , i + 4 ) ) & * xmdtx rdat % r03 ( 5 , i ) = rdat % r03 ( 5 , i ) + rdat % fq3 ( 2 , i ) * xmdtxy rdat % r03 ( 6 , i ) = rdat % r03 ( 6 , i ) + ( rdat % fq3 ( 3 , i ) - rdat % fq2 ( 1 , i + 4 ) ) * xmdtx rdat % r03 ( 7 , i ) = rdat % r03 ( 7 , i ) + ( rdat % fq3 ( 1 , i ) * rdat % acy2 - rdat % fq2 ( 1 , i + 4 ) & * 3 ) * xmdty rdat % r03 ( 8 , i ) = rdat % r03 ( 8 , i ) + ( rdat % fq3 ( 2 , i ) * rdat % acy2 - rdat % fq2 ( 2 , i + 4 ) ) & * xmdt rdat % r03 ( 9 , i ) = rdat % r03 ( 9 , i ) + ( rdat % fq3 ( 3 , i ) - rdat % fq2 ( 1 , i + 4 ) ) * xmdty rdat % r03 ( 10 , i ) = rdat % r03 ( 10 , i ) + ( rdat % fq3 ( 4 , i ) - rdat % fq2 ( 2 , i + 4 ) * 3 ) & * xmdt enddo fwk ( 1 ) = - ( rdat % fq3 ( 1 , 5 ) * rdat % aqx2 - rdat % fq2 ( 1 , 9 ) * 3 ) * rdat % aqx fwk ( 2 ) = - ( rdat % fq3 ( 1 , 5 ) * rdat % aqx2 - rdat % fq2 ( 1 , 9 ) ) * rdat % acy fwk ( 3 ) = rdat % fq3 ( 2 , 5 ) * rdat % aqx2 - rdat % fq2 ( 2 , 9 ) fwk ( 4 ) = - ( rdat % fq3 ( 1 , 5 ) * rdat % acy2 - rdat % fq2 ( 1 , 9 ) ) * rdat % aqx fwk ( 5 ) = rdat % fq3 ( 2 , 5 ) * rdat % aqxy fwk ( 6 ) = - ( rdat % fq3 ( 3 , 5 ) - rdat % fq2 ( 1 , 9 ) ) * rdat % aqx fwk ( 7 ) = - ( rdat % fq3 ( 1 , 5 ) * rdat % acy2 - rdat % fq2 ( 1 , 9 ) * 3 ) * rdat % acy fwk ( 8 ) = rdat % fq3 ( 2 , 5 ) * rdat % acy2 - rdat % fq2 ( 2 , 9 ) fwk ( 9 ) = - ( rdat % fq3 ( 3 , 5 ) - rdat % fq2 ( 1 , 9 ) ) * rdat % acy fwk ( 10 ) = rdat % fq3 ( 4 , 5 ) - rdat % fq2 ( 2 , 9 ) * 3 do i = 5 , 8 do j = 1 , 10 rdat % r03 ( j , i ) = rdat % r03 ( j , i ) + fwk ( j ) * work ( i + 1 ) end do end do aqx4 = rdat % aqx2 * rdat % aqx2 acy4 = rdat % acy2 * rdat % acy2 x2y2 = rdat % aqx2 * rdat % acy2 q2c2 = rdat % aqx2 + rdat % acy2 rdat % r04 ( 1 , 1 ) = rdat % r04 ( 1 , 1 ) + ( rdat % fq4 ( 1 , 1 ) * aqx4 - rdat % fq3 ( 1 , 5 ) * 6 * rdat % aqx2 + & rdat % fq2 ( 1 , 9 ) * 3 ) * xmdt rdat % r04 ( 2 , 1 ) = rdat % r04 ( 2 , 1 ) + ( rdat % fq4 ( 1 , 1 ) * rdat % aqx2 - rdat % fq3 ( 1 , 5 ) * 3 ) * xmdtxy rdat % r04 ( 3 , 1 ) = rdat % r04 ( 3 , 1 ) + ( rdat % fq4 ( 2 , 1 ) * rdat % aqx2 - rdat % fq3 ( 2 , 5 ) * 3 ) * xmdtx rdat % r04 ( 4 , 1 ) = rdat % r04 ( 4 , 1 ) + ( rdat % fq4 ( 1 , 1 ) * x2y2 - rdat % fq3 ( 1 , 5 ) * q2c2 + rdat % fq2 ( 1 , & 9 ) ) * xmdt rdat % r04 ( 5 , 1 ) = rdat % r04 ( 5 , 1 ) + ( rdat % fq4 ( 2 , 1 ) * rdat % aqx2 - rdat % fq3 ( 2 , 5 ) ) * xmdty rdat % r04 ( 6 , 1 ) = rdat % r04 ( 6 , 1 ) + ( rdat % fq4 ( 3 , 1 ) * rdat % aqx2 - rdat % fq3 ( 1 , 5 ) * rdat % aqx2 - rdat % fq3 ( 3 , & 5 ) + rdat % fq2 ( 1 , 9 ) ) * xmdt rdat % r04 ( 7 , 1 ) = rdat % r04 ( 7 , 1 ) + ( rdat % fq4 ( 1 , 1 ) * rdat % acy2 - rdat % fq3 ( 1 , 5 ) * 3 ) * xmdtxy rdat % r04 ( 8 , 1 ) = rdat % r04 ( 8 , 1 ) + ( rdat % fq4 ( 2 , 1 ) * rdat % acy2 - rdat % fq3 ( 2 , 5 ) ) * xmdtx rdat % r04 ( 9 , 1 ) = rdat % r04 ( 9 , 1 ) + ( rdat % fq4 ( 3 , 1 ) - rdat % fq3 ( 1 , 5 ) ) * xmdtxy rdat % r04 ( 10 , 1 ) = rdat % r04 ( 10 , 1 ) + ( rdat % fq4 ( 4 , 1 ) - rdat % fq3 ( 2 , 5 ) * 3 ) * xmdtx rdat % r04 ( 11 , 1 ) = rdat % r04 ( 11 , 1 ) + ( rdat % fq4 ( 1 , 1 ) * acy4 - rdat % fq3 ( 1 , 5 ) * 6 * rdat % acy2 + & rdat % fq2 ( 1 , 9 ) * 3 ) * xmdt rdat % r04 ( 12 , 1 ) = rdat % r04 ( 12 , 1 ) + ( rdat % fq4 ( 2 , 1 ) * rdat % acy2 - rdat % fq3 ( 2 , 5 ) * 3 ) * xmdty rdat % r04 ( 13 , 1 ) = rdat % r04 ( 13 , 1 ) + ( rdat % fq4 ( 3 , 1 ) * rdat % acy2 - rdat % fq3 ( 1 , 5 ) * rdat % acy2 - rdat % fq3 ( & 3 , 5 ) + rdat % fq2 ( 1 , 9 ) ) * xmdt rdat % r04 ( 14 , 1 ) = rdat % r04 ( 14 , 1 ) + ( rdat % fq4 ( 4 , 1 ) - rdat % fq3 ( 2 , 5 ) * 3 ) * xmdty rdat % r04 ( 15 , 1 ) = rdat % r04 ( 15 , 1 ) + ( rdat % fq4 ( 5 , 1 ) - rdat % fq3 ( 3 , 5 ) * 6 + rdat % fq2 ( 1 , 9 ) & * 3 ) * xmdt end subroutine intk_06 ! > ! >    @brief   dsss case ! > ! >    @details integration of the dsss case ! > subroutine intk_07 ( rdat , ikl ) implicit none type ( rotaxis_data_t ) :: rdat integer :: ikl real ( kind = dp ) :: xmd1 , xmd2 , xmdt ! Generate jtype= 7 integrals if ( ikl == 0 ) then rdat % r00 ( 1 : 2 , 1 ) = 0.0_dp rdat % r01 (:, 1 ) = 0.0_dp rdat % r02 (:, 1 ) = 0.0_dp return endif xmd2 = rdat % x43 * 0.5d+00 xmd1 = xmd2 xmdt = xmd2 * xmd1 xmd2 =- xmd1 * rdat % y03 rdat % r00 ( 1 , 1 ) = rdat % r00 ( 1 , 1 ) + rdat % fq0 ( 1 ) * xmd1 rdat % r00 ( 2 , 1 ) = rdat % r00 ( 2 , 1 ) + rdat % fq0 ( 1 ) * rdat % y03 * rdat % y03 rdat % r01 ( 1 , 1 ) = rdat % r01 ( 1 , 1 ) - rdat % fq1 ( 1 , 1 ) * rdat % aqx * xmd2 rdat % r01 ( 2 , 1 ) = rdat % r01 ( 2 , 1 ) - rdat % fq1 ( 1 , 1 ) * rdat % acy * xmd2 rdat % r01 ( 3 , 1 ) = rdat % r01 ( 3 , 1 ) + rdat % fq1 ( 2 , 1 ) * xmd2 rdat % r02 ( 1 , 1 ) = rdat % r02 ( 1 , 1 ) + ( rdat % fq2 ( 1 , 1 ) * rdat % aqx2 - rdat % fq1 ( 1 , 1 )) * xmdt rdat % r02 ( 2 , 1 ) = rdat % r02 ( 2 , 1 ) + ( rdat % fq2 ( 1 , 1 ) * rdat % acy2 - rdat % fq1 ( 1 , 1 )) * xmdt rdat % r02 ( 3 , 1 ) = rdat % r02 ( 3 , 1 ) + ( rdat % fq2 ( 3 , 1 ) - rdat % fq1 ( 1 , 1 )) * xmdt rdat % r02 ( 4 , 1 ) = rdat % r02 ( 4 , 1 ) + rdat % fq2 ( 1 , 1 ) * rdat % aqxy * xmdt rdat % r02 ( 5 , 1 ) = rdat % r02 ( 5 , 1 ) - rdat % fq2 ( 2 , 1 ) * rdat % aqx * xmdt rdat % r02 ( 6 , 1 ) = rdat % r02 ( 6 , 1 ) - rdat % fq2 ( 2 , 1 ) * rdat % acy * xmdt end subroutine intk_07 ! > ! >    @brief   dpss case ! > ! >    @details integration of the dpss case ! > subroutine intk_08 ( rdat , ikl ) implicit none type ( rotaxis_data_t ) :: rdat integer :: ikl real ( kind = dp ) :: xmd1 , xmd2 , xmd3 , xmd4 , xmd5 , xmdt , xmdtx , xmdtxy , xmdty real ( kind = dp ) :: y33 , y334 , y34 real ( kind = dp ) :: work , fwk integer :: i , j ! Generate jtype= 8 integrals dimension work ( 4 ), fwk ( 6 ) if ( ikl == 0 ) then rdat % r00 ( 1 , 1 ) = 0.0_dp rdat % r00 ( 2 , 1 ) = 0.0_dp rdat % r00 ( 3 , 1 ) = 0.0_dp rdat % r00 ( 4 , 1 ) = 0.0_dp rdat % r00 ( 5 , 1 ) = 0.0_dp do i = 1 , 4 rdat % r01 ( 1 , i ) = 0.0_dp rdat % r01 ( 2 , i ) = 0.0_dp rdat % r01 ( 3 , i ) = 0.0_dp enddo do i = 1 , 3 rdat % r02 ( 1 , i ) = 0.0_dp rdat % r02 ( 2 , i ) = 0.0_dp rdat % r02 ( 3 , i ) = 0.0_dp rdat % r02 ( 4 , i ) = 0.0_dp rdat % r02 ( 5 , i ) = 0.0_dp rdat % r02 ( 6 , i ) = 0.0_dp enddo do j = 1 , 10 rdat % r03 ( j , 1 ) = 0.0_dp enddo return endif xmd2 = rdat % x43 * 0.5d+00 xmd1 = xmd2 xmd3 = xmd2 xmd4 = xmd2 * xmd2 xmd5 = xmd4 xmdt = xmd4 * xmd3 xmdty =- xmdt * rdat % acy xmdtx =- xmdt * rdat % aqx xmdtxy = xmdt * rdat % aqxy y33 = rdat % y03 * rdat % y03 y34 =- rdat % y03 * rdat % y04 y334 = y33 * rdat % y04 work ( 1 ) =- xmd1 * rdat % y03 work ( 2 ) = xmd5 work ( 3 ) = xmd3 * y33 work ( 4 ) = xmd3 * y34 rdat % r00 ( 1 , 1 ) = rdat % r00 ( 1 , 1 ) + rdat % fq0 ( 1 ) * xmd1 rdat % r00 ( 2 , 1 ) = rdat % r00 ( 2 , 1 ) + rdat % fq0 ( 1 ) * y33 rdat % r00 ( 3 , 1 ) = rdat % r00 ( 3 , 1 ) - rdat % fq0 ( 1 ) * xmd3 * rdat % y03 rdat % r00 ( 4 , 1 ) = rdat % r00 ( 4 , 1 ) + rdat % fq0 ( 1 ) * xmd3 * rdat % y04 rdat % r00 ( 5 , 1 ) = rdat % r00 ( 5 , 1 ) + rdat % fq0 ( 1 ) * y334 fwk ( 1 ) =- rdat % fq1 ( 1 , 1 ) * rdat % aqx fwk ( 2 ) =- rdat % fq1 ( 1 , 1 ) * rdat % acy fwk ( 3 ) = rdat % fq1 ( 2 , 1 ) do i = 1 , 4 rdat % r01 ( 1 , i ) = rdat % r01 ( 1 , i ) + fwk ( 1 ) * work ( i ) rdat % r01 ( 2 , i ) = rdat % r01 ( 2 , i ) + fwk ( 2 ) * work ( i ) rdat % r01 ( 3 , i ) = rdat % r01 ( 3 , i ) + fwk ( 3 ) * work ( i ) enddo work ( 1 ) = xmd4 work ( 2 ) =- xmd5 * rdat % y03 work ( 3 ) = xmd5 * rdat % y04 fwk ( 1 ) = rdat % fq2 ( 1 , 1 ) * rdat % aqx2 - rdat % fq1 ( 1 , 1 ) fwk ( 2 ) = rdat % fq2 ( 1 , 1 ) * rdat % acy2 - rdat % fq1 ( 1 , 1 ) fwk ( 3 ) = rdat % fq2 ( 3 , 1 ) - rdat % fq1 ( 1 , 1 ) fwk ( 4 ) = rdat % fq2 ( 1 , 1 ) * rdat % aqxy fwk ( 5 ) =- rdat % fq2 ( 2 , 1 ) * rdat % aqx fwk ( 6 ) =- rdat % fq2 ( 2 , 1 ) * rdat % acy do i = 1 , 3 do j = 1 , 6 rdat % r02 ( j , i ) = rdat % r02 ( j , i ) + fwk ( j ) * work ( i ) end do end do rdat % r03 ( 1 , 1 ) = rdat % r03 ( 1 , 1 ) + ( rdat % fq3 ( 1 , 1 ) * rdat % aqx2 - rdat % fq2 ( 1 , 1 ) * 3 ) * xmdtx rdat % r03 ( 2 , 1 ) = rdat % r03 ( 2 , 1 ) + ( rdat % fq3 ( 1 , 1 ) * rdat % aqx2 - rdat % fq2 ( 1 , 1 ) ) * xmdty rdat % r03 ( 3 , 1 ) = rdat % r03 ( 3 , 1 ) + ( rdat % fq3 ( 2 , 1 ) * rdat % aqx2 - rdat % fq2 ( 2 , 1 ) ) * xmdt rdat % r03 ( 4 , 1 ) = rdat % r03 ( 4 , 1 ) + ( rdat % fq3 ( 1 , 1 ) * rdat % acy2 - rdat % fq2 ( 1 , 1 ) ) * xmdtx rdat % r03 ( 5 , 1 ) = rdat % r03 ( 5 , 1 ) + rdat % fq3 ( 2 , 1 ) * xmdtxy rdat % r03 ( 6 , 1 ) = rdat % r03 ( 6 , 1 ) + ( rdat % fq3 ( 3 , 1 ) - rdat % fq2 ( 1 , 1 ) ) * xmdtx rdat % r03 ( 7 , 1 ) = rdat % r03 ( 7 , 1 ) + ( rdat % fq3 ( 1 , 1 ) * rdat % acy2 - rdat % fq2 ( 1 , 1 ) * 3 ) * xmdty rdat % r03 ( 8 , 1 ) = rdat % r03 ( 8 , 1 ) + ( rdat % fq3 ( 2 , 1 ) * rdat % acy2 - rdat % fq2 ( 2 , 1 ) ) * xmdt rdat % r03 ( 9 , 1 ) = rdat % r03 ( 9 , 1 ) + ( rdat % fq3 ( 3 , 1 ) - rdat % fq2 ( 1 , 1 ) ) * xmdty rdat % r03 ( 10 , 1 ) = rdat % r03 ( 10 , 1 ) + ( rdat % fq3 ( 4 , 1 ) - rdat % fq2 ( 2 , 1 ) * 3 ) * xmdt end subroutine intk_08 ! > ! >    @brief   dsps case ! > ! >    @details integration of the dsps case ! > subroutine intk_09 ( rdat , ikl ) implicit none type ( rotaxis_data_t ) :: rdat integer :: ikl real ( kind = dp ) :: xmd2 , xmd3 , xmdt , xmdtx , xmdtxy , xmdty real ( kind = dp ) :: work integer :: i ! Generate jtype= 9 integrals dimension work ( 3 ) if ( ikl == 0 ) then rdat % r00 ( 1 : 4 , 1 ) = 0.0_dp rdat % r01 (:, 1 : 4 ) = 0.0_dp rdat % r02 (:, 1 : 3 ) = 0.0_dp rdat % r03 (:, 1 ) = 0.0_dp return endif xmd2 = rdat % x43 * 0.5d+00 xmd3 = xmd2 xmdt = xmd3 * xmd2 xmdty =- xmdt * rdat % acy xmdtx =- xmdt * rdat % aqx xmdtxy = xmdt * rdat % aqxy work ( 1 ) = xmd3 work ( 2 ) = rdat % y03 * rdat % y03 work ( 3 ) =- xmd3 * rdat % y03 rdat % r00 ( 1 , 1 ) = rdat % r00 ( 1 , 1 ) + rdat % fq0 ( 1 ) * work ( 1 ) rdat % r00 ( 2 , 1 ) = rdat % r00 ( 2 , 1 ) + rdat % fq0 ( 1 ) * work ( 2 ) rdat % r00 ( 3 , 1 ) = rdat % r00 ( 3 , 1 ) + rdat % fq0 ( 2 ) * work ( 1 ) rdat % r00 ( 4 , 1 ) = rdat % r00 ( 4 , 1 ) + rdat % fq0 ( 2 ) * work ( 2 ) do i = 1 , 2 rdat % r01 ( 1 , i ) = rdat % r01 ( 1 , i ) - rdat % fq1 ( 1 , i ) * rdat % aqx * work ( 3 ) rdat % r01 ( 2 , i ) = rdat % r01 ( 2 , i ) - rdat % fq1 ( 1 , i ) * rdat % acy * work ( 3 ) rdat % r01 ( 3 , i ) = rdat % r01 ( 3 , i ) + rdat % fq1 ( 2 , i ) * work ( 3 ) enddo do i = 3 , 4 rdat % r01 ( 1 , i ) = rdat % r01 ( 1 , i ) - rdat % fq1 ( 1 , 3 ) * rdat % aqx * work ( i - 2 ) rdat % r01 ( 2 , i ) = rdat % r01 ( 2 , i ) - rdat % fq1 ( 1 , 3 ) * rdat % acy * work ( i - 2 ) rdat % r01 ( 3 , i ) = rdat % r01 ( 3 , i ) + rdat % fq1 ( 2 , 3 ) * work ( i - 2 ) enddo work ( 1 ) = xmdt work ( 2 ) = xmdt do i = 1 , 3 rdat % r02 ( 1 , i ) = rdat % r02 ( 1 , i ) + ( rdat % fq2 ( 1 , i ) * rdat % aqx2 - rdat % fq1 ( 1 , i )) * work ( i ) rdat % r02 ( 2 , i ) = rdat % r02 ( 2 , i ) + ( rdat % fq2 ( 1 , i ) * rdat % acy2 - rdat % fq1 ( 1 , i )) * work ( i ) rdat % r02 ( 3 , i ) = rdat % r02 ( 3 , i ) + ( rdat % fq2 ( 3 , i ) - rdat % fq1 ( 1 , i )) * work ( i ) rdat % r02 ( 4 , i ) = rdat % r02 ( 4 , i ) + rdat % fq2 ( 1 , i ) * rdat % aqxy * work ( i ) rdat % r02 ( 5 , i ) = rdat % r02 ( 5 , i ) - rdat % fq2 ( 2 , i ) * rdat % aqx * work ( i ) rdat % r02 ( 6 , i ) = rdat % r02 ( 6 , i ) - rdat % fq2 ( 2 , i ) * rdat % acy * work ( i ) enddo rdat % r03 ( 1 , 1 ) = rdat % r03 ( 1 , 1 ) + ( rdat % fq3 ( 1 , 1 ) * rdat % aqx2 - rdat % fq2 ( 1 , 3 ) * 3 ) * xmdtx rdat % r03 ( 2 , 1 ) = rdat % r03 ( 2 , 1 ) + ( rdat % fq3 ( 1 , 1 ) * rdat % aqx2 - rdat % fq2 ( 1 , 3 ) ) * xmdty rdat % r03 ( 3 , 1 ) = rdat % r03 ( 3 , 1 ) + ( rdat % fq3 ( 2 , 1 ) * rdat % aqx2 - rdat % fq2 ( 2 , 3 ) ) * xmdt rdat % r03 ( 4 , 1 ) = rdat % r03 ( 4 , 1 ) + ( rdat % fq3 ( 1 , 1 ) * rdat % acy2 - rdat % fq2 ( 1 , 3 ) ) * xmdtx rdat % r03 ( 5 , 1 ) = rdat % r03 ( 5 , 1 ) + rdat % fq3 ( 2 , 1 ) * xmdtxy rdat % r03 ( 6 , 1 ) = rdat % r03 ( 6 , 1 ) + ( rdat % fq3 ( 3 , 1 ) - rdat % fq2 ( 1 , 3 ) ) * xmdtx rdat % r03 ( 7 , 1 ) = rdat % r03 ( 7 , 1 ) + ( rdat % fq3 ( 1 , 1 ) * rdat % acy2 - rdat % fq2 ( 1 , 3 ) * 3 ) * xmdty rdat % r03 ( 8 , 1 ) = rdat % r03 ( 8 , 1 ) + ( rdat % fq3 ( 2 , 1 ) * rdat % acy2 - rdat % fq2 ( 2 , 3 ) ) * xmdt rdat % r03 ( 9 , 1 ) = rdat % r03 ( 9 , 1 ) + ( rdat % fq3 ( 3 , 1 ) - rdat % fq2 ( 1 , 3 ) ) * xmdty rdat % r03 ( 10 , 1 ) = rdat % r03 ( 10 , 1 ) + ( rdat % fq3 ( 4 , 1 ) - rdat % fq2 ( 2 , 3 ) * 3 ) * xmdt end subroutine intk_09 ! > ! >    @brief   ddss case ! > ! >    @details integration of the ddss case ! > subroutine intk_10 ( rdat , ikl ) implicit none type ( rotaxis_data_t ) :: rdat integer :: ikl real ( kind = dp ) :: xmd2 , xmd3 , xmd4 , xmd6 real ( kind = dp ) :: xmdt , xmdtx , xmdtxy , xmdty real ( kind = dp ) :: aqx4 , acy4 , q2c2 , x2y2 real ( kind = dp ) :: y33 , y334 , y34 , y344 , y44 real ( kind = dp ) :: work , fwk integer :: i , j ! Generate jtype=10 integrals dimension work ( 4 ), fwk ( 10 ) if ( ikl == 0 ) then rdat % r00 (:, 1 ) = 0.0_dp rdat % r01 (:, 1 : 4 ) = 0.0_dp rdat % r02 (:, 1 : 4 ) = 0.0_dp rdat % r03 (:, 1 : 2 ) = 0.0_dp rdat % r04 (:, 1 ) = 0.0_dp return endif xmd2 = rdat % x43 * 0.5d+00 xmd3 = xmd2 xmd4 = xmd3 * xmd2 xmd6 = xmd4 * xmd2 xmdt = xmd6 * xmd2 xmd2 = xmd3 xmdty =- xmdt * rdat % acy xmdtx =- xmdt * rdat % aqx xmdtxy = xmdt * rdat % aqxy y33 = rdat % y03 * rdat % y03 y34 =- rdat % y03 * rdat % y04 y44 = rdat % y04 * rdat % y04 y334 = y33 * rdat % y04 y344 = y34 * rdat % y04 work ( 1 ) =- xmd4 * rdat % y03 work ( 2 ) = xmd4 * rdat % y04 work ( 3 ) = xmd2 * y334 work ( 4 ) = xmd2 * y344 rdat % r00 ( 1 , 1 ) = rdat % r00 ( 1 , 1 ) + rdat % fq0 ( 1 ) * xmd4 rdat % r00 ( 2 , 1 ) = rdat % r00 ( 2 , 1 ) + rdat % fq0 ( 1 ) * xmd2 * y33 rdat % r00 ( 3 , 1 ) = rdat % r00 ( 3 , 1 ) + rdat % fq0 ( 1 ) * xmd2 * y34 rdat % r00 ( 4 , 1 ) = rdat % r00 ( 4 , 1 ) + rdat % fq0 ( 1 ) * xmd2 * y44 rdat % r00 ( 5 , 1 ) = rdat % r00 ( 5 , 1 ) + rdat % fq0 ( 1 ) * y33 * y44 fwk ( 1 ) =- rdat % fq1 ( 1 , 1 ) * rdat % aqx fwk ( 2 ) =- rdat % fq1 ( 1 , 1 ) * rdat % acy fwk ( 3 ) = rdat % fq1 ( 2 , 1 ) do i = 1 , 4 rdat % r01 ( 1 , i ) = rdat % r01 ( 1 , i ) + fwk ( 1 ) * work ( i ) rdat % r01 ( 2 , i ) = rdat % r01 ( 2 , i ) + fwk ( 2 ) * work ( i ) rdat % r01 ( 3 , i ) = rdat % r01 ( 3 , i ) + fwk ( 3 ) * work ( i ) enddo work ( 1 ) = xmd6 work ( 2 ) = xmd4 * y33 work ( 3 ) = xmd4 * y34 work ( 4 ) = xmd4 * y44 fwk ( 1 ) = rdat % fq2 ( 1 , 1 ) * rdat % aqx2 - rdat % fq1 ( 1 , 1 ) fwk ( 2 ) = rdat % fq2 ( 1 , 1 ) * rdat % acy2 - rdat % fq1 ( 1 , 1 ) fwk ( 3 ) = rdat % fq2 ( 3 , 1 ) - rdat % fq1 ( 1 , 1 ) fwk ( 4 ) = rdat % fq2 ( 1 , 1 ) * rdat % aqxy fwk ( 5 ) =- rdat % fq2 ( 2 , 1 ) * rdat % aqx fwk ( 6 ) =- rdat % fq2 ( 2 , 1 ) * rdat % acy do i = 1 , 4 do j = 1 , 6 rdat % r02 ( j , i ) = rdat % r02 ( j , i ) + fwk ( j ) * work ( i ) end do end do work ( 1 ) =- xmd6 * rdat % y03 work ( 2 ) = xmd6 * rdat % y04 fwk ( 1 ) =- ( rdat % fq3 ( 1 , 1 ) * rdat % aqx2 - rdat % fq2 ( 1 , 1 ) * 3 ) * rdat % aqx fwk ( 2 ) =- ( rdat % fq3 ( 1 , 1 ) * rdat % aqx2 - rdat % fq2 ( 1 , 1 ) ) * rdat % acy fwk ( 3 ) = rdat % fq3 ( 2 , 1 ) * rdat % aqx2 - rdat % fq2 ( 2 , 1 ) fwk ( 4 ) =- ( rdat % fq3 ( 1 , 1 ) * rdat % acy2 - rdat % fq2 ( 1 , 1 ) ) * rdat % aqx fwk ( 5 ) = rdat % fq3 ( 2 , 1 ) * rdat % aqxy fwk ( 6 ) =- ( rdat % fq3 ( 3 , 1 ) - rdat % fq2 ( 1 , 1 ) ) * rdat % aqx fwk ( 7 ) =- ( rdat % fq3 ( 1 , 1 ) * rdat % acy2 - rdat % fq2 ( 1 , 1 ) * 3 ) * rdat % acy fwk ( 8 ) = rdat % fq3 ( 2 , 1 ) * rdat % acy2 - rdat % fq2 ( 2 , 1 ) fwk ( 9 ) =- ( rdat % fq3 ( 3 , 1 ) - rdat % fq2 ( 1 , 1 ) ) * rdat % acy fwk ( 10 ) = rdat % fq3 ( 4 , 1 ) - rdat % fq2 ( 2 , 1 ) * 3 do i = 1 , 2 do j = 1 , 10 rdat % r03 ( j , i ) = rdat % r03 ( j , i ) + fwk ( j ) * work ( i ) end do end do aqx4 = rdat % aqx2 * rdat % aqx2 acy4 = rdat % acy2 * rdat % acy2 x2y2 = rdat % aqx2 * rdat % acy2 q2c2 = rdat % aqx2 + rdat % acy2 rdat % r04 ( 1 , 1 ) = rdat % r04 ( 1 , 1 ) + ( rdat % fq4 ( 1 , 1 ) * aqx4 - rdat % fq3 ( 1 , 1 ) * 6 * rdat % aqx2 & & + rdat % fq2 ( 1 , 1 ) * 3 ) * xmdt rdat % r04 ( 2 , 1 ) = rdat % r04 ( 2 , 1 ) + ( rdat % fq4 ( 1 , 1 ) * rdat % aqx2 - rdat % fq3 ( 1 , 1 ) * 3 ) * xmdtxy rdat % r04 ( 3 , 1 ) = rdat % r04 ( 3 , 1 ) + ( rdat % fq4 ( 2 , 1 ) * rdat % aqx2 - rdat % fq3 ( 2 , 1 ) * 3 ) * xmdtx rdat % r04 ( 4 , 1 ) = rdat % r04 ( 4 , 1 ) + ( rdat % fq4 ( 1 , 1 ) * x2y2 - rdat % fq3 ( 1 , 1 ) * q2c2 + rdat % fq2 ( 1 , 1 )) * xmdt rdat % r04 ( 5 , 1 ) = rdat % r04 ( 5 , 1 ) + ( rdat % fq4 ( 2 , 1 ) * rdat % aqx2 - rdat % fq3 ( 2 , 1 ) ) * xmdty rdat % r04 ( 6 , 1 ) = rdat % r04 ( 6 , 1 ) + ( rdat % fq4 ( 3 , 1 ) * rdat % aqx2 - rdat % fq3 ( 1 , 1 ) * rdat % aqx2 - rdat % fq3 ( 3 , 1 ) & & + rdat % fq2 ( 1 , 1 ) ) * xmdt rdat % r04 ( 7 , 1 ) = rdat % r04 ( 7 , 1 ) + ( rdat % fq4 ( 1 , 1 ) * rdat % acy2 - rdat % fq3 ( 1 , 1 ) * 3 ) * xmdtxy rdat % r04 ( 8 , 1 ) = rdat % r04 ( 8 , 1 ) + ( rdat % fq4 ( 2 , 1 ) * rdat % acy2 - rdat % fq3 ( 2 , 1 ) ) * xmdtx rdat % r04 ( 9 , 1 ) = rdat % r04 ( 9 , 1 ) + ( rdat % fq4 ( 3 , 1 ) - rdat % fq3 ( 1 , 1 ) ) * xmdtxy rdat % r04 ( 10 , 1 ) = rdat % r04 ( 10 , 1 ) + ( rdat % fq4 ( 4 , 1 ) - rdat % fq3 ( 2 , 1 ) * 3 ) * xmdtx rdat % r04 ( 11 , 1 ) = rdat % r04 ( 11 , 1 ) + ( rdat % fq4 ( 1 , 1 ) * acy4 - rdat % fq3 ( 1 , 1 ) * 6 * rdat % acy2 & & + rdat % fq2 ( 1 , 1 ) * 3 ) * xmdt rdat % r04 ( 12 , 1 ) = rdat % r04 ( 12 , 1 ) + ( rdat % fq4 ( 2 , 1 ) * rdat % acy2 - rdat % fq3 ( 2 , 1 ) * 3 ) * xmdty rdat % r04 ( 13 , 1 ) = rdat % r04 ( 13 , 1 ) + ( rdat % fq4 ( 3 , 1 ) * rdat % acy2 - rdat % fq3 ( 1 , 1 ) * rdat % acy2 - rdat % fq3 ( 3 , 1 ) & & + rdat % fq2 ( 1 , 1 ) ) * xmdt rdat % r04 ( 14 , 1 ) = rdat % r04 ( 14 , 1 ) + ( rdat % fq4 ( 4 , 1 ) - rdat % fq3 ( 2 , 1 ) * 3 ) * xmdty rdat % r04 ( 15 , 1 ) = rdat % r04 ( 15 , 1 ) + ( rdat % fq4 ( 5 , 1 ) - rdat % fq3 ( 3 , 1 ) * 6 + rdat % fq2 ( 1 , 1 ) * 3 ) * xmdt end subroutine intk_10 ! > ! >    @brief   dpps case ! > ! >    @details integration of the dpps case ! > subroutine intk_11 ( rdat , ikl ) implicit none type ( rotaxis_data_t ) :: rdat integer :: ikl real ( kind = dp ) :: xmd1 , xmd2 , xmd3 , xmd4 , xmd5 real ( kind = dp ) :: xmdt , xmdtx , xmdtxy , xmdty real ( kind = dp ) :: aqx4 , acy4 , q2c2 , x2y2 real ( kind = dp ) :: y33 , y334 , y34 real ( kind = dp ) :: work , fwk integer :: i , j ! Generate jtype=11 integrals dimension work ( 12 ), fwk ( 10 , 3 ) if ( ikl == 0 ) then rdat % r00 (:, 1 : 2 ) = 0.0_dp rdat % r01 (:, 1 : 13 ) = 0.0_dp rdat % r02 (:, 1 : 10 ) = 0.0_dp rdat % r03 (:, 1 : 5 ) = 0.0_dp rdat % r04 (:, 1 ) = 0.0_dp return endif xmd2 = rdat % x43 * 0.5d+00 xmd1 = xmd2 xmd3 = xmd2 xmd4 = xmd2 * xmd2 xmd5 = xmd4 xmdt = xmd4 * xmd3 xmdty =- xmdt * rdat % acy xmdtx =- xmdt * rdat % aqx xmdtxy = xmdt * rdat % aqxy y33 = rdat % y03 * rdat % y03 y34 =- rdat % y03 * rdat % y04 y334 = y33 * rdat % y04 work ( 1 ) = xmd1 work ( 2 ) = y33 work ( 3 ) =- xmd3 * rdat % y03 work ( 4 ) = xmd3 * rdat % y04 work ( 5 ) = y334 work ( 6 ) =- xmd1 * rdat % y03 work ( 7 ) = xmd5 work ( 8 ) = xmd3 * y33 work ( 9 ) = xmd2 * y34 work ( 10 ) = xmd4 work ( 11 ) =- xmd5 * rdat % y03 work ( 12 ) = xmd5 * rdat % y04 do i = 1 , 2 do j = 1 , 5 rdat % r00 ( j , i ) = rdat % r00 ( j , i ) + rdat % fq0 ( i ) * work ( j ) end do end do do i = 1 , 3 fwk ( 1 , i ) =- rdat % fq1 ( 1 , i ) * rdat % aqx fwk ( 2 , i ) =- rdat % fq1 ( 1 , i ) * rdat % acy fwk ( 3 , i ) = rdat % fq1 ( 2 , i ) enddo do i = 1 , 4 rdat % r01 ( 1 , i ) = rdat % r01 ( 1 , i ) + fwk ( 1 , 1 ) * work ( i + 5 ) rdat % r01 ( 2 , i ) = rdat % r01 ( 2 , i ) + fwk ( 2 , 1 ) * work ( i + 5 ) rdat % r01 ( 3 , i ) = rdat % r01 ( 3 , i ) + fwk ( 3 , 1 ) * work ( i + 5 ) enddo do i = 5 , 8 rdat % r01 ( 1 , i ) = rdat % r01 ( 1 , i ) + fwk ( 1 , 2 ) * work ( i + 1 ) rdat % r01 ( 2 , i ) = rdat % r01 ( 2 , i ) + fwk ( 2 , 2 ) * work ( i + 1 ) rdat % r01 ( 3 , i ) = rdat % r01 ( 3 , i ) + fwk ( 3 , 2 ) * work ( i + 1 ) enddo do i = 9 , 13 rdat % r01 ( 1 , i ) = rdat % r01 ( 1 , i ) + fwk ( 1 , 3 ) * work ( i - 8 ) rdat % r01 ( 2 , i ) = rdat % r01 ( 2 , i ) + fwk ( 2 , 3 ) * work ( i - 8 ) rdat % r01 ( 3 , i ) = rdat % r01 ( 3 , i ) + fwk ( 3 , 3 ) * work ( i - 8 ) enddo do i = 1 , 3 fwk ( 1 , i ) = rdat % fq2 ( 1 , i ) * rdat % aqx2 - rdat % fq1 ( 1 , i ) fwk ( 2 , i ) = rdat % fq2 ( 1 , i ) * rdat % acy2 - rdat % fq1 ( 1 , i ) fwk ( 3 , i ) = rdat % fq2 ( 3 , i ) - rdat % fq1 ( 1 , i ) fwk ( 4 , i ) = rdat % fq2 ( 1 , i ) * rdat % aqxy fwk ( 5 , i ) =- rdat % fq2 ( 2 , i ) * rdat % aqx fwk ( 6 , i ) =- rdat % fq2 ( 2 , i ) * rdat % acy enddo do i = 1 , 3 do j = 1 , 6 rdat % r02 ( j , i ) = rdat % r02 ( j , i ) + fwk ( j , 1 ) * work ( i + 9 ) enddo enddo do i = 4 , 6 do j = 1 , 6 rdat % r02 ( j , i ) = rdat % r02 ( j , i ) + fwk ( j , 2 ) * work ( i + 6 ) enddo enddo do i = 7 , 10 do j = 1 , 6 rdat % r02 ( j , i ) = rdat % r02 ( j , i ) + fwk ( j , 3 ) * work ( i - 1 ) enddo enddo do i = 1 , 2 rdat % r03 ( 1 , i ) = rdat % r03 ( 1 , i ) + ( rdat % fq3 ( 1 , i ) * rdat % aqx2 - rdat % fq2 ( 1 , i ) * 3 ) * xmdtx rdat % r03 ( 2 , i ) = rdat % r03 ( 2 , i ) + ( rdat % fq3 ( 1 , i ) * rdat % aqx2 - rdat % fq2 ( 1 , i ) ) * xmdty rdat % r03 ( 3 , i ) = rdat % r03 ( 3 , i ) + ( rdat % fq3 ( 2 , i ) * rdat % aqx2 - rdat % fq2 ( 2 , i ) ) * xmdt rdat % r03 ( 4 , i ) = rdat % r03 ( 4 , i ) + ( rdat % fq3 ( 1 , i ) * rdat % acy2 - rdat % fq2 ( 1 , i ) ) * xmdtx rdat % r03 ( 5 , i ) = rdat % r03 ( 5 , i ) + rdat % fq3 ( 2 , i ) * xmdtxy rdat % r03 ( 6 , i ) = rdat % r03 ( 6 , i ) + ( rdat % fq3 ( 3 , i ) - rdat % fq2 ( 1 , i ) ) * xmdtx rdat % r03 ( 7 , i ) = rdat % r03 ( 7 , i ) + ( rdat % fq3 ( 1 , i ) * rdat % acy2 - rdat % fq2 ( 1 , i ) * 3 ) * xmdty rdat % r03 ( 8 , i ) = rdat % r03 ( 8 , i ) + ( rdat % fq3 ( 2 , i ) * rdat % acy2 - rdat % fq2 ( 2 , i ) ) * xmdt rdat % r03 ( 9 , i ) = rdat % r03 ( 9 , i ) + ( rdat % fq3 ( 3 , i ) - rdat % fq2 ( 1 , i ) ) * xmdty rdat % r03 ( 10 , i ) = rdat % r03 ( 10 , i ) + ( rdat % fq3 ( 4 , i ) - rdat % fq2 ( 2 , i ) * 3 ) * xmdt enddo fwk ( 1 , 3 ) =- ( rdat % fq3 ( 1 , 3 ) * rdat % aqx2 - rdat % fq2 ( 1 , 3 ) * 3 ) * rdat % aqx fwk ( 2 , 3 ) =- ( rdat % fq3 ( 1 , 3 ) * rdat % aqx2 - rdat % fq2 ( 1 , 3 ) ) * rdat % acy fwk ( 3 , 3 ) = rdat % fq3 ( 2 , 3 ) * rdat % aqx2 - rdat % fq2 ( 2 , 3 ) fwk ( 4 , 3 ) =- ( rdat % fq3 ( 1 , 3 ) * rdat % acy2 - rdat % fq2 ( 1 , 3 ) ) * rdat % aqx fwk ( 5 , 3 ) = rdat % fq3 ( 2 , 3 ) * rdat % aqxy fwk ( 6 , 3 ) =- ( rdat % fq3 ( 3 , 3 ) - rdat % fq2 ( 1 , 3 ) ) * rdat % aqx fwk ( 7 , 3 ) =- ( rdat % fq3 ( 1 , 3 ) * rdat % acy2 - rdat % fq2 ( 1 , 3 ) * 3 ) * rdat % acy fwk ( 8 , 3 ) = rdat % fq3 ( 2 , 3 ) * rdat % acy2 - rdat % fq2 ( 2 , 3 ) fwk ( 9 , 3 ) =- ( rdat % fq3 ( 3 , 3 ) - rdat % fq2 ( 1 , 3 ) ) * rdat % acy fwk ( 10 , 3 ) = rdat % fq3 ( 4 , 3 ) - rdat % fq2 ( 2 , 3 ) * 3 do i = 3 , 5 do j = 1 , 10 rdat % r03 ( j , i ) = rdat % r03 ( j , i ) + fwk ( j , 3 ) * work ( i + 7 ) end do end do aqx4 = rdat % aqx2 * rdat % aqx2 acy4 = rdat % acy2 * rdat % acy2 x2y2 = rdat % aqx2 * rdat % acy2 q2c2 = rdat % aqx2 + rdat % acy2 rdat % r04 ( 1 , 1 ) = rdat % r04 ( 1 , 1 ) + ( rdat % fq4 ( 1 , 1 ) * aqx4 - rdat % fq3 ( 1 , 3 ) * 6 * rdat % aqx2 & & + rdat % fq2 ( 1 , 3 ) * 3 ) * xmdt rdat % r04 ( 2 , 1 ) = rdat % r04 ( 2 , 1 ) + ( rdat % fq4 ( 1 , 1 ) * rdat % aqx2 - rdat % fq3 ( 1 , 3 ) * 3 ) * xmdtxy rdat % r04 ( 3 , 1 ) = rdat % r04 ( 3 , 1 ) + ( rdat % fq4 ( 2 , 1 ) * rdat % aqx2 - rdat % fq3 ( 2 , 3 ) * 3 ) * xmdtx rdat % r04 ( 4 , 1 ) = rdat % r04 ( 4 , 1 ) + ( rdat % fq4 ( 1 , 1 ) * x2y2 - rdat % fq3 ( 1 , 3 ) * q2c2 + rdat % fq2 ( 1 , 3 )) * xmdt rdat % r04 ( 5 , 1 ) = rdat % r04 ( 5 , 1 ) + ( rdat % fq4 ( 2 , 1 ) * rdat % aqx2 - rdat % fq3 ( 2 , 3 ) ) * xmdty rdat % r04 ( 6 , 1 ) = rdat % r04 ( 6 , 1 ) + ( rdat % fq4 ( 3 , 1 ) * rdat % aqx2 - rdat % fq3 ( 1 , 3 ) * rdat % aqx2 - rdat % fq3 ( 3 , 3 ) & & + rdat % fq2 ( 1 , 3 ) ) * xmdt rdat % r04 ( 7 , 1 ) = rdat % r04 ( 7 , 1 ) + ( rdat % fq4 ( 1 , 1 ) * rdat % acy2 - rdat % fq3 ( 1 , 3 ) * 3 ) * xmdtxy rdat % r04 ( 8 , 1 ) = rdat % r04 ( 8 , 1 ) + ( rdat % fq4 ( 2 , 1 ) * rdat % acy2 - rdat % fq3 ( 2 , 3 ) ) * xmdtx rdat % r04 ( 9 , 1 ) = rdat % r04 ( 9 , 1 ) + ( rdat % fq4 ( 3 , 1 ) - rdat % fq3 ( 1 , 3 ) ) * xmdtxy rdat % r04 ( 10 , 1 ) = rdat % r04 ( 10 , 1 ) + ( rdat % fq4 ( 4 , 1 ) - rdat % fq3 ( 2 , 3 ) * 3 ) * xmdtx rdat % r04 ( 11 , 1 ) = rdat % r04 ( 11 , 1 ) + ( rdat % fq4 ( 1 , 1 ) * acy4 - rdat % fq3 ( 1 , 3 ) * 6 * rdat % acy2 & & + rdat % fq2 ( 1 , 3 ) * 3 ) * xmdt rdat % r04 ( 12 , 1 ) = rdat % r04 ( 12 , 1 ) + ( rdat % fq4 ( 2 , 1 ) * rdat % acy2 - rdat % fq3 ( 2 , 3 ) * 3 ) * xmdty rdat % r04 ( 13 , 1 ) = rdat % r04 ( 13 , 1 ) + ( rdat % fq4 ( 3 , 1 ) * rdat % acy2 - rdat % fq3 ( 1 , 3 ) * rdat % acy2 - rdat % fq3 ( 3 , 3 ) & & + rdat % fq2 ( 1 , 3 ) ) * xmdt rdat % r04 ( 14 , 1 ) = rdat % r04 ( 14 , 1 ) + ( rdat % fq4 ( 4 , 1 ) - rdat % fq3 ( 2 , 3 ) * 3 ) * xmdty rdat % r04 ( 15 , 1 ) = rdat % r04 ( 15 , 1 ) + ( rdat % fq4 ( 5 , 1 ) - rdat % fq3 ( 3 , 3 ) * 6 + rdat % fq2 ( 1 , 3 ) * 3 ) * xmdt end subroutine intk_11 ! > ! >    @brief   dsds case ! > ! >    @details integration of the dsds case ! > subroutine intk_12 ( rdat , ikl ) implicit none type ( rotaxis_data_t ) :: rdat integer :: ikl real ( kind = dp ) :: xmd1 , xmd2 , xmd3 real ( kind = dp ) :: xmd3y , xmd3x , xmd3xy real ( kind = dp ) :: xmdt , xmdtx , xmdtxy , xmdty real ( kind = dp ) :: aqx4 , acy4 , q2c2 , x2y2 real ( kind = dp ) :: work , fwk integer :: i , j ! Generate jtype=12 integrals dimension work ( 5 ), fwk ( 10 ) if ( ikl == 0 ) then rdat % r00 ( 1 : 4 , 1 ) = 0.0_dp rdat % r01 (:, 1 : 4 ) = 0.0_dp rdat % r02 (:, 1 : 5 ) = 0.0_dp rdat % r03 (:, 1 : 2 ) = 0.0_dp rdat % r04 (:, 1 ) = 0.0_dp return endif xmd2 = rdat % x43 * 0.5d+00 xmd1 = xmd2 xmd3 =- xmd1 * rdat % y03 xmdt = xmd1 * xmd2 xmd3y =- xmd3 * rdat % acy xmd3x =- xmd3 * rdat % aqx xmd3xy = xmd3 * rdat % aqxy xmdty =- xmdt * rdat % acy xmdtx =- xmdt * rdat % aqx xmdtxy = xmdt * rdat % aqxy work ( 1 ) = xmd1 work ( 2 ) = rdat % y03 * rdat % y03 work ( 3 ) = xmdt work ( 4 ) = xmdt work ( 5 ) = xmd3 rdat % r00 ( 1 , 1 ) = rdat % r00 ( 1 , 1 ) + rdat % fq0 ( 1 ) * work ( 1 ) rdat % r00 ( 2 , 1 ) = rdat % r00 ( 2 , 1 ) + rdat % fq0 ( 1 ) * work ( 2 ) rdat % r00 ( 3 , 1 ) = rdat % r00 ( 3 , 1 ) + rdat % fq0 ( 2 ) * work ( 1 ) rdat % r00 ( 4 , 1 ) = rdat % r00 ( 4 , 1 ) + rdat % fq0 ( 2 ) * work ( 2 ) do i = 1 , 2 rdat % r01 ( 1 , i ) = rdat % r01 ( 1 , i ) + rdat % fq1 ( 1 , i ) * xmd3x rdat % r01 ( 2 , i ) = rdat % r01 ( 2 , i ) + rdat % fq1 ( 1 , i ) * xmd3y rdat % r01 ( 3 , i ) = rdat % r01 ( 3 , i ) + rdat % fq1 ( 2 , i ) * xmd3 enddo fwk ( 1 ) =- rdat % fq1 ( 1 , 3 ) * rdat % aqx fwk ( 2 ) =- rdat % fq1 ( 1 , 3 ) * rdat % acy fwk ( 3 ) = rdat % fq1 ( 2 , 3 ) do i = 3 , 4 rdat % r01 ( 1 , i ) = rdat % r01 ( 1 , i ) + fwk ( 1 ) * work ( i - 2 ) rdat % r01 ( 2 , i ) = rdat % r01 ( 2 , i ) + fwk ( 2 ) * work ( i - 2 ) rdat % r01 ( 3 , i ) = rdat % r01 ( 3 , i ) + fwk ( 3 ) * work ( i - 2 ) enddo do i = 1 , 3 rdat % r02 ( 1 , i ) = rdat % r02 ( 1 , i ) + ( rdat % fq2 ( 1 , i ) * rdat % aqx2 - rdat % fq1 ( 1 , i )) * work ( i + 2 ) rdat % r02 ( 2 , i ) = rdat % r02 ( 2 , i ) + ( rdat % fq2 ( 1 , i ) * rdat % acy2 - rdat % fq1 ( 1 , i )) * work ( i + 2 ) rdat % r02 ( 3 , i ) = rdat % r02 ( 3 , i ) + ( rdat % fq2 ( 3 , i ) - rdat % fq1 ( 1 , i )) * work ( i + 2 ) rdat % r02 ( 4 , i ) = rdat % r02 ( 4 , i ) + rdat % fq2 ( 1 , i ) * rdat % aqxy * work ( i + 2 ) rdat % r02 ( 5 , i ) = rdat % r02 ( 5 , i ) - rdat % fq2 ( 2 , i ) * rdat % aqx * work ( i + 2 ) rdat % r02 ( 6 , i ) = rdat % r02 ( 6 , i ) - rdat % fq2 ( 2 , i ) * rdat % acy * work ( i + 2 ) enddo fwk ( 1 ) = rdat % fq2 ( 1 , 4 ) * rdat % aqx2 - rdat % fq1 ( 1 , 4 ) fwk ( 2 ) = rdat % fq2 ( 1 , 4 ) * rdat % acy2 - rdat % fq1 ( 1 , 4 ) fwk ( 3 ) = rdat % fq2 ( 3 , 4 ) - rdat % fq1 ( 1 , 4 ) fwk ( 4 ) = rdat % fq2 ( 1 , 4 ) * rdat % aqxy fwk ( 5 ) =- rdat % fq2 ( 2 , 4 ) * rdat % aqx fwk ( 6 ) =- rdat % fq2 ( 2 , 4 ) * rdat % acy do i = 4 , 5 do j = 1 , 6 rdat % r02 ( j , i ) = rdat % r02 ( j , i ) + fwk ( j ) * work ( i - 3 ) end do end do rdat % r03 ( 1 , 1 ) = rdat % r03 ( 1 , 1 ) + ( rdat % fq3 ( 1 , 1 ) * rdat % aqx2 - rdat % fq2 ( 1 , 3 ) * 3 ) * xmdtx rdat % r03 ( 2 , 1 ) = rdat % r03 ( 2 , 1 ) + ( rdat % fq3 ( 1 , 1 ) * rdat % aqx2 - rdat % fq2 ( 1 , 3 ) ) * xmdty rdat % r03 ( 3 , 1 ) = rdat % r03 ( 3 , 1 ) + ( rdat % fq3 ( 2 , 1 ) * rdat % aqx2 - rdat % fq2 ( 2 , 3 ) ) * xmdt rdat % r03 ( 4 , 1 ) = rdat % r03 ( 4 , 1 ) + ( rdat % fq3 ( 1 , 1 ) * rdat % acy2 - rdat % fq2 ( 1 , 3 ) ) * xmdtx rdat % r03 ( 5 , 1 ) = rdat % r03 ( 5 , 1 ) + rdat % fq3 ( 2 , 1 ) * xmdtxy rdat % r03 ( 6 , 1 ) = rdat % r03 ( 6 , 1 ) + ( rdat % fq3 ( 3 , 1 ) - rdat % fq2 ( 1 , 3 ) ) * xmdtx rdat % r03 ( 7 , 1 ) = rdat % r03 ( 7 , 1 ) + ( rdat % fq3 ( 1 , 1 ) * rdat % acy2 - rdat % fq2 ( 1 , 3 ) * 3 ) * xmdty rdat % r03 ( 8 , 1 ) = rdat % r03 ( 8 , 1 ) + ( rdat % fq3 ( 2 , 1 ) * rdat % acy2 - rdat % fq2 ( 2 , 3 ) ) * xmdt rdat % r03 ( 9 , 1 ) = rdat % r03 ( 9 , 1 ) + ( rdat % fq3 ( 3 , 1 ) - rdat % fq2 ( 1 , 3 ) ) * xmdty rdat % r03 ( 10 , 1 ) = rdat % r03 ( 10 , 1 ) + ( rdat % fq3 ( 4 , 1 ) - rdat % fq2 ( 2 , 3 ) * 3 ) * xmdt rdat % r03 ( 1 , 2 ) = rdat % r03 ( 1 , 2 ) + ( rdat % fq3 ( 1 , 2 ) * rdat % aqx2 - rdat % fq2 ( 1 , 4 ) * 3 ) * xmd3x rdat % r03 ( 2 , 2 ) = rdat % r03 ( 2 , 2 ) + ( rdat % fq3 ( 1 , 2 ) * rdat % aqx2 - rdat % fq2 ( 1 , 4 ) ) * xmd3y rdat % r03 ( 3 , 2 ) = rdat % r03 ( 3 , 2 ) + ( rdat % fq3 ( 2 , 2 ) * rdat % aqx2 - rdat % fq2 ( 2 , 4 ) ) * xmd3 rdat % r03 ( 4 , 2 ) = rdat % r03 ( 4 , 2 ) + ( rdat % fq3 ( 1 , 2 ) * rdat % acy2 - rdat % fq2 ( 1 , 4 ) ) * xmd3x rdat % r03 ( 5 , 2 ) = rdat % r03 ( 5 , 2 ) + rdat % fq3 ( 2 , 2 ) * xmd3xy rdat % r03 ( 6 , 2 ) = rdat % r03 ( 6 , 2 ) + ( rdat % fq3 ( 3 , 2 ) - rdat % fq2 ( 1 , 4 ) ) * xmd3x rdat % r03 ( 7 , 2 ) = rdat % r03 ( 7 , 2 ) + ( rdat % fq3 ( 1 , 2 ) * rdat % acy2 - rdat % fq2 ( 1 , 4 ) * 3 ) * xmd3y rdat % r03 ( 8 , 2 ) = rdat % r03 ( 8 , 2 ) + ( rdat % fq3 ( 2 , 2 ) * rdat % acy2 - rdat % fq2 ( 2 , 4 ) ) * xmd3 rdat % r03 ( 9 , 2 ) = rdat % r03 ( 9 , 2 ) + ( rdat % fq3 ( 3 , 2 ) - rdat % fq2 ( 1 , 4 ) ) * xmd3y rdat % r03 ( 10 , 2 ) = rdat % r03 ( 10 , 2 ) + ( rdat % fq3 ( 4 , 2 ) - rdat % fq2 ( 2 , 4 ) * 3 ) * xmd3 aqx4 = rdat % aqx2 * rdat % aqx2 acy4 = rdat % acy2 * rdat % acy2 x2y2 = rdat % aqx2 * rdat % acy2 q2c2 = rdat % aqx2 + rdat % acy2 rdat % r04 ( 1 , 1 ) = rdat % r04 ( 1 , 1 ) + ( rdat % fq4 ( 1 , 1 ) * aqx4 - rdat % fq3 ( 1 , 2 ) * 6 * rdat % aqx2 & & + rdat % fq2 ( 1 , 4 ) * 3 ) * xmdt rdat % r04 ( 2 , 1 ) = rdat % r04 ( 2 , 1 ) + ( rdat % fq4 ( 1 , 1 ) * rdat % aqx2 - rdat % fq3 ( 1 , 2 ) * 3 ) * xmdtxy rdat % r04 ( 3 , 1 ) = rdat % r04 ( 3 , 1 ) + ( rdat % fq4 ( 2 , 1 ) * rdat % aqx2 - rdat % fq3 ( 2 , 2 ) * 3 ) * xmdtx rdat % r04 ( 4 , 1 ) = rdat % r04 ( 4 , 1 ) + ( rdat % fq4 ( 1 , 1 ) * x2y2 - rdat % fq3 ( 1 , 2 ) * q2c2 + rdat % fq2 ( 1 , 4 )) * xmdt rdat % r04 ( 5 , 1 ) = rdat % r04 ( 5 , 1 ) + ( rdat % fq4 ( 2 , 1 ) * rdat % aqx2 - rdat % fq3 ( 2 , 2 ) ) * xmdty rdat % r04 ( 6 , 1 ) = rdat % r04 ( 6 , 1 ) + ( rdat % fq4 ( 3 , 1 ) * rdat % aqx2 - rdat % fq3 ( 1 , 2 ) * rdat % aqx2 - rdat % fq3 ( 3 , 2 ) & & + rdat % fq2 ( 1 , 4 ) ) * xmdt rdat % r04 ( 7 , 1 ) = rdat % r04 ( 7 , 1 ) + ( rdat % fq4 ( 1 , 1 ) * rdat % acy2 - rdat % fq3 ( 1 , 2 ) * 3 ) * xmdtxy rdat % r04 ( 8 , 1 ) = rdat % r04 ( 8 , 1 ) + ( rdat % fq4 ( 2 , 1 ) * rdat % acy2 - rdat % fq3 ( 2 , 2 ) ) * xmdtx rdat % r04 ( 9 , 1 ) = rdat % r04 ( 9 , 1 ) + ( rdat % fq4 ( 3 , 1 ) - rdat % fq3 ( 1 , 2 ) ) * xmdtxy rdat % r04 ( 10 , 1 ) = rdat % r04 ( 10 , 1 ) + ( rdat % fq4 ( 4 , 1 ) - rdat % fq3 ( 2 , 2 ) * 3 ) * xmdtx rdat % r04 ( 11 , 1 ) = rdat % r04 ( 11 , 1 ) + ( rdat % fq4 ( 1 , 1 ) * acy4 - rdat % fq3 ( 1 , 2 ) * 6 * rdat % acy2 & & + rdat % fq2 ( 1 , 4 ) * 3 ) * xmdt rdat % r04 ( 12 , 1 ) = rdat % r04 ( 12 , 1 ) + ( rdat % fq4 ( 2 , 1 ) * rdat % acy2 - rdat % fq3 ( 2 , 2 ) * 3 ) * xmdty rdat % r04 ( 13 , 1 ) = rdat % r04 ( 13 , 1 ) + ( rdat % fq4 ( 3 , 1 ) * rdat % acy2 - rdat % fq3 ( 1 , 2 ) * rdat % acy2 - rdat % fq3 ( 3 , 2 ) & & + rdat % fq2 ( 1 , 4 ) ) * xmdt rdat % r04 ( 14 , 1 ) = rdat % r04 ( 14 , 1 ) + ( rdat % fq4 ( 4 , 1 ) - rdat % fq3 ( 2 , 2 ) * 3 ) * xmdty rdat % r04 ( 15 , 1 ) = rdat % r04 ( 15 , 1 ) + ( rdat % fq4 ( 5 , 1 ) - rdat % fq3 ( 3 , 2 ) * 6 + rdat % fq2 ( 1 , 4 ) * 3 ) * xmdt end subroutine intk_12 ! > ! >    @brief   dspp case ! > ! >    @details integration of the dspp case ! > subroutine intk_13 ( rdat , ikl ) implicit none type ( rotaxis_data_t ) :: rdat integer :: ikl real ( kind = dp ) :: xmd1 , xmd2 , xmd3 real ( kind = dp ) :: xmd3y , xmd3x , xmd3xy real ( kind = dp ) :: xmdt , xmdtx , xmdtxy , xmdty real ( kind = dp ) :: aqx4 , acy4 , q2c2 , x2y2 real ( kind = dp ) :: fqd11 , fqd12 real ( kind = dp ) :: work , fwk integer :: i , j ! Generate jtype=13 integrals dimension work ( 2 ), fwk ( 6 , 4 ) if ( ikl == 0 ) then rdat % r00 (:, 1 : 2 ) = 0.0_dp rdat % r01 (:, 1 : 13 ) = 0.0_dp rdat % r02 (:, 1 : 11 ) = 0.0_dp rdat % r03 (:, 1 : 5 ) = 0.0_dp rdat % r04 (:, 1 ) = 0.0_dp return endif xmd2 = rdat % x43 * 0.5d+00 xmd1 = xmd2 xmd3 =- xmd1 * rdat % y03 xmdt = xmd1 * xmd2 xmd3y =- xmd3 * rdat % acy xmd3x =- xmd3 * rdat % aqx xmd3xy = xmd3 * rdat % aqxy xmdty =- xmdt * rdat % acy xmdtx =- xmdt * rdat % aqx xmdtxy = xmdt * rdat % aqxy work ( 1 ) = xmd1 work ( 2 ) = rdat % y03 * rdat % y03 do i = 1 , 2 do j = 1 , 5 rdat % r00 ( j , i ) = rdat % r00 ( j , i ) + rdat % fq0 ( j ) * work ( i ) end do end do do i = 1 , 5 rdat % r01 ( 1 , i ) = rdat % r01 ( 1 , i ) + rdat % fq1 ( 1 , i ) * xmd3x rdat % r01 ( 2 , i ) = rdat % r01 ( 2 , i ) + rdat % fq1 ( 1 , i ) * xmd3y rdat % r01 ( 3 , i ) = rdat % r01 ( 3 , i ) + rdat % fq1 ( 2 , i ) * xmd3 enddo do i = 1 , 3 fwk ( 1 , i ) =- rdat % fq1 ( 1 , i + 5 ) * rdat % aqx fwk ( 2 , i ) =- rdat % fq1 ( 1 , i + 5 ) * rdat % acy fwk ( 3 , i ) = rdat % fq1 ( 2 , i + 5 ) enddo fqd11 = rdat % fq1 ( 1 , 5 ) * rdat % rab + rdat % fq1 ( 1 , 8 ) fqd12 = rdat % fq1 ( 2 , 5 ) * rdat % rab + rdat % fq1 ( 2 , 8 ) fwk ( 1 , 4 ) =- fqd11 * rdat % aqx fwk ( 2 , 4 ) =- fqd11 * rdat % acy fwk ( 3 , 4 ) = fqd12 do i = 6 , 7 rdat % r01 ( 1 , i ) = rdat % r01 ( 1 , i ) + fwk ( 1 , 1 ) * work ( i - 5 ) rdat % r01 ( 2 , i ) = rdat % r01 ( 2 , i ) + fwk ( 2 , 1 ) * work ( i - 5 ) rdat % r01 ( 3 , i ) = rdat % r01 ( 3 , i ) + fwk ( 3 , 1 ) * work ( i - 5 ) enddo do i = 8 , 9 rdat % r01 ( 1 , i ) = rdat % r01 ( 1 , i ) + fwk ( 1 , 2 ) * work ( i - 7 ) rdat % r01 ( 2 , i ) = rdat % r01 ( 2 , i ) + fwk ( 2 , 2 ) * work ( i - 7 ) rdat % r01 ( 3 , i ) = rdat % r01 ( 3 , i ) + fwk ( 3 , 2 ) * work ( i - 7 ) enddo do i = 10 , 11 rdat % r01 ( 1 , i ) = rdat % r01 ( 1 , i ) + fwk ( 1 , 3 ) * work ( i - 9 ) rdat % r01 ( 2 , i ) = rdat % r01 ( 2 , i ) + fwk ( 2 , 3 ) * work ( i - 9 ) rdat % r01 ( 3 , i ) = rdat % r01 ( 3 , i ) + fwk ( 3 , 3 ) * work ( i - 9 ) enddo do i = 12 , 13 rdat % r01 ( 1 , i ) = rdat % r01 ( 1 , i ) + fwk ( 1 , 4 ) * work ( i - 11 ) rdat % r01 ( 2 , i ) = rdat % r01 ( 2 , i ) + fwk ( 2 , 4 ) * work ( i - 11 ) rdat % r01 ( 3 , i ) = rdat % r01 ( 3 , i ) + fwk ( 3 , 4 ) * work ( i - 11 ) enddo do i = 1 , 5 rdat % r02 ( 1 , i ) = rdat % r02 ( 1 , i ) + ( rdat % fq2 ( 1 , i ) * rdat % aqx2 - rdat % fq1 ( 1 , i )) * xmdt rdat % r02 ( 2 , i ) = rdat % r02 ( 2 , i ) + ( rdat % fq2 ( 1 , i ) * rdat % acy2 - rdat % fq1 ( 1 , i )) * xmdt rdat % r02 ( 3 , i ) = rdat % r02 ( 3 , i ) + ( rdat % fq2 ( 3 , i ) - rdat % fq1 ( 1 , i )) * xmdt rdat % r02 ( 4 , i ) = rdat % r02 ( 4 , i ) + rdat % fq2 ( 1 , i ) * xmdtxy rdat % r02 ( 5 , i ) = rdat % r02 ( 5 , i ) + rdat % fq2 ( 2 , i ) * xmdtx rdat % r02 ( 6 , i ) = rdat % r02 ( 6 , i ) + rdat % fq2 ( 2 , i ) * xmdty enddo do i = 6 , 8 rdat % r02 ( 1 , i ) = rdat % r02 ( 1 , i ) + ( rdat % fq2 ( 1 , i ) * rdat % aqx2 - rdat % fq1 ( 1 , i )) * xmd3 rdat % r02 ( 2 , i ) = rdat % r02 ( 2 , i ) + ( rdat % fq2 ( 1 , i ) * rdat % acy2 - rdat % fq1 ( 1 , i )) * xmd3 rdat % r02 ( 3 , i ) = rdat % r02 ( 3 , i ) + ( rdat % fq2 ( 3 , i ) - rdat % fq1 ( 1 , i )) * xmd3 rdat % r02 ( 4 , i ) = rdat % r02 ( 4 , i ) + rdat % fq2 ( 1 , i ) * xmd3xy rdat % r02 ( 5 , i ) = rdat % r02 ( 5 , i ) + rdat % fq2 ( 2 , i ) * xmd3x rdat % r02 ( 6 , i ) = rdat % r02 ( 6 , i ) + rdat % fq2 ( 2 , i ) * xmd3y enddo rdat % fq2 ( 1 , 5 ) = rdat % fq2 ( 1 , 5 ) * rdat % rab + rdat % fq2 ( 1 , 8 ) rdat % fq2 ( 2 , 5 ) = rdat % fq2 ( 2 , 5 ) * rdat % rab + rdat % fq2 ( 2 , 8 ) rdat % fq2 ( 3 , 5 ) = rdat % fq2 ( 3 , 5 ) * rdat % rab + rdat % fq2 ( 3 , 8 ) rdat % r02 ( 1 , 9 ) = rdat % r02 ( 1 , 9 ) + ( rdat % fq2 ( 1 , 5 ) * rdat % aqx2 - fqd11 ) * xmd3 rdat % r02 ( 2 , 9 ) = rdat % r02 ( 2 , 9 ) + ( rdat % fq2 ( 1 , 5 ) * rdat % acy2 - fqd11 ) * xmd3 rdat % r02 ( 3 , 9 ) = rdat % r02 ( 3 , 9 ) + ( rdat % fq2 ( 3 , 5 ) - fqd11 ) * xmd3 rdat % r02 ( 4 , 9 ) = rdat % r02 ( 4 , 9 ) + rdat % fq2 ( 1 , 5 ) * xmd3xy rdat % r02 ( 5 , 9 ) = rdat % r02 ( 5 , 9 ) + rdat % fq2 ( 2 , 5 ) * xmd3x rdat % r02 ( 6 , 9 ) = rdat % r02 ( 6 , 9 ) + rdat % fq2 ( 2 , 5 ) * xmd3y fwk ( 1 , 1 ) = rdat % fq2 ( 1 , 9 ) * rdat % aqx2 - rdat % fq1 ( 1 , 9 ) fwk ( 2 , 1 ) = rdat % fq2 ( 1 , 9 ) * rdat % acy2 - rdat % fq1 ( 1 , 9 ) fwk ( 3 , 1 ) = rdat % fq2 ( 3 , 9 ) - rdat % fq1 ( 1 , 9 ) fwk ( 4 , 1 ) = rdat % fq2 ( 1 , 9 ) * rdat % aqxy fwk ( 5 , 1 ) =- rdat % fq2 ( 2 , 9 ) * rdat % aqx fwk ( 6 , 1 ) =- rdat % fq2 ( 2 , 9 ) * rdat % acy do i = 10 , 11 do j = 1 , 6 rdat % r02 ( j , i ) = rdat % r02 ( j , i ) + fwk ( j , 1 ) * work ( i - 9 ) end do end do rdat % fq3 ( 1 , 1 ) = rdat % fq3 ( 1 , 1 ) * rdat % rab + rdat % fq3 ( 1 , 4 ) rdat % fq3 ( 2 , 1 ) = rdat % fq3 ( 2 , 1 ) * rdat % rab + rdat % fq3 ( 2 , 4 ) rdat % fq3 ( 3 , 1 ) = rdat % fq3 ( 3 , 1 ) * rdat % rab + rdat % fq3 ( 3 , 4 ) rdat % fq3 ( 4 , 1 ) = rdat % fq3 ( 4 , 1 ) * rdat % rab + rdat % fq3 ( 4 , 4 ) do i = 1 , 4 rdat % r03 ( 1 , i ) = rdat % r03 ( 1 , i ) + ( rdat % fq3 ( 1 , i ) * rdat % aqx2 - rdat % fq2 ( 1 , i + 4 ) * 3 ) * xmdtx rdat % r03 ( 2 , i ) = rdat % r03 ( 2 , i ) + ( rdat % fq3 ( 1 , i ) * rdat % aqx2 - rdat % fq2 ( 1 , i + 4 ) ) * xmdty rdat % r03 ( 3 , i ) = rdat % r03 ( 3 , i ) + ( rdat % fq3 ( 2 , i ) * rdat % aqx2 - rdat % fq2 ( 2 , i + 4 ) ) * xmdt rdat % r03 ( 4 , i ) = rdat % r03 ( 4 , i ) + ( rdat % fq3 ( 1 , i ) * rdat % acy2 - rdat % fq2 ( 1 , i + 4 ) ) * xmdtx rdat % r03 ( 5 , i ) = rdat % r03 ( 5 , i ) + rdat % fq3 ( 2 , i ) * xmdtxy rdat % r03 ( 6 , i ) = rdat % r03 ( 6 , i ) + ( rdat % fq3 ( 3 , i ) - rdat % fq2 ( 1 , i + 4 ) ) * xmdtx rdat % r03 ( 7 , i ) = rdat % r03 ( 7 , i ) + ( rdat % fq3 ( 1 , i ) * rdat % acy2 - rdat % fq2 ( 1 , i + 4 ) * 3 ) * xmdty rdat % r03 ( 8 , i ) = rdat % r03 ( 8 , i ) + ( rdat % fq3 ( 2 , i ) * rdat % acy2 - rdat % fq2 ( 2 , i + 4 ) ) * xmdt rdat % r03 ( 9 , i ) = rdat % r03 ( 9 , i ) + ( rdat % fq3 ( 3 , i ) - rdat % fq2 ( 1 , i + 4 ) ) * xmdty rdat % r03 ( 10 , i ) = rdat % r03 ( 10 , i ) + ( rdat % fq3 ( 4 , i ) - rdat % fq2 ( 2 , i + 4 ) * 3 ) * xmdt enddo rdat % r03 ( 1 , 5 ) = rdat % r03 ( 1 , 5 ) + ( rdat % fq3 ( 1 , 5 ) * rdat % aqx2 - rdat % fq2 ( 1 , 9 ) * 3 ) * xmd3x rdat % r03 ( 2 , 5 ) = rdat % r03 ( 2 , 5 ) + ( rdat % fq3 ( 1 , 5 ) * rdat % aqx2 - rdat % fq2 ( 1 , 9 ) ) * xmd3y rdat % r03 ( 3 , 5 ) = rdat % r03 ( 3 , 5 ) + ( rdat % fq3 ( 2 , 5 ) * rdat % aqx2 - rdat % fq2 ( 2 , 9 ) ) * xmd3 rdat % r03 ( 4 , 5 ) = rdat % r03 ( 4 , 5 ) + ( rdat % fq3 ( 1 , 5 ) * rdat % acy2 - rdat % fq2 ( 1 , 9 ) ) * xmd3x rdat % r03 ( 5 , 5 ) = rdat % r03 ( 5 , 5 ) + rdat % fq3 ( 2 , 5 ) * xmd3xy rdat % r03 ( 6 , 5 ) = rdat % r03 ( 6 , 5 ) + ( rdat % fq3 ( 3 , 5 ) - rdat % fq2 ( 1 , 9 ) ) * xmd3x rdat % r03 ( 7 , 5 ) = rdat % r03 ( 7 , 5 ) + ( rdat % fq3 ( 1 , 5 ) * rdat % acy2 - rdat % fq2 ( 1 , 9 ) * 3 ) * xmd3y rdat % r03 ( 8 , 5 ) = rdat % r03 ( 8 , 5 ) + ( rdat % fq3 ( 2 , 5 ) * rdat % acy2 - rdat % fq2 ( 2 , 9 ) ) * xmd3 rdat % r03 ( 9 , 5 ) = rdat % r03 ( 9 , 5 ) + ( rdat % fq3 ( 3 , 5 ) - rdat % fq2 ( 1 , 9 ) ) * xmd3y rdat % r03 ( 10 , 5 ) = rdat % r03 ( 10 , 5 ) + ( rdat % fq3 ( 4 , 5 ) - rdat % fq2 ( 2 , 9 ) * 3 ) * xmd3 aqx4 = rdat % aqx2 * rdat % aqx2 acy4 = rdat % acy2 * rdat % acy2 x2y2 = rdat % aqx2 * rdat % acy2 q2c2 = rdat % aqx2 + rdat % acy2 rdat % r04 ( 1 , 1 ) = rdat % r04 ( 1 , 1 ) + ( rdat % fq4 ( 1 , 1 ) * aqx4 - rdat % fq3 ( 1 , 5 ) * 6 * rdat % aqx2 & & + rdat % fq2 ( 1 , 9 ) * 3 ) * xmdt rdat % r04 ( 2 , 1 ) = rdat % r04 ( 2 , 1 ) + ( rdat % fq4 ( 1 , 1 ) * rdat % aqx2 - rdat % fq3 ( 1 , 5 ) * 3 ) * xmdtxy rdat % r04 ( 3 , 1 ) = rdat % r04 ( 3 , 1 ) + ( rdat % fq4 ( 2 , 1 ) * rdat % aqx2 - rdat % fq3 ( 2 , 5 ) * 3 ) * xmdtx rdat % r04 ( 4 , 1 ) = rdat % r04 ( 4 , 1 ) + ( rdat % fq4 ( 1 , 1 ) * x2y2 - rdat % fq3 ( 1 , 5 ) * q2c2 + rdat % fq2 ( 1 , 9 )) * xmdt rdat % r04 ( 5 , 1 ) = rdat % r04 ( 5 , 1 ) + ( rdat % fq4 ( 2 , 1 ) * rdat % aqx2 - rdat % fq3 ( 2 , 5 ) ) * xmdty rdat % r04 ( 6 , 1 ) = rdat % r04 ( 6 , 1 ) + ( rdat % fq4 ( 3 , 1 ) * rdat % aqx2 - rdat % fq3 ( 1 , 5 ) * rdat % aqx2 & & - rdat % fq3 ( 3 , 5 ) + rdat % fq2 ( 1 , 9 ) ) * xmdt rdat % r04 ( 7 , 1 ) = rdat % r04 ( 7 , 1 ) + ( rdat % fq4 ( 1 , 1 ) * rdat % acy2 - rdat % fq3 ( 1 , 5 ) * 3 ) * xmdtxy rdat % r04 ( 8 , 1 ) = rdat % r04 ( 8 , 1 ) + ( rdat % fq4 ( 2 , 1 ) * rdat % acy2 - rdat % fq3 ( 2 , 5 ) ) * xmdtx rdat % r04 ( 9 , 1 ) = rdat % r04 ( 9 , 1 ) + ( rdat % fq4 ( 3 , 1 ) - rdat % fq3 ( 1 , 5 ) ) * xmdtxy rdat % r04 ( 10 , 1 ) = rdat % r04 ( 10 , 1 ) + ( rdat % fq4 ( 4 , 1 ) - rdat % fq3 ( 2 , 5 ) * 3 ) * xmdtx rdat % r04 ( 11 , 1 ) = rdat % r04 ( 11 , 1 ) + ( rdat % fq4 ( 1 , 1 ) * acy4 - rdat % fq3 ( 1 , 5 ) * 6 * rdat % acy2 & & + rdat % fq2 ( 1 , 9 ) * 3 ) * xmdt rdat % r04 ( 12 , 1 ) = rdat % r04 ( 12 , 1 ) + ( rdat % fq4 ( 2 , 1 ) * rdat % acy2 - rdat % fq3 ( 2 , 5 ) * 3 ) * xmdty rdat % r04 ( 13 , 1 ) = rdat % r04 ( 13 , 1 ) + ( rdat % fq4 ( 3 , 1 ) * rdat % acy2 - rdat % fq3 ( 1 , 5 ) * rdat % acy2 - rdat % fq3 ( 3 , 5 ) & & + rdat % fq2 ( 1 , 9 ) ) * xmdt rdat % r04 ( 14 , 1 ) = rdat % r04 ( 14 , 1 ) + ( rdat % fq4 ( 4 , 1 ) - rdat % fq3 ( 2 , 5 ) * 3 ) * xmdty rdat % r04 ( 15 , 1 ) = rdat % r04 ( 15 , 1 ) + ( rdat % fq4 ( 5 , 1 ) - rdat % fq3 ( 3 , 5 ) * 6 + rdat % fq2 ( 1 , 9 ) * 3 ) * xmdt end subroutine intk_13 ! > ! >    @brief   ddps case ! > ! >    @details integration of the ddps case ! > subroutine intk_14 ( rdat , ikl ) implicit none type ( rotaxis_data_t ) :: rdat integer :: ikl real ( kind = dp ) :: xmd2 , xmd3 , xmd4 , xmd6 real ( kind = dp ) :: xmdt , xmdtx , xmdtxy , xmdty real ( kind = dp ) :: aqx4 , acy4 , q2c2 , x2y2 real ( kind = dp ) :: y33 , y34 , y334 , y344 , y44 real ( kind = dp ) :: work , fwk integer :: i , j ! Generate jtype=14 integrals dimension work ( 15 ), fwk ( 15 , 3 ) if ( ikl == 0 ) then rdat % r00 (:, 1 : 2 ) = 0.0_dp rdat % r01 (:, 1 : 13 ) = 0.0_dp rdat % r02 (:, 1 : 12 ) = 0.0_dp rdat % r03 (:, 1 : 8 ) = 0.0_dp rdat % r04 (:, 1 : 4 ) = 0.0_dp rdat % r05 (:, 1 ) = 0.0_dp return endif xmd2 = rdat % x43 * 0.5d+00 xmd3 = xmd2 xmd4 = xmd3 * xmd2 xmd6 = xmd4 * xmd2 xmdt = xmd6 * xmd2 xmd2 = xmd3 xmdty =- xmdt * rdat % acy xmdtx =- xmdt * rdat % aqx xmdtxy = xmdt * rdat % aqxy y33 = rdat % y03 * rdat % y03 y34 =- rdat % y03 * rdat % y04 y44 = rdat % y04 * rdat % y04 y334 = y33 * rdat % y04 y344 = y34 * rdat % y04 work ( 1 ) = xmd4 work ( 2 ) = xmd2 * y33 work ( 3 ) = xmd2 * y34 work ( 4 ) = xmd2 * y44 work ( 5 ) = y33 * y44 work ( 6 ) =- xmd4 * rdat % y03 work ( 7 ) = xmd4 * rdat % y04 work ( 8 ) = xmd2 * y334 work ( 9 ) = xmd2 * y344 work ( 10 ) = xmd6 work ( 11 ) = xmd4 * y33 work ( 12 ) = xmd4 * y34 work ( 13 ) = xmd4 * y44 work ( 14 ) =- xmd6 * rdat % y03 work ( 15 ) = xmd6 * rdat % y04 do i = 1 , 2 do j = 1 , 5 rdat % r00 ( j , i ) = rdat % r00 ( j , i ) + rdat % fq0 ( i ) * work ( j ) end do end do do i = 1 , 3 fwk ( 1 , i ) =- rdat % fq1 ( 1 , i ) * rdat % aqx fwk ( 2 , i ) =- rdat % fq1 ( 1 , i ) * rdat % acy fwk ( 3 , i ) = rdat % fq1 ( 2 , i ) enddo do i = 1 , 4 rdat % r01 ( 1 , i ) = rdat % r01 ( 1 , i ) + fwk ( 1 , 1 ) * work ( i + 5 ) rdat % r01 ( 2 , i ) = rdat % r01 ( 2 , i ) + fwk ( 2 , 1 ) * work ( i + 5 ) rdat % r01 ( 3 , i ) = rdat % r01 ( 3 , i ) + fwk ( 3 , 1 ) * work ( i + 5 ) enddo do i = 5 , 8 rdat % r01 ( 1 , i ) = rdat % r01 ( 1 , i ) + fwk ( 1 , 2 ) * work ( i + 1 ) rdat % r01 ( 2 , i ) = rdat % r01 ( 2 , i ) + fwk ( 2 , 2 ) * work ( i + 1 ) rdat % r01 ( 3 , i ) = rdat % r01 ( 3 , i ) + fwk ( 3 , 2 ) * work ( i + 1 ) enddo do i = 9 , 13 rdat % r01 ( 1 , i ) = rdat % r01 ( 1 , i ) + fwk ( 1 , 3 ) * work ( i - 8 ) rdat % r01 ( 2 , i ) = rdat % r01 ( 2 , i ) + fwk ( 2 , 3 ) * work ( i - 8 ) rdat % r01 ( 3 , i ) = rdat % r01 ( 3 , i ) + fwk ( 3 , 3 ) * work ( i - 8 ) enddo do i = 1 , 3 fwk ( 1 , i ) = rdat % fq2 ( 1 , i ) * rdat % aqx2 - rdat % fq1 ( 1 , i ) fwk ( 2 , i ) = rdat % fq2 ( 1 , i ) * rdat % acy2 - rdat % fq1 ( 1 , i ) fwk ( 3 , i ) = rdat % fq2 ( 3 , i ) - rdat % fq1 ( 1 , i ) fwk ( 4 , i ) = rdat % fq2 ( 1 , i ) * rdat % aqxy fwk ( 5 , i ) =- rdat % fq2 ( 2 , i ) * rdat % aqx fwk ( 6 , i ) =- rdat % fq2 ( 2 , i ) * rdat % acy enddo do i = 1 , 4 do j = 1 , 6 rdat % r02 ( j , i ) = rdat % r02 ( j , i ) + fwk ( j , 1 ) * work ( i + 9 ) enddo enddo do i = 5 , 8 do j = 1 , 6 rdat % r02 ( j , i ) = rdat % r02 ( j , i ) + fwk ( j , 2 ) * work ( i + 5 ) enddo enddo do i = 9 , 12 do j = 1 , 6 rdat % r02 ( j , i ) = rdat % r02 ( j , i ) + fwk ( j , 3 ) * work ( i - 3 ) enddo enddo do i = 1 , 3 fwk ( 1 , i ) =- ( rdat % fq3 ( 1 , i ) * rdat % aqx2 - rdat % fq2 ( 1 , i ) * 3 ) * rdat % aqx fwk ( 2 , i ) =- ( rdat % fq3 ( 1 , i ) * rdat % aqx2 - rdat % fq2 ( 1 , i ) ) * rdat % acy fwk ( 3 , i ) = rdat % fq3 ( 2 , i ) * rdat % aqx2 - rdat % fq2 ( 2 , i ) fwk ( 4 , i ) =- ( rdat % fq3 ( 1 , i ) * rdat % acy2 - rdat % fq2 ( 1 , i ) ) * rdat % aqx fwk ( 5 , i ) = rdat % fq3 ( 2 , i ) * rdat % aqxy fwk ( 6 , i ) =- ( rdat % fq3 ( 3 , i ) - rdat % fq2 ( 1 , i ) ) * rdat % aqx fwk ( 7 , i ) =- ( rdat % fq3 ( 1 , i ) * rdat % acy2 - rdat % fq2 ( 1 , i ) * 3 ) * rdat % acy fwk ( 8 , i ) = rdat % fq3 ( 2 , i ) * rdat % acy2 - rdat % fq2 ( 2 , i ) fwk ( 9 , i ) =- ( rdat % fq3 ( 3 , i ) - rdat % fq2 ( 1 , i ) ) * rdat % acy fwk ( 10 , i ) = rdat % fq3 ( 4 , i ) - rdat % fq2 ( 2 , i ) * 3 enddo do i = 1 , 2 do j = 1 , 10 rdat % r03 ( j , i ) = rdat % r03 ( j , i ) + fwk ( j , 1 ) * work ( i + 13 ) enddo enddo do i = 3 , 4 do j = 1 , 10 rdat % r03 ( j , i ) = rdat % r03 ( j , i ) + fwk ( j , 2 ) * work ( i + 11 ) enddo enddo do i = 5 , 8 do j = 1 , 10 rdat % r03 ( j , i ) = rdat % r03 ( j , i ) + fwk ( j , 3 ) * work ( i + 5 ) enddo enddo aqx4 = rdat % aqx2 * rdat % aqx2 acy4 = rdat % acy2 * rdat % acy2 x2y2 = rdat % aqx2 * rdat % acy2 q2c2 = rdat % aqx2 + rdat % acy2 do i = 1 , 2 rdat % r04 ( 1 , i ) = rdat % r04 ( 1 , i ) + ( rdat % fq4 ( 1 , i ) * aqx4 - rdat % fq3 ( 1 , i ) * 6 * rdat % aqx2 & & + rdat % fq2 ( 1 , i ) * 3 ) * xmdt rdat % r04 ( 2 , i ) = rdat % r04 ( 2 , i ) + ( rdat % fq4 ( 1 , i ) * rdat % aqx2 - rdat % fq3 ( 1 , i ) * 3 ) * xmdtxy rdat % r04 ( 3 , i ) = rdat % r04 ( 3 , i ) + ( rdat % fq4 ( 2 , i ) * rdat % aqx2 - rdat % fq3 ( 2 , i ) * 3 ) * xmdtx rdat % r04 ( 4 , i ) = rdat % r04 ( 4 , i ) + ( rdat % fq4 ( 1 , i ) * x2y2 - rdat % fq3 ( 1 , i ) * q2c2 & & + rdat % fq2 ( 1 , i ) ) * xmdt rdat % r04 ( 5 , i ) = rdat % r04 ( 5 , i ) + ( rdat % fq4 ( 2 , i ) * rdat % aqx2 - rdat % fq3 ( 2 , i ) ) * xmdty rdat % r04 ( 6 , i ) = rdat % r04 ( 6 , i ) + ( rdat % fq4 ( 3 , i ) * rdat % aqx2 - rdat % fq3 ( 1 , i ) * rdat % aqx2 & & - rdat % fq3 ( 3 , i ) + rdat % fq2 ( 1 , i ) ) * xmdt rdat % r04 ( 7 , i ) = rdat % r04 ( 7 , i ) + ( rdat % fq4 ( 1 , i ) * rdat % acy2 - rdat % fq3 ( 1 , i ) * 3 ) * xmdtxy rdat % r04 ( 8 , i ) = rdat % r04 ( 8 , i ) + ( rdat % fq4 ( 2 , i ) * rdat % acy2 - rdat % fq3 ( 2 , i ) ) * xmdtx rdat % r04 ( 9 , i ) = rdat % r04 ( 9 , i ) + ( rdat % fq4 ( 3 , i ) - rdat % fq3 ( 1 , i ) ) * xmdtxy rdat % r04 ( 10 , i ) = rdat % r04 ( 10 , i ) + ( rdat % fq4 ( 4 , i ) - rdat % fq3 ( 2 , i ) * 3 ) * xmdtx rdat % r04 ( 11 , i ) = rdat % r04 ( 11 , i ) + ( rdat % fq4 ( 1 , i ) * acy4 - rdat % fq3 ( 1 , i ) * 6 * rdat % acy2 & & + rdat % fq2 ( 1 , i ) * 3 ) * xmdt rdat % r04 ( 12 , i ) = rdat % r04 ( 12 , i ) + ( rdat % fq4 ( 2 , i ) * rdat % acy2 - rdat % fq3 ( 2 , i ) * 3 ) * xmdty rdat % r04 ( 13 , i ) = rdat % r04 ( 13 , i ) + ( rdat % fq4 ( 3 , i ) * rdat % acy2 - rdat % fq3 ( 1 , i ) * rdat % acy2 & & - rdat % fq3 ( 3 , i ) + rdat % fq2 ( 1 , i ) ) * xmdt rdat % r04 ( 14 , i ) = rdat % r04 ( 14 , i ) + ( rdat % fq4 ( 4 , i ) - rdat % fq3 ( 2 , i ) * 3 ) * xmdty rdat % r04 ( 15 , i ) = rdat % r04 ( 15 , i ) + ( rdat % fq4 ( 5 , i ) - rdat % fq3 ( 3 , i ) * 6 & & + rdat % fq2 ( 1 , i ) * 3 ) * xmdt enddo fwk ( 1 , 3 ) = rdat % fq4 ( 1 , 3 ) * aqx4 - rdat % fq3 ( 1 , 3 ) * 6 * rdat % aqx2 + rdat % fq2 ( 1 , 3 ) * 3 fwk ( 2 , 3 ) = ( rdat % fq4 ( 1 , 3 ) * rdat % aqx2 - rdat % fq3 ( 1 , 3 ) * 3 ) * rdat % aqxy fwk ( 3 , 3 ) =- ( rdat % fq4 ( 2 , 3 ) * rdat % aqx2 - rdat % fq3 ( 2 , 3 ) * 3 ) * rdat % aqx fwk ( 4 , 3 ) = rdat % fq4 ( 1 , 3 ) * x2y2 - rdat % fq3 ( 1 , 3 ) * q2c2 + rdat % fq2 ( 1 , 3 ) fwk ( 5 , 3 ) =- ( rdat % fq4 ( 2 , 3 ) * rdat % aqx2 - rdat % fq3 ( 2 , 3 ) ) * rdat % acy fwk ( 6 , 3 ) = rdat % fq4 ( 3 , 3 ) * rdat % aqx2 - rdat % fq3 ( 1 , 3 ) * rdat % aqx2 - rdat % fq3 ( 3 , 3 ) + rdat % fq2 ( 1 , 3 ) fwk ( 7 , 3 ) = ( rdat % fq4 ( 1 , 3 ) * rdat % acy2 - rdat % fq3 ( 1 , 3 ) * 3 ) * rdat % aqxy fwk ( 8 , 3 ) =- ( rdat % fq4 ( 2 , 3 ) * rdat % acy2 - rdat % fq3 ( 2 , 3 ) ) * rdat % aqx fwk ( 9 , 3 ) = ( rdat % fq4 ( 3 , 3 ) - rdat % fq3 ( 1 , 3 ) ) * rdat % aqxy fwk ( 10 , 3 ) =- ( rdat % fq4 ( 4 , 3 ) - rdat % fq3 ( 2 , 3 ) * 3 ) * rdat % aqx fwk ( 11 , 3 ) = rdat % fq4 ( 1 , 3 ) * acy4 - rdat % fq3 ( 1 , 3 ) * 6 * rdat % acy2 + rdat % fq2 ( 1 , 3 ) * 3 fwk ( 12 , 3 ) =- ( rdat % fq4 ( 2 , 3 ) * rdat % acy2 - rdat % fq3 ( 2 , 3 ) * 3 ) * rdat % acy fwk ( 13 , 3 ) = rdat % fq4 ( 3 , 3 ) * rdat % acy2 - rdat % fq3 ( 1 , 3 ) * rdat % acy2 - rdat % fq3 ( 3 , 3 ) + rdat % fq2 ( 1 , 3 ) fwk ( 14 , 3 ) =- ( rdat % fq4 ( 4 , 3 ) - rdat % fq3 ( 2 , 3 ) * 3 ) * rdat % acy fwk ( 15 , 3 ) = rdat % fq4 ( 5 , 3 ) - rdat % fq3 ( 3 , 3 ) * 6 + rdat % fq2 ( 1 , 3 ) * 3 do i = 3 , 4 do j = 1 , 15 rdat % r04 ( j , i ) = rdat % r04 ( j , i ) + fwk ( j , 3 ) * work ( i + 11 ) end do end do rdat % r05 ( 1 , 1 ) = rdat % r05 ( 1 , 1 ) + ( rdat % fq5 ( 1 , 1 ) * aqx4 - rdat % fq4 ( 1 , 3 ) * 10 * rdat % aqx2 & & + rdat % fq3 ( 1 , 3 ) * 15 ) * xmdtx rdat % r05 ( 2 , 1 ) = rdat % r05 ( 2 , 1 ) + ( rdat % fq5 ( 1 , 1 ) * aqx4 - rdat % fq4 ( 1 , 3 ) * 6 * rdat % aqx2 & & + rdat % fq3 ( 1 , 3 ) * 3 ) * xmdty rdat % r05 ( 3 , 1 ) = rdat % r05 ( 3 , 1 ) + ( rdat % fq5 ( 2 , 1 ) * aqx4 - rdat % fq4 ( 2 , 3 ) * 6 * rdat % aqx2 & & + rdat % fq3 ( 2 , 3 ) * 3 ) * xmdt rdat % r05 ( 4 , 1 ) = rdat % r05 ( 4 , 1 ) + ( rdat % fq5 ( 1 , 1 ) * x2y2 - rdat % fq4 ( 1 , 3 ) * rdat % aqx2 - rdat % fq4 ( 1 , 3 ) * 3 * rdat % acy2 & & + rdat % fq3 ( 1 , 3 ) * 3 ) * xmdtx rdat % r05 ( 5 , 1 ) = rdat % r05 ( 5 , 1 ) + ( rdat % fq5 ( 2 , 1 ) * rdat % aqx2 - rdat % fq4 ( 2 , 3 ) * 3 ) * xmdtxy rdat % r05 ( 6 , 1 ) = rdat % r05 ( 6 , 1 ) + ( rdat % fq5 ( 3 , 1 ) * rdat % aqx2 - rdat % fq4 ( 1 , 3 ) * rdat % aqx2 - rdat % fq4 ( 3 , 3 ) * 3 & & + rdat % fq3 ( 1 , 3 ) * 3 ) * xmdtx rdat % r05 ( 7 , 1 ) = rdat % r05 ( 7 , 1 ) + ( rdat % fq5 ( 1 , 1 ) * x2y2 - rdat % fq4 ( 1 , 3 ) * 3 * rdat % aqx2 - rdat % fq4 ( 1 , 3 ) * rdat % acy2 & & + rdat % fq3 ( 1 , 3 ) * 3 ) * xmdty rdat % r05 ( 8 , 1 ) = rdat % r05 ( 8 , 1 ) + ( rdat % fq5 ( 2 , 1 ) * x2y2 - rdat % fq4 ( 2 , 3 ) * q2c2 + rdat % fq3 ( 2 , 3 )) * xmdt rdat % r05 ( 9 , 1 ) = rdat % r05 ( 9 , 1 ) + ( rdat % fq5 ( 3 , 1 ) * rdat % aqx2 - rdat % fq4 ( 1 , 3 ) * rdat % aqx2 - rdat % fq4 ( 3 , 3 ) & & + rdat % fq3 ( 1 , 3 ) ) * xmdty rdat % r05 ( 10 , 1 ) = rdat % r05 ( 10 , 1 ) + ( rdat % fq5 ( 4 , 1 ) * rdat % aqx2 - rdat % fq4 ( 2 , 3 ) * 3 * rdat % aqx2 - rdat % fq4 ( 4 , 3 ) & & + rdat % fq3 ( 2 , 3 ) * 3 ) * xmdt rdat % r05 ( 11 , 1 ) = rdat % r05 ( 11 , 1 ) + ( rdat % fq5 ( 1 , 1 ) * acy4 - rdat % fq4 ( 1 , 3 ) * 6 * rdat % acy2 & & + rdat % fq3 ( 1 , 3 ) * 3 ) * xmdtx rdat % r05 ( 12 , 1 ) = rdat % r05 ( 12 , 1 ) + ( rdat % fq5 ( 2 , 1 ) * rdat % acy2 - rdat % fq4 ( 2 , 3 ) * 3 ) * xmdtxy rdat % r05 ( 13 , 1 ) = rdat % r05 ( 13 , 1 ) + ( rdat % fq5 ( 3 , 1 ) * rdat % acy2 - rdat % fq4 ( 1 , 3 ) * rdat % acy2 - rdat % fq4 ( 3 , 3 ) & & + rdat % fq3 ( 1 , 3 ) ) * xmdtx rdat % r05 ( 14 , 1 ) = rdat % r05 ( 14 , 1 ) + ( rdat % fq5 ( 4 , 1 ) - rdat % fq4 ( 2 , 3 ) * 3 ) * xmdtxy rdat % r05 ( 15 , 1 ) = rdat % r05 ( 15 , 1 ) + ( rdat % fq5 ( 5 , 1 ) - rdat % fq4 ( 3 , 3 ) * 6 + rdat % fq3 ( 1 , 3 ) * 3 ) * xmdtx rdat % r05 ( 16 , 1 ) = rdat % r05 ( 16 , 1 ) + ( rdat % fq5 ( 1 , 1 ) * acy4 - rdat % fq4 ( 1 , 3 ) * 10 * rdat % acy2 & & + rdat % fq3 ( 1 , 3 ) * 15 ) * xmdty rdat % r05 ( 17 , 1 ) = rdat % r05 ( 17 , 1 ) + ( rdat % fq5 ( 2 , 1 ) * acy4 - rdat % fq4 ( 2 , 3 ) * 6 * rdat % acy2 & & + rdat % fq3 ( 2 , 3 ) * 3 ) * xmdt rdat % r05 ( 18 , 1 ) = rdat % r05 ( 18 , 1 ) + ( rdat % fq5 ( 3 , 1 ) * rdat % acy2 - rdat % fq4 ( 1 , 3 ) * rdat % acy2 - rdat % fq4 ( 3 , 3 ) * 3 & & + rdat % fq3 ( 1 , 3 ) * 3 ) * xmdty rdat % r05 ( 19 , 1 ) = rdat % r05 ( 19 , 1 ) + ( rdat % fq5 ( 4 , 1 ) * rdat % acy2 - rdat % fq4 ( 2 , 3 ) * 3 * rdat % acy2 - rdat % fq4 ( 4 , 3 ) & & + rdat % fq3 ( 2 , 3 ) * 3 ) * xmdt rdat % r05 ( 20 , 1 ) = rdat % r05 ( 20 , 1 ) + ( rdat % fq5 ( 5 , 1 ) - rdat % fq4 ( 3 , 3 ) * 6 + rdat % fq3 ( 1 , 3 ) * 3 ) * xmdty rdat % r05 ( 21 , 1 ) = rdat % r05 ( 21 , 1 ) + ( rdat % fq5 ( 6 , 1 ) - rdat % fq4 ( 4 , 3 ) * 10 + rdat % fq3 ( 2 , 3 ) * 15 ) * xmdt end subroutine intk_14 ! > ! >    @brief   dpds case ! > ! >    @details integration of the dpds case ! > subroutine intk_15 ( rdat , ikl ) implicit none type ( rotaxis_data_t ) :: rdat integer :: ikl real ( kind = dp ) :: xmd1 , xmd2 , xmd3 , xmd4 , xmd5 real ( kind = dp ) :: xmdt , xmdtx , xmdtxy , xmdty real ( kind = dp ) :: aqx4 , acy4 , q2c2 , x2y2 real ( kind = dp ) :: y33 , y34 real ( kind = dp ) :: work , fwk integer :: i , j ! Generate jtype=15 integrals dimension work ( 12 ), fwk ( 15 , 4 ) if ( ikl == 0 ) then rdat % r00 (:, 1 : 2 ) = 0.0_dp rdat % r01 (:, 1 : 13 ) = 0.0_dp rdat % r02 (:, 1 : 15 ) = 0.0_dp rdat % r03 (:, 1 : 9 ) = 0.0_dp rdat % r04 (:, 1 : 4 ) = 0.0_dp rdat % r05 (:, 1 ) = 0.0_dp return endif xmd2 = rdat % x43 * 0.5d+00 xmd1 = xmd2 xmd3 = xmd2 xmd4 = xmd2 * xmd2 xmd5 = xmd4 xmdt = xmd4 * xmd3 xmdty =- xmdt * rdat % acy xmdtx =- xmdt * rdat % aqx xmdtxy = xmdt * rdat % aqxy y33 = rdat % y03 * rdat % y03 y34 =- rdat % y03 * rdat % y04 work ( 1 ) = xmd1 work ( 2 ) = y33 work ( 3 ) =- xmd3 * rdat % y03 work ( 4 ) = xmd3 * rdat % y04 work ( 5 ) = y33 * rdat % y04 work ( 6 ) =- xmd1 * rdat % y03 work ( 7 ) = xmd5 work ( 8 ) = xmd3 * y33 work ( 9 ) = xmd3 * y34 work ( 10 ) = xmd4 work ( 11 ) =- xmd5 * rdat % y03 work ( 12 ) = xmd5 * rdat % y04 do i = 1 , 2 do j = 1 , 5 rdat % r00 ( j , i ) = rdat % r00 ( j , i ) + rdat % fq0 ( i ) * work ( j ) end do end do do i = 1 , 3 fwk ( 1 , i ) =- rdat % fq1 ( 1 , i ) * rdat % aqx fwk ( 2 , i ) =- rdat % fq1 ( 1 , i ) * rdat % acy fwk ( 3 , i ) = rdat % fq1 ( 2 , i ) enddo do i = 1 , 4 rdat % r01 ( 1 , i ) = rdat % r01 ( 1 , i ) + fwk ( 1 , 1 ) * work ( i + 5 ) rdat % r01 ( 2 , i ) = rdat % r01 ( 2 , i ) + fwk ( 2 , 1 ) * work ( i + 5 ) rdat % r01 ( 3 , i ) = rdat % r01 ( 3 , i ) + fwk ( 3 , 1 ) * work ( i + 5 ) enddo do i = 5 , 8 rdat % r01 ( 1 , i ) = rdat % r01 ( 1 , i ) + fwk ( 1 , 2 ) * work ( i + 1 ) rdat % r01 ( 2 , i ) = rdat % r01 ( 2 , i ) + fwk ( 2 , 2 ) * work ( i + 1 ) rdat % r01 ( 3 , i ) = rdat % r01 ( 3 , i ) + fwk ( 3 , 2 ) * work ( i + 1 ) enddo do i = 9 , 13 rdat % r01 ( 1 , i ) = rdat % r01 ( 1 , i ) + fwk ( 1 , 3 ) * work ( i - 8 ) rdat % r01 ( 2 , i ) = rdat % r01 ( 2 , i ) + fwk ( 2 , 3 ) * work ( i - 8 ) rdat % r01 ( 3 , i ) = rdat % r01 ( 3 , i ) + fwk ( 3 , 3 ) * work ( i - 8 ) enddo do i = 1 , 4 fwk ( 1 , i ) = rdat % fq2 ( 1 , i ) * rdat % aqx2 - rdat % fq1 ( 1 , i ) fwk ( 2 , i ) = rdat % fq2 ( 1 , i ) * rdat % acy2 - rdat % fq1 ( 1 , i ) fwk ( 3 , i ) = rdat % fq2 ( 3 , i ) - rdat % fq1 ( 1 , i ) fwk ( 4 , i ) = rdat % fq2 ( 1 , i ) * rdat % aqxy fwk ( 5 , i ) =- rdat % fq2 ( 2 , i ) * rdat % aqx fwk ( 6 , i ) =- rdat % fq2 ( 2 , i ) * rdat % acy enddo do i = 1 , 3 do j = 1 , 6 rdat % r02 ( j , i ) = rdat % r02 ( j , i ) + fwk ( j , 1 ) * work ( i + 9 ) enddo enddo do i = 4 , 6 do j = 1 , 6 rdat % r02 ( j , i ) = rdat % r02 ( j , i ) + fwk ( j , 2 ) * work ( i + 6 ) enddo enddo do i = 7 , 10 do j = 1 , 6 rdat % r02 ( j , i ) = rdat % r02 ( j , i ) + fwk ( j , 3 ) * work ( i - 1 ) enddo enddo do i = 11 , 15 do j = 1 , 6 rdat % r02 ( j , i ) = rdat % r02 ( j , i ) + fwk ( j , 4 ) * work ( i - 10 ) enddo enddo do i = 1 , 2 rdat % r03 ( 1 , i ) = rdat % r03 ( 1 , i ) + ( rdat % fq3 ( 1 , i ) * rdat % aqx2 - rdat % fq2 ( 1 , i ) * 3 ) * xmdtx rdat % r03 ( 2 , i ) = rdat % r03 ( 2 , i ) + ( rdat % fq3 ( 1 , i ) * rdat % aqx2 - rdat % fq2 ( 1 , i ) ) * xmdty rdat % r03 ( 3 , i ) = rdat % r03 ( 3 , i ) + ( rdat % fq3 ( 2 , i ) * rdat % aqx2 - rdat % fq2 ( 2 , i ) ) * xmdt rdat % r03 ( 4 , i ) = rdat % r03 ( 4 , i ) + ( rdat % fq3 ( 1 , i ) * rdat % acy2 - rdat % fq2 ( 1 , i ) ) * xmdtx rdat % r03 ( 5 , i ) = rdat % r03 ( 5 , i ) + rdat % fq3 ( 2 , i ) * xmdtxy rdat % r03 ( 6 , i ) = rdat % r03 ( 6 , i ) + ( rdat % fq3 ( 3 , i ) - rdat % fq2 ( 1 , i ) ) * xmdtx rdat % r03 ( 7 , i ) = rdat % r03 ( 7 , i ) + ( rdat % fq3 ( 1 , i ) * rdat % acy2 - rdat % fq2 ( 1 , i ) * 3 ) * xmdty rdat % r03 ( 8 , i ) = rdat % r03 ( 8 , i ) + ( rdat % fq3 ( 2 , i ) * rdat % acy2 - rdat % fq2 ( 2 , i ) ) * xmdt rdat % r03 ( 9 , i ) = rdat % r03 ( 9 , i ) + ( rdat % fq3 ( 3 , i ) - rdat % fq2 ( 1 , i ) ) * xmdty rdat % r03 ( 10 , i ) = rdat % r03 ( 10 , i ) + ( rdat % fq3 ( 4 , i ) - rdat % fq2 ( 2 , i ) * 3 ) * xmdt enddo do i = 3 , 4 fwk ( 1 , i ) =- ( rdat % fq3 ( 1 , i ) * rdat % aqx2 - rdat % fq2 ( 1 , i ) * 3 ) * rdat % aqx fwk ( 2 , i ) =- ( rdat % fq3 ( 1 , i ) * rdat % aqx2 - rdat % fq2 ( 1 , i ) ) * rdat % acy fwk ( 3 , i ) = rdat % fq3 ( 2 , i ) * rdat % aqx2 - rdat % fq2 ( 2 , i ) fwk ( 4 , i ) =- ( rdat % fq3 ( 1 , i ) * rdat % acy2 - rdat % fq2 ( 1 , i ) ) * rdat % aqx fwk ( 5 , i ) = rdat % fq3 ( 2 , i ) * rdat % aqxy fwk ( 6 , i ) =- ( rdat % fq3 ( 3 , i ) - rdat % fq2 ( 1 , i ) ) * rdat % aqx fwk ( 7 , i ) =- ( rdat % fq3 ( 1 , i ) * rdat % acy2 - rdat % fq2 ( 1 , i ) * 3 ) * rdat % acy fwk ( 8 , i ) = rdat % fq3 ( 2 , i ) * rdat % acy2 - rdat % fq2 ( 2 , i ) fwk ( 9 , i ) =- ( rdat % fq3 ( 3 , i ) - rdat % fq2 ( 1 , i ) ) * rdat % acy fwk ( 10 , i ) = rdat % fq3 ( 4 , i ) - rdat % fq2 ( 2 , i ) * 3 enddo do i = 3 , 5 do j = 1 , 10 rdat % r03 ( j , i ) = rdat % r03 ( j , i ) + fwk ( j , 3 ) * work ( i + 7 ) enddo enddo do i = 6 , 9 do j = 1 , 10 rdat % r03 ( j , i ) = rdat % r03 ( j , i ) + fwk ( j , 4 ) * work ( i ) enddo enddo aqx4 = rdat % aqx2 * rdat % aqx2 acy4 = rdat % acy2 * rdat % acy2 x2y2 = rdat % aqx2 * rdat % acy2 q2c2 = rdat % aqx2 + rdat % acy2 rdat % r04 ( 1 , 1 ) = rdat % r04 ( 1 , 1 ) + ( rdat % fq4 ( 1 , 1 ) * aqx4 - rdat % fq3 ( 1 , 3 ) * 6 * rdat % aqx2 & & + rdat % fq2 ( 1 , 3 ) * 3 ) * xmdt rdat % r04 ( 2 , 1 ) = rdat % r04 ( 2 , 1 ) + ( rdat % fq4 ( 1 , 1 ) * rdat % aqx2 - rdat % fq3 ( 1 , 3 ) * 3 ) * xmdtxy rdat % r04 ( 3 , 1 ) = rdat % r04 ( 3 , 1 ) + ( rdat % fq4 ( 2 , 1 ) * rdat % aqx2 - rdat % fq3 ( 2 , 3 ) * 3 ) * xmdtx rdat % r04 ( 4 , 1 ) = rdat % r04 ( 4 , 1 ) + ( rdat % fq4 ( 1 , 1 ) * x2y2 - rdat % fq3 ( 1 , 3 ) * q2c2 & & + rdat % fq2 ( 1 , 3 ) ) * xmdt rdat % r04 ( 5 , 1 ) = rdat % r04 ( 5 , 1 ) + ( rdat % fq4 ( 2 , 1 ) * rdat % aqx2 - rdat % fq3 ( 2 , 3 ) ) * xmdty rdat % r04 ( 6 , 1 ) = rdat % r04 ( 6 , 1 ) + ( rdat % fq4 ( 3 , 1 ) * rdat % aqx2 - rdat % fq3 ( 1 , 3 ) * rdat % aqx2 & & - rdat % fq3 ( 3 , 3 ) + rdat % fq2 ( 1 , 3 ) ) * xmdt rdat % r04 ( 7 , 1 ) = rdat % r04 ( 7 , 1 ) + ( rdat % fq4 ( 1 , 1 ) * rdat % acy2 - rdat % fq3 ( 1 , 3 ) * 3 ) * xmdtxy rdat % r04 ( 8 , 1 ) = rdat % r04 ( 8 , 1 ) + ( rdat % fq4 ( 2 , 1 ) * rdat % acy2 - rdat % fq3 ( 2 , 3 ) ) * xmdtx rdat % r04 ( 9 , 1 ) = rdat % r04 ( 9 , 1 ) + ( rdat % fq4 ( 3 , 1 ) - rdat % fq3 ( 1 , 3 ) ) * xmdtxy rdat % r04 ( 10 , 1 ) = rdat % r04 ( 10 , 1 ) + ( rdat % fq4 ( 4 , 1 ) - rdat % fq3 ( 2 , 3 ) * 3 ) * xmdtx rdat % r04 ( 11 , 1 ) = rdat % r04 ( 11 , 1 ) + ( rdat % fq4 ( 1 , 1 ) * acy4 - rdat % fq3 ( 1 , 3 ) * 6 * rdat % acy2 & & + rdat % fq2 ( 1 , 3 ) * 3 ) * xmdt rdat % r04 ( 12 , 1 ) = rdat % r04 ( 12 , 1 ) + ( rdat % fq4 ( 2 , 1 ) * rdat % acy2 - rdat % fq3 ( 2 , 3 ) * 3 ) * xmdty rdat % r04 ( 13 , 1 ) = rdat % r04 ( 13 , 1 ) + ( rdat % fq4 ( 3 , 1 ) * rdat % acy2 - rdat % fq3 ( 1 , 3 ) * rdat % acy2 & & - rdat % fq3 ( 3 , 3 ) + rdat % fq2 ( 1 , 3 ) ) * xmdt rdat % r04 ( 14 , 1 ) = rdat % r04 ( 14 , 1 ) + ( rdat % fq4 ( 4 , 1 ) - rdat % fq3 ( 2 , 3 ) * 3 ) * xmdty rdat % r04 ( 15 , 1 ) = rdat % r04 ( 15 , 1 ) + ( rdat % fq4 ( 5 , 1 ) - rdat % fq3 ( 3 , 3 ) * 6 & & + rdat % fq2 ( 1 , 3 ) * 3 ) * xmdt fwk ( 1 , 2 ) = rdat % fq4 ( 1 , 2 ) * aqx4 - rdat % fq3 ( 1 , 4 ) * 6 * rdat % aqx2 + rdat % fq2 ( 1 , 4 ) * 3 fwk ( 2 , 2 ) = ( rdat % fq4 ( 1 , 2 ) * rdat % aqx2 - rdat % fq3 ( 1 , 4 ) * 3 ) * rdat % aqxy fwk ( 3 , 2 ) =- ( rdat % fq4 ( 2 , 2 ) * rdat % aqx2 - rdat % fq3 ( 2 , 4 ) * 3 ) * rdat % aqx fwk ( 4 , 2 ) = rdat % fq4 ( 1 , 2 ) * x2y2 - rdat % fq3 ( 1 , 4 ) * q2c2 + rdat % fq2 ( 1 , 4 ) fwk ( 5 , 2 ) =- ( rdat % fq4 ( 2 , 2 ) * rdat % aqx2 - rdat % fq3 ( 2 , 4 ) ) * rdat % acy fwk ( 6 , 2 ) = rdat % fq4 ( 3 , 2 ) * rdat % aqx2 - rdat % fq3 ( 1 , 4 ) * rdat % aqx2 - rdat % fq3 ( 3 , 4 ) + rdat % fq2 ( 1 , 4 ) fwk ( 7 , 2 ) = ( rdat % fq4 ( 1 , 2 ) * rdat % acy2 - rdat % fq3 ( 1 , 4 ) * 3 ) * rdat % aqxy fwk ( 8 , 2 ) =- ( rdat % fq4 ( 2 , 2 ) * rdat % acy2 - rdat % fq3 ( 2 , 4 ) ) * rdat % aqx fwk ( 9 , 2 ) = ( rdat % fq4 ( 3 , 2 ) - rdat % fq3 ( 1 , 4 ) ) * rdat % aqxy fwk ( 10 , 2 ) =- ( rdat % fq4 ( 4 , 2 ) - rdat % fq3 ( 2 , 4 ) * 3 ) * rdat % aqx fwk ( 11 , 2 ) = rdat % fq4 ( 1 , 2 ) * acy4 - rdat % fq3 ( 1 , 4 ) * 6 * rdat % acy2 + rdat % fq2 ( 1 , 4 ) * 3 fwk ( 12 , 2 ) =- ( rdat % fq4 ( 2 , 2 ) * rdat % acy2 - rdat % fq3 ( 2 , 4 ) * 3 ) * rdat % acy fwk ( 13 , 2 ) = rdat % fq4 ( 3 , 2 ) * rdat % acy2 - rdat % fq3 ( 1 , 4 ) * rdat % acy2 - rdat % fq3 ( 3 , 4 ) + rdat % fq2 ( 1 , 4 ) fwk ( 14 , 2 ) =- ( rdat % fq4 ( 4 , 2 ) - rdat % fq3 ( 2 , 4 ) * 3 ) * rdat % acy fwk ( 15 , 2 ) = rdat % fq4 ( 5 , 2 ) - rdat % fq3 ( 3 , 4 ) * 6 + rdat % fq2 ( 1 , 4 ) * 3 do i = 2 , 4 do j = 1 , 15 rdat % r04 ( j , i ) = rdat % r04 ( j , i ) + fwk ( j , 2 ) * work ( i + 8 ) end do end do rdat % r05 ( 1 , 1 ) = rdat % r05 ( 1 , 1 ) + ( rdat % fq5 ( 1 , 1 ) * aqx4 - rdat % fq4 ( 1 , 2 ) * 10 * rdat % aqx2 & & + rdat % fq3 ( 1 , 4 ) * 15 ) * xmdtx rdat % r05 ( 2 , 1 ) = rdat % r05 ( 2 , 1 ) + ( rdat % fq5 ( 1 , 1 ) * aqx4 - rdat % fq4 ( 1 , 2 ) * 6 * rdat % aqx2 & & + rdat % fq3 ( 1 , 4 ) * 3 ) * xmdty rdat % r05 ( 3 , 1 ) = rdat % r05 ( 3 , 1 ) + ( rdat % fq5 ( 2 , 1 ) * aqx4 - rdat % fq4 ( 2 , 2 ) * 6 * rdat % aqx2 & & + rdat % fq3 ( 2 , 4 ) * 3 ) * xmdt rdat % r05 ( 4 , 1 ) = rdat % r05 ( 4 , 1 ) + ( rdat % fq5 ( 1 , 1 ) * x2y2 - rdat % fq4 ( 1 , 2 ) * rdat % aqx2 - rdat % fq4 ( 1 , 2 ) * 3 * rdat % acy2 & & + rdat % fq3 ( 1 , 4 ) * 3 ) * xmdtx rdat % r05 ( 5 , 1 ) = rdat % r05 ( 5 , 1 ) + ( rdat % fq5 ( 2 , 1 ) * rdat % aqx2 - rdat % fq4 ( 2 , 2 ) * 3 ) * xmdtxy rdat % r05 ( 6 , 1 ) = rdat % r05 ( 6 , 1 ) + ( rdat % fq5 ( 3 , 1 ) * rdat % aqx2 - rdat % fq4 ( 1 , 2 ) * rdat % aqx2 - rdat % fq4 ( 3 , 2 ) * 3 & & + rdat % fq3 ( 1 , 4 ) * 3 ) * xmdtx rdat % r05 ( 7 , 1 ) = rdat % r05 ( 7 , 1 ) + ( rdat % fq5 ( 1 , 1 ) * x2y2 - rdat % fq4 ( 1 , 2 ) * 3 * rdat % aqx2 - rdat % fq4 ( 1 , 2 ) * rdat % acy2 & & + rdat % fq3 ( 1 , 4 ) * 3 ) * xmdty rdat % r05 ( 8 , 1 ) = rdat % r05 ( 8 , 1 ) + ( rdat % fq5 ( 2 , 1 ) * x2y2 - rdat % fq4 ( 2 , 2 ) * q2c2 + rdat % fq3 ( 2 , 4 )) * xmdt rdat % r05 ( 9 , 1 ) = rdat % r05 ( 9 , 1 ) + ( rdat % fq5 ( 3 , 1 ) * rdat % aqx2 - rdat % fq4 ( 1 , 2 ) * rdat % aqx2 - rdat % fq4 ( 3 , 2 ) & & + rdat % fq3 ( 1 , 4 ) ) * xmdty rdat % r05 ( 10 , 1 ) = rdat % r05 ( 10 , 1 ) + ( rdat % fq5 ( 4 , 1 ) * rdat % aqx2 - rdat % fq4 ( 2 , 2 ) * 3 * rdat % aqx2 - rdat % fq4 ( 4 , 2 ) & & + rdat % fq3 ( 2 , 4 ) * 3 ) * xmdt rdat % r05 ( 11 , 1 ) = rdat % r05 ( 11 , 1 ) + ( rdat % fq5 ( 1 , 1 ) * acy4 - rdat % fq4 ( 1 , 2 ) * 6 * rdat % acy2 & & + rdat % fq3 ( 1 , 4 ) * 3 ) * xmdtx rdat % r05 ( 12 , 1 ) = rdat % r05 ( 12 , 1 ) + ( rdat % fq5 ( 2 , 1 ) * rdat % acy2 - rdat % fq4 ( 2 , 2 ) * 3 ) * xmdtxy rdat % r05 ( 13 , 1 ) = rdat % r05 ( 13 , 1 ) + ( rdat % fq5 ( 3 , 1 ) * rdat % acy2 - rdat % fq4 ( 1 , 2 ) * rdat % acy2 - rdat % fq4 ( 3 , 2 ) & & + rdat % fq3 ( 1 , 4 ) ) * xmdtx rdat % r05 ( 14 , 1 ) = rdat % r05 ( 14 , 1 ) + ( rdat % fq5 ( 4 , 1 ) - rdat % fq4 ( 2 , 2 ) * 3 ) * xmdtxy rdat % r05 ( 15 , 1 ) = rdat % r05 ( 15 , 1 ) + ( rdat % fq5 ( 5 , 1 ) - rdat % fq4 ( 3 , 2 ) * 6 + rdat % fq3 ( 1 , 4 ) * 3 ) * xmdtx rdat % r05 ( 16 , 1 ) = rdat % r05 ( 16 , 1 ) + ( rdat % fq5 ( 1 , 1 ) * acy4 - rdat % fq4 ( 1 , 2 ) * 10 * rdat % acy2 & & + rdat % fq3 ( 1 , 4 ) * 15 ) * xmdty rdat % r05 ( 17 , 1 ) = rdat % r05 ( 17 , 1 ) + ( rdat % fq5 ( 2 , 1 ) * acy4 - rdat % fq4 ( 2 , 2 ) * 6 * rdat % acy2 & & + rdat % fq3 ( 2 , 4 ) * 3 ) * xmdt rdat % r05 ( 18 , 1 ) = rdat % r05 ( 18 , 1 ) + ( rdat % fq5 ( 3 , 1 ) * rdat % acy2 - rdat % fq4 ( 1 , 2 ) * rdat % acy2 - rdat % fq4 ( 3 , 2 ) * 3 & & + rdat % fq3 ( 1 , 4 ) * 3 ) * xmdty rdat % r05 ( 19 , 1 ) = rdat % r05 ( 19 , 1 ) + ( rdat % fq5 ( 4 , 1 ) * rdat % acy2 - rdat % fq4 ( 2 , 2 ) * 3 * rdat % acy2 - rdat % fq4 ( 4 , 2 ) & & + rdat % fq3 ( 2 , 4 ) * 3 ) * xmdt rdat % r05 ( 20 , 1 ) = rdat % r05 ( 20 , 1 ) + ( rdat % fq5 ( 5 , 1 ) - rdat % fq4 ( 3 , 2 ) * 6 + rdat % fq3 ( 1 , 4 ) * 3 ) * xmdty rdat % r05 ( 21 , 1 ) = rdat % r05 ( 21 , 1 ) + ( rdat % fq5 ( 6 , 1 ) - rdat % fq4 ( 4 , 2 ) * 10 + rdat % fq3 ( 2 , 4 ) * 15 ) * xmdt end subroutine intk_15 ! > ! >    @brief   dppp case ! > ! >    @details integration of the dppp case ! > subroutine intk_16 ( rdat , ikl ) implicit none type ( rotaxis_data_t ) :: rdat integer :: ikl real ( kind = dp ) :: xmd1 , xmd2 , xmd3 , xmd4 , xmd5 real ( kind = dp ) :: xmdt , xmdtx , xmdtxy , xmdty real ( kind = dp ) :: aqx4 , acy4 , q2c2 , x2y2 real ( kind = dp ) :: y33 , y34 real ( kind = dp ) :: fqd11 , fqd12 , fqd21 , fqd22 , fqd23 real ( kind = dp ) :: work , fwk integer :: i , j ! Generate jtype=16 integrals dimension work ( 12 ), fwk ( 15 , 10 ) if ( ikl == 0 ) then rdat % r00 = 0.0_dp rdat % r01 = 0.0_dp rdat % r02 (:, 1 : 36 ) = 0.0_dp rdat % r03 (:, 1 : 21 ) = 0.0_dp rdat % r04 (:, 1 : 7 ) = 0.0_dp rdat % r05 (:, 1 ) = 0.0_dp return endif xmd2 = rdat % x43 * 0.5d+00 xmd1 = xmd2 xmd3 = xmd2 xmd4 = xmd2 * xmd2 xmd5 = xmd4 xmdt = xmd4 * xmd3 xmdty =- xmdt * rdat % acy xmdtx =- xmdt * rdat % aqx xmdtxy = xmdt * rdat % aqxy y33 = rdat % y03 * rdat % y03 y34 =- rdat % y03 * rdat % y04 work ( 1 ) = xmd1 work ( 2 ) = y33 work ( 3 ) =- xmd3 * rdat % y03 work ( 4 ) = xmd3 * rdat % y04 work ( 5 ) = y33 * rdat % y04 work ( 6 ) =- xmd1 * rdat % y03 work ( 7 ) = xmd5 work ( 8 ) = xmd3 * y33 work ( 9 ) = xmd3 * y34 work ( 10 ) = xmd4 work ( 11 ) =- xmd5 * rdat % y03 work ( 12 ) = xmd5 * rdat % y04 do i = 1 , 5 do j = 1 , 5 rdat % r00 ( j , i ) = rdat % r00 ( j , i ) + rdat % fq0 ( i ) * work ( j ) end do end do do i = 1 , 8 fwk ( 1 , i ) =- rdat % fq1 ( 1 , i ) * rdat % aqx fwk ( 2 , i ) =- rdat % fq1 ( 1 , i ) * rdat % acy fwk ( 3 , i ) = rdat % fq1 ( 2 , i ) enddo fqd11 = rdat % fq1 ( 1 , 5 ) * rdat % rab + rdat % fq1 ( 1 , 8 ) fqd12 = rdat % fq1 ( 2 , 5 ) * rdat % rab + rdat % fq1 ( 2 , 8 ) fwk ( 1 , 9 ) =- fqd11 * rdat % aqx fwk ( 2 , 9 ) =- fqd11 * rdat % acy fwk ( 3 , 9 ) = fqd12 do i = 1 , 4 rdat % r01 ( 1 , i ) = rdat % r01 ( 1 , i ) + fwk ( 1 , 1 ) * work ( i + 5 ) rdat % r01 ( 2 , i ) = rdat % r01 ( 2 , i ) + fwk ( 2 , 1 ) * work ( i + 5 ) rdat % r01 ( 3 , i ) = rdat % r01 ( 3 , i ) + fwk ( 3 , 1 ) * work ( i + 5 ) enddo do i = 5 , 8 rdat % r01 ( 1 , i ) = rdat % r01 ( 1 , i ) + fwk ( 1 , 2 ) * work ( i + 1 ) rdat % r01 ( 2 , i ) = rdat % r01 ( 2 , i ) + fwk ( 2 , 2 ) * work ( i + 1 ) rdat % r01 ( 3 , i ) = rdat % r01 ( 3 , i ) + fwk ( 3 , 2 ) * work ( i + 1 ) enddo do i = 9 , 12 rdat % r01 ( 1 , i ) = rdat % r01 ( 1 , i ) + fwk ( 1 , 3 ) * work ( i - 3 ) rdat % r01 ( 2 , i ) = rdat % r01 ( 2 , i ) + fwk ( 2 , 3 ) * work ( i - 3 ) rdat % r01 ( 3 , i ) = rdat % r01 ( 3 , i ) + fwk ( 3 , 3 ) * work ( i - 3 ) enddo do i = 13 , 16 rdat % r01 ( 1 , i ) = rdat % r01 ( 1 , i ) + fwk ( 1 , 4 ) * work ( i - 7 ) rdat % r01 ( 2 , i ) = rdat % r01 ( 2 , i ) + fwk ( 2 , 4 ) * work ( i - 7 ) rdat % r01 ( 3 , i ) = rdat % r01 ( 3 , i ) + fwk ( 3 , 4 ) * work ( i - 7 ) enddo do i = 17 , 20 rdat % r01 ( 1 , i ) = rdat % r01 ( 1 , i ) + fwk ( 1 , 5 ) * work ( i - 11 ) rdat % r01 ( 2 , i ) = rdat % r01 ( 2 , i ) + fwk ( 2 , 5 ) * work ( i - 11 ) rdat % r01 ( 3 , i ) = rdat % r01 ( 3 , i ) + fwk ( 3 , 5 ) * work ( i - 11 ) enddo do i = 21 , 25 rdat % r01 ( 1 , i ) = rdat % r01 ( 1 , i ) + fwk ( 1 , 6 ) * work ( i - 20 ) rdat % r01 ( 2 , i ) = rdat % r01 ( 2 , i ) + fwk ( 2 , 6 ) * work ( i - 20 ) rdat % r01 ( 3 , i ) = rdat % r01 ( 3 , i ) + fwk ( 3 , 6 ) * work ( i - 20 ) enddo do i = 26 , 30 rdat % r01 ( 1 , i ) = rdat % r01 ( 1 , i ) + fwk ( 1 , 7 ) * work ( i - 25 ) rdat % r01 ( 2 , i ) = rdat % r01 ( 2 , i ) + fwk ( 2 , 7 ) * work ( i - 25 ) rdat % r01 ( 3 , i ) = rdat % r01 ( 3 , i ) + fwk ( 3 , 7 ) * work ( i - 25 ) enddo do i = 31 , 35 rdat % r01 ( 1 , i ) = rdat % r01 ( 1 , i ) + fwk ( 1 , 8 ) * work ( i - 30 ) rdat % r01 ( 2 , i ) = rdat % r01 ( 2 , i ) + fwk ( 2 , 8 ) * work ( i - 30 ) rdat % r01 ( 3 , i ) = rdat % r01 ( 3 , i ) + fwk ( 3 , 8 ) * work ( i - 30 ) enddo do i = 36 , 40 rdat % r01 ( 1 , i ) = rdat % r01 ( 1 , i ) + fwk ( 1 , 9 ) * work ( i - 35 ) rdat % r01 ( 2 , i ) = rdat % r01 ( 2 , i ) + fwk ( 2 , 9 ) * work ( i - 35 ) rdat % r01 ( 3 , i ) = rdat % r01 ( 3 , i ) + fwk ( 3 , 9 ) * work ( i - 35 ) enddo do i = 1 , 9 fwk ( 1 , i ) = rdat % fq2 ( 1 , i ) * rdat % aqx2 - rdat % fq1 ( 1 , i ) fwk ( 2 , i ) = rdat % fq2 ( 1 , i ) * rdat % acy2 - rdat % fq1 ( 1 , i ) fwk ( 3 , i ) = rdat % fq2 ( 3 , i ) - rdat % fq1 ( 1 , i ) fwk ( 4 , i ) = rdat % fq2 ( 1 , i ) * rdat % aqxy fwk ( 5 , i ) =- rdat % fq2 ( 2 , i ) * rdat % aqx fwk ( 6 , i ) =- rdat % fq2 ( 2 , i ) * rdat % acy enddo fqd21 = rdat % fq2 ( 1 , 5 ) * rdat % rab + rdat % fq2 ( 1 , 8 ) fqd22 = rdat % fq2 ( 2 , 5 ) * rdat % rab + rdat % fq2 ( 2 , 8 ) fqd23 = rdat % fq2 ( 3 , 5 ) * rdat % rab + rdat % fq2 ( 3 , 8 ) fwk ( 1 , 10 ) = fqd21 * rdat % aqx2 - fqd11 fwk ( 2 , 10 ) = fqd21 * rdat % acy2 - fqd11 fwk ( 3 , 10 ) = fqd23 - fqd11 fwk ( 4 , 10 ) = fqd21 * rdat % aqxy fwk ( 5 , 10 ) =- fqd22 * rdat % aqx fwk ( 6 , 10 ) =- fqd22 * rdat % acy do i = 1 , 3 do j = 1 , 6 rdat % r02 ( j , i ) = rdat % r02 ( j , i ) + fwk ( j , 1 ) * work ( i + 9 ) enddo enddo do i = 4 , 6 do j = 1 , 6 rdat % r02 ( j , i ) = rdat % r02 ( j , i ) + fwk ( j , 2 ) * work ( i + 6 ) enddo enddo do i = 7 , 9 do j = 1 , 6 rdat % r02 ( j , i ) = rdat % r02 ( j , i ) + fwk ( j , 3 ) * work ( i + 3 ) enddo enddo do i = 10 , 12 do j = 1 , 6 rdat % r02 ( j , i ) = rdat % r02 ( j , i ) + fwk ( j , 4 ) * work ( i ) enddo enddo do i = 13 , 15 do j = 1 , 6 rdat % r02 ( j , i ) = rdat % r02 ( j , i ) + fwk ( j , 5 ) * work ( i - 3 ) enddo enddo do i = 16 , 19 do j = 1 , 6 rdat % r02 ( j , i ) = rdat % r02 ( j , i ) + fwk ( j , 6 ) * work ( i - 10 ) enddo enddo do i = 20 , 23 do j = 1 , 6 rdat % r02 ( j , i ) = rdat % r02 ( j , i ) + fwk ( j , 7 ) * work ( i - 14 ) enddo enddo do i = 24 , 27 do j = 1 , 6 rdat % r02 ( j , i ) = rdat % r02 ( j , i ) + fwk ( j , 8 ) * work ( i - 18 ) enddo enddo do i = 28 , 31 do j = 1 , 6 rdat % r02 ( j , i ) = rdat % r02 ( j , i ) + fwk ( j , 10 ) * work ( i - 22 ) enddo enddo do i = 32 , 36 do j = 1 , 6 rdat % r02 ( j , i ) = rdat % r02 ( j , i ) + fwk ( j , 9 ) * work ( i - 31 ) enddo enddo do i = 1 , 5 rdat % r03 ( 1 , i ) = rdat % r03 ( 1 , i ) + ( rdat % fq3 ( 1 , i ) * rdat % aqx2 - rdat % fq2 ( 1 , i ) * 3 ) * xmdtx rdat % r03 ( 2 , i ) = rdat % r03 ( 2 , i ) + ( rdat % fq3 ( 1 , i ) * rdat % aqx2 - rdat % fq2 ( 1 , i ) ) * xmdty rdat % r03 ( 3 , i ) = rdat % r03 ( 3 , i ) + ( rdat % fq3 ( 2 , i ) * rdat % aqx2 - rdat % fq2 ( 2 , i ) ) * xmdt rdat % r03 ( 4 , i ) = rdat % r03 ( 4 , i ) + ( rdat % fq3 ( 1 , i ) * rdat % acy2 - rdat % fq2 ( 1 , i ) ) * xmdtx rdat % r03 ( 5 , i ) = rdat % r03 ( 5 , i ) + rdat % fq3 ( 2 , i ) * xmdtxy rdat % r03 ( 6 , i ) = rdat % r03 ( 6 , i ) + ( rdat % fq3 ( 3 , i ) - rdat % fq2 ( 1 , i ) ) * xmdtx rdat % r03 ( 7 , i ) = rdat % r03 ( 7 , i ) + ( rdat % fq3 ( 1 , i ) * rdat % acy2 - rdat % fq2 ( 1 , i ) * 3 ) * xmdty rdat % r03 ( 8 , i ) = rdat % r03 ( 8 , i ) + ( rdat % fq3 ( 2 , i ) * rdat % acy2 - rdat % fq2 ( 2 , i ) ) * xmdt rdat % r03 ( 9 , i ) = rdat % r03 ( 9 , i ) + ( rdat % fq3 ( 3 , i ) - rdat % fq2 ( 1 , i ) ) * xmdty rdat % r03 ( 10 , i ) = rdat % r03 ( 10 , i ) + ( rdat % fq3 ( 4 , i ) - rdat % fq2 ( 2 , i ) * 3 ) * xmdt enddo rdat % fq2 ( 1 , 5 ) = fqd21 rdat % fq2 ( 2 , 5 ) = fqd22 rdat % fq3 ( 1 , 5 ) = rdat % fq3 ( 1 , 5 ) * rdat % rab + rdat % fq3 ( 1 , 8 ) rdat % fq3 ( 2 , 5 ) = rdat % fq3 ( 2 , 5 ) * rdat % rab + rdat % fq3 ( 2 , 8 ) rdat % fq3 ( 3 , 5 ) = rdat % fq3 ( 3 , 5 ) * rdat % rab + rdat % fq3 ( 3 , 8 ) rdat % fq3 ( 4 , 5 ) = rdat % fq3 ( 4 , 5 ) * rdat % rab + rdat % fq3 ( 4 , 8 ) do i = 5 , 9 fwk ( 1 , i ) =- ( rdat % fq3 ( 1 , i ) * rdat % aqx2 - rdat % fq2 ( 1 , i ) * 3 ) * rdat % aqx fwk ( 2 , i ) =- ( rdat % fq3 ( 1 , i ) * rdat % aqx2 - rdat % fq2 ( 1 , i ) ) * rdat % acy fwk ( 3 , i ) = rdat % fq3 ( 2 , i ) * rdat % aqx2 - rdat % fq2 ( 2 , i ) fwk ( 4 , i ) =- ( rdat % fq3 ( 1 , i ) * rdat % acy2 - rdat % fq2 ( 1 , i ) ) * rdat % aqx fwk ( 5 , i ) = rdat % fq3 ( 2 , i ) * rdat % aqxy fwk ( 6 , i ) =- ( rdat % fq3 ( 3 , i ) - rdat % fq2 ( 1 , i ) ) * rdat % aqx fwk ( 7 , i ) =- ( rdat % fq3 ( 1 , i ) * rdat % acy2 - rdat % fq2 ( 1 , i ) * 3 ) * rdat % acy fwk ( 8 , i ) = rdat % fq3 ( 2 , i ) * rdat % acy2 - rdat % fq2 ( 2 , i ) fwk ( 9 , i ) =- ( rdat % fq3 ( 3 , i ) - rdat % fq2 ( 1 , i ) ) * rdat % acy fwk ( 10 , i ) = rdat % fq3 ( 4 , i ) - rdat % fq2 ( 2 , i ) * 3 enddo do i = 6 , 8 do j = 1 , 10 rdat % r03 ( j , i ) = rdat % r03 ( j , i ) + fwk ( j , 5 ) * work ( i + 4 ) enddo enddo do i = 9 , 11 do j = 1 , 10 rdat % r03 ( j , i ) = rdat % r03 ( j , i ) + fwk ( j , 6 ) * work ( i + 1 ) enddo enddo do i = 12 , 14 do j = 1 , 10 rdat % r03 ( j , i ) = rdat % r03 ( j , i ) + fwk ( j , 7 ) * work ( i - 2 ) enddo enddo do i = 15 , 17 do j = 1 , 10 rdat % r03 ( j , i ) = rdat % r03 ( j , i ) + fwk ( j , 8 ) * work ( i - 5 ) enddo enddo do i = 18 , 21 do j = 1 , 10 rdat % r03 ( j , i ) = rdat % r03 ( j , i ) + fwk ( j , 9 ) * work ( i - 12 ) enddo enddo do j = 1 , 5 rdat % fq4 ( j , 1 ) = rdat % fq4 ( j , 1 ) * rdat % rab + rdat % fq4 ( j , 4 ) enddo aqx4 = rdat % aqx2 * rdat % aqx2 acy4 = rdat % acy2 * rdat % acy2 x2y2 = rdat % aqx2 * rdat % acy2 q2c2 = rdat % aqx2 + rdat % acy2 do i = 1 , 4 rdat % r04 ( 1 , i ) = rdat % r04 ( 1 , i ) + ( rdat % fq4 ( 1 , i ) * aqx4 - rdat % fq3 ( 1 , i + 4 ) * 6 * rdat % aqx2 & & + rdat % fq2 ( 1 , i + 4 ) * 3 ) * xmdt rdat % r04 ( 2 , i ) = rdat % r04 ( 2 , i ) + ( rdat % fq4 ( 1 , i ) * rdat % aqx2 - rdat % fq3 ( 1 , i + 4 ) * 3 ) * xmdtxy rdat % r04 ( 3 , i ) = rdat % r04 ( 3 , i ) + ( rdat % fq4 ( 2 , i ) * rdat % aqx2 - rdat % fq3 ( 2 , i + 4 ) * 3 ) * xmdtx rdat % r04 ( 4 , i ) = rdat % r04 ( 4 , i ) + ( rdat % fq4 ( 1 , i ) * x2y2 - rdat % fq3 ( 1 , i + 4 ) * q2c2 & & + rdat % fq2 ( 1 , i + 4 ) ) * xmdt rdat % r04 ( 5 , i ) = rdat % r04 ( 5 , i ) + ( rdat % fq4 ( 2 , i ) * rdat % aqx2 - rdat % fq3 ( 2 , i + 4 ) ) * xmdty rdat % r04 ( 6 , i ) = rdat % r04 ( 6 , i ) + ( rdat % fq4 ( 3 , i ) * rdat % aqx2 - rdat % fq3 ( 1 , i + 4 ) * rdat % aqx2 & & - rdat % fq3 ( 3 , i + 4 ) + rdat % fq2 ( 1 , i + 4 ) ) * xmdt rdat % r04 ( 7 , i ) = rdat % r04 ( 7 , i ) + ( rdat % fq4 ( 1 , i ) * rdat % acy2 - rdat % fq3 ( 1 , i + 4 ) * 3 ) * xmdtxy rdat % r04 ( 8 , i ) = rdat % r04 ( 8 , i ) + ( rdat % fq4 ( 2 , i ) * rdat % acy2 - rdat % fq3 ( 2 , i + 4 ) ) * xmdtx rdat % r04 ( 9 , i ) = rdat % r04 ( 9 , i ) + ( rdat % fq4 ( 3 , i ) - rdat % fq3 ( 1 , i + 4 ) ) * xmdtxy rdat % r04 ( 10 , i ) = rdat % r04 ( 10 , i ) + ( rdat % fq4 ( 4 , i ) - rdat % fq3 ( 2 , i + 4 ) * 3 ) * xmdtx rdat % r04 ( 11 , i ) = rdat % r04 ( 11 , i ) + ( rdat % fq4 ( 1 , i ) * acy4 - rdat % fq3 ( 1 , i + 4 ) * 6 * rdat % acy2 & & + rdat % fq2 ( 1 , i + 4 ) * 3 ) * xmdt rdat % r04 ( 12 , i ) = rdat % r04 ( 12 , i ) + ( rdat % fq4 ( 2 , i ) * rdat % acy2 - rdat % fq3 ( 2 , i + 4 ) * 3 ) * xmdty rdat % r04 ( 13 , i ) = rdat % r04 ( 13 , i ) + ( rdat % fq4 ( 3 , i ) * rdat % acy2 - rdat % fq3 ( 1 , i + 4 ) * rdat % acy2 & & - rdat % fq3 ( 3 , i + 4 ) + rdat % fq2 ( 1 , i + 4 ) ) * xmdt rdat % r04 ( 14 , i ) = rdat % r04 ( 14 , i ) + ( rdat % fq4 ( 4 , i ) - rdat % fq3 ( 2 , i + 4 ) * 3 ) * xmdty rdat % r04 ( 15 , i ) = rdat % r04 ( 15 , i ) + ( rdat % fq4 ( 5 , i ) - rdat % fq3 ( 3 , i + 4 ) * 6 & & + rdat % fq2 ( 1 , i + 4 ) * 3 ) * xmdt enddo fwk ( 1 , 5 ) = rdat % fq4 ( 1 , 5 ) * aqx4 - rdat % fq3 ( 1 , 9 ) * 6 * rdat % aqx2 + rdat % fq2 ( 1 , 9 ) * 3 fwk ( 2 , 5 ) = ( rdat % fq4 ( 1 , 5 ) * rdat % aqx2 - rdat % fq3 ( 1 , 9 ) * 3 ) * rdat % aqxy fwk ( 3 , 5 ) =- ( rdat % fq4 ( 2 , 5 ) * rdat % aqx2 - rdat % fq3 ( 2 , 9 ) * 3 ) * rdat % aqx fwk ( 4 , 5 ) = rdat % fq4 ( 1 , 5 ) * x2y2 - rdat % fq3 ( 1 , 9 ) * q2c2 + rdat % fq2 ( 1 , 9 ) fwk ( 5 , 5 ) =- ( rdat % fq4 ( 2 , 5 ) * rdat % aqx2 - rdat % fq3 ( 2 , 9 ) ) * rdat % acy fwk ( 6 , 5 ) = rdat % fq4 ( 3 , 5 ) * rdat % aqx2 - rdat % fq3 ( 1 , 9 ) * rdat % aqx2 - rdat % fq3 ( 3 , 9 ) + rdat % fq2 ( 1 , 9 ) fwk ( 7 , 5 ) = ( rdat % fq4 ( 1 , 5 ) * rdat % acy2 - rdat % fq3 ( 1 , 9 ) * 3 ) * rdat % aqxy fwk ( 8 , 5 ) =- ( rdat % fq4 ( 2 , 5 ) * rdat % acy2 - rdat % fq3 ( 2 , 9 ) ) * rdat % aqx fwk ( 9 , 5 ) = ( rdat % fq4 ( 3 , 5 ) - rdat % fq3 ( 1 , 9 ) ) * rdat % aqxy fwk ( 10 , 5 ) =- ( rdat % fq4 ( 4 , 5 ) - rdat % fq3 ( 2 , 9 ) * 3 ) * rdat % aqx fwk ( 11 , 5 ) = rdat % fq4 ( 1 , 5 ) * acy4 - rdat % fq3 ( 1 , 9 ) * 6 * rdat % acy2 + rdat % fq2 ( 1 , 9 ) * 3 fwk ( 12 , 5 ) =- ( rdat % fq4 ( 2 , 5 ) * rdat % acy2 - rdat % fq3 ( 2 , 9 ) * 3 ) * rdat % acy fwk ( 13 , 5 ) = rdat % fq4 ( 3 , 5 ) * rdat % acy2 - rdat % fq3 ( 1 , 9 ) * rdat % acy2 - rdat % fq3 ( 3 , 9 ) + rdat % fq2 ( 1 , 9 ) fwk ( 14 , 5 ) =- ( rdat % fq4 ( 4 , 5 ) - rdat % fq3 ( 2 , 9 ) * 3 ) * rdat % acy fwk ( 15 , 5 ) = rdat % fq4 ( 5 , 5 ) - rdat % fq3 ( 3 , 9 ) * 6 + rdat % fq2 ( 1 , 9 ) * 3 do i = 5 , 7 do j = 1 , 15 rdat % r04 ( j , i ) = rdat % r04 ( j , i ) + fwk ( j , 5 ) * work ( i + 5 ) end do end do rdat % r05 ( 1 , 1 ) = rdat % r05 ( 1 , 1 ) + ( rdat % fq5 ( 1 , 1 ) * aqx4 - rdat % fq4 ( 1 , 5 ) * 10 * rdat % aqx2 & & + rdat % fq3 ( 1 , 9 ) * 15 ) * xmdtx rdat % r05 ( 2 , 1 ) = rdat % r05 ( 2 , 1 ) + ( rdat % fq5 ( 1 , 1 ) * aqx4 - rdat % fq4 ( 1 , 5 ) * 6 * rdat % aqx2 & & + rdat % fq3 ( 1 , 9 ) * 3 ) * xmdty rdat % r05 ( 3 , 1 ) = rdat % r05 ( 3 , 1 ) + ( rdat % fq5 ( 2 , 1 ) * aqx4 - rdat % fq4 ( 2 , 5 ) * 6 * rdat % aqx2 & & + rdat % fq3 ( 2 , 9 ) * 3 ) * xmdt rdat % r05 ( 4 , 1 ) = rdat % r05 ( 4 , 1 ) + ( rdat % fq5 ( 1 , 1 ) * x2y2 - rdat % fq4 ( 1 , 5 ) * rdat % aqx2 - rdat % fq4 ( 1 , 5 ) * 3 * rdat % acy2 & & + rdat % fq3 ( 1 , 9 ) * 3 ) * xmdtx rdat % r05 ( 5 , 1 ) = rdat % r05 ( 5 , 1 ) + ( rdat % fq5 ( 2 , 1 ) * rdat % aqx2 - rdat % fq4 ( 2 , 5 ) * 3 ) * xmdtxy rdat % r05 ( 6 , 1 ) = rdat % r05 ( 6 , 1 ) + ( rdat % fq5 ( 3 , 1 ) * rdat % aqx2 - rdat % fq4 ( 1 , 5 ) * rdat % aqx2 - rdat % fq4 ( 3 , 5 ) * 3 & & + rdat % fq3 ( 1 , 9 ) * 3 ) * xmdtx rdat % r05 ( 7 , 1 ) = rdat % r05 ( 7 , 1 ) + ( rdat % fq5 ( 1 , 1 ) * x2y2 - rdat % fq4 ( 1 , 5 ) * 3 * rdat % aqx2 - rdat % fq4 ( 1 , 5 ) * rdat % acy2 & & + rdat % fq3 ( 1 , 9 ) * 3 ) * xmdty rdat % r05 ( 8 , 1 ) = rdat % r05 ( 8 , 1 ) + ( rdat % fq5 ( 2 , 1 ) * x2y2 - rdat % fq4 ( 2 , 5 ) * q2c2 + rdat % fq3 ( 2 , 9 ) ) * xmdt rdat % r05 ( 9 , 1 ) = rdat % r05 ( 9 , 1 ) + ( rdat % fq5 ( 3 , 1 ) * rdat % aqx2 - rdat % fq4 ( 1 , 5 ) * rdat % aqx2 - rdat % fq4 ( 3 , 5 ) & & + rdat % fq3 ( 1 , 9 ) ) * xmdty rdat % r05 ( 10 , 1 ) = rdat % r05 ( 10 , 1 ) + ( rdat % fq5 ( 4 , 1 ) * rdat % aqx2 - rdat % fq4 ( 2 , 5 ) * 3 * rdat % aqx2 - rdat % fq4 ( 4 , 5 ) & & + rdat % fq3 ( 2 , 9 ) * 3 ) * xmdt rdat % r05 ( 11 , 1 ) = rdat % r05 ( 11 , 1 ) + ( rdat % fq5 ( 1 , 1 ) * acy4 - rdat % fq4 ( 1 , 5 ) * 6 * rdat % acy2 & & + rdat % fq3 ( 1 , 9 ) * 3 ) * xmdtx rdat % r05 ( 12 , 1 ) = rdat % r05 ( 12 , 1 ) + ( rdat % fq5 ( 2 , 1 ) * rdat % acy2 - rdat % fq4 ( 2 , 5 ) * 3 ) * xmdtxy rdat % r05 ( 13 , 1 ) = rdat % r05 ( 13 , 1 ) + ( rdat % fq5 ( 3 , 1 ) * rdat % acy2 - rdat % fq4 ( 1 , 5 ) * rdat % acy2 - rdat % fq4 ( 3 , 5 ) & & + rdat % fq3 ( 1 , 9 ) ) * xmdtx rdat % r05 ( 14 , 1 ) = rdat % r05 ( 14 , 1 ) + ( rdat % fq5 ( 4 , 1 ) - rdat % fq4 ( 2 , 5 ) * 3 ) * xmdtxy rdat % r05 ( 15 , 1 ) = rdat % r05 ( 15 , 1 ) + ( rdat % fq5 ( 5 , 1 ) - rdat % fq4 ( 3 , 5 ) * 6 + rdat % fq3 ( 1 , 9 ) * 3 ) * xmdtx rdat % r05 ( 16 , 1 ) = rdat % r05 ( 16 , 1 ) + ( rdat % fq5 ( 1 , 1 ) * acy4 - rdat % fq4 ( 1 , 5 ) * 10 * rdat % acy2 & & + rdat % fq3 ( 1 , 9 ) * 15 ) * xmdty rdat % r05 ( 17 , 1 ) = rdat % r05 ( 17 , 1 ) + ( rdat % fq5 ( 2 , 1 ) * acy4 - rdat % fq4 ( 2 , 5 ) * 6 * rdat % acy2 & & + rdat % fq3 ( 2 , 9 ) * 3 ) * xmdt rdat % r05 ( 18 , 1 ) = rdat % r05 ( 18 , 1 ) + ( rdat % fq5 ( 3 , 1 ) * rdat % acy2 - rdat % fq4 ( 1 , 5 ) * rdat % acy2 - rdat % fq4 ( 3 , 5 ) * 3 & & + rdat % fq3 ( 1 , 9 ) * 3 ) * xmdty rdat % r05 ( 19 , 1 ) = rdat % r05 ( 19 , 1 ) + ( rdat % fq5 ( 4 , 1 ) * rdat % acy2 - rdat % fq4 ( 2 , 5 ) * 3 * rdat % acy2 - rdat % fq4 ( 4 , 5 ) & & + rdat % fq3 ( 2 , 9 ) * 3 ) * xmdt rdat % r05 ( 20 , 1 ) = rdat % r05 ( 20 , 1 ) + ( rdat % fq5 ( 5 , 1 ) - rdat % fq4 ( 3 , 5 ) * 6 + rdat % fq3 ( 1 , 9 ) * 3 ) * xmdty rdat % r05 ( 21 , 1 ) = rdat % r05 ( 21 , 1 ) + ( rdat % fq5 ( 6 , 1 ) - rdat % fq4 ( 4 , 5 ) * 10 + rdat % fq3 ( 2 , 9 ) * 15 ) * xmdt end subroutine intk_16 ! > ! >    @brief   ddds case ! > ! >    @details integration of the ddds case ! > subroutine intk_17 ( rdat , ikl ) implicit none type ( rotaxis_data_t ) :: rdat integer :: ikl real ( kind = dp ) :: xmd2 , xmd3 , xmd4 , xmd6 real ( kind = dp ) :: xmdt , xmdtx , xmdtxy , xmdty real ( kind = dp ) :: aqx4 , acy4 , q2c2 , x2y2 real ( kind = dp ) :: y33 , y34 , y44 real ( kind = dp ) :: work , fwk , fw6 , fcu , fcc integer :: i , j ! Generate jtype=17 integrals dimension work ( 15 ), fwk ( 21 , 4 ), fw6 ( 28 ) dimension fcu ( 45 , 8 ), fcc ( 45 , 8 ) if ( ikl == 0 ) then rdat % r00 (:, 1 : 2 ) = 0.0_dp rdat % r01 (:, 1 : 13 ) = 0.0_dp rdat % r02 (:, 1 : 17 ) = 0.0_dp rdat % r03 (:, 1 : 12 ) = 0.0_dp rdat % r04 (:, 1 : 8 ) = 0.0_dp rdat % r05 (:, 1 : 3 ) = 0.0_dp rdat % r06 ( 1 : 28 , 1 ) = 0.0_dp return endif xmd2 = rdat % x43 * 0.5d+00 xmd3 = xmd2 xmd4 = xmd3 * xmd2 xmd6 = xmd4 * xmd2 xmdt = xmd6 * xmd2 xmd2 = xmd3 xmdty =- xmdt * rdat % acy xmdtx =- xmdt * rdat % aqx xmdtxy = xmdt * rdat % aqxy y33 = rdat % y03 * rdat % y03 y34 =- rdat % y03 * rdat % y04 y44 = rdat % y04 * rdat % y04 work ( 1 ) = xmd4 work ( 2 ) = xmd2 * y33 work ( 3 ) = xmd2 * y34 work ( 4 ) = xmd2 * y44 work ( 5 ) = y33 * y44 work ( 6 ) =- xmd4 * rdat % y03 work ( 7 ) = xmd4 * rdat % y04 work ( 8 ) = xmd2 * y33 * rdat % y04 work ( 9 ) = xmd2 * y34 * rdat % y04 work ( 10 ) = xmd6 work ( 11 ) = xmd4 * y33 work ( 12 ) = xmd4 * y34 work ( 13 ) = xmd4 * y44 work ( 14 ) =- xmd6 * rdat % y03 work ( 15 ) = xmd6 * rdat % y04 call fcufcc ( rdat , 6 , xmdt , fcu , fcc ) do i = 1 , 2 do j = 1 , 5 rdat % r00 ( j , i ) = rdat % r00 ( j , i ) + rdat % fq0 ( i ) * work ( j ) end do end do do i = 1 , 3 fwk ( 1 , i ) =- rdat % fq1 ( 1 , i ) * rdat % aqx fwk ( 2 , i ) =- rdat % fq1 ( 1 , i ) * rdat % acy fwk ( 3 , i ) = rdat % fq1 ( 2 , i ) enddo do i = 1 , 4 rdat % r01 ( 1 , i ) = rdat % r01 ( 1 , i ) + fwk ( 1 , 1 ) * work ( i + 5 ) rdat % r01 ( 2 , i ) = rdat % r01 ( 2 , i ) + fwk ( 2 , 1 ) * work ( i + 5 ) rdat % r01 ( 3 , i ) = rdat % r01 ( 3 , i ) + fwk ( 3 , 1 ) * work ( i + 5 ) enddo do i = 5 , 8 rdat % r01 ( 1 , i ) = rdat % r01 ( 1 , i ) + fwk ( 1 , 2 ) * work ( i + 1 ) rdat % r01 ( 2 , i ) = rdat % r01 ( 2 , i ) + fwk ( 2 , 2 ) * work ( i + 1 ) rdat % r01 ( 3 , i ) = rdat % r01 ( 3 , i ) + fwk ( 3 , 2 ) * work ( i + 1 ) enddo do i = 9 , 13 rdat % r01 ( 1 , i ) = rdat % r01 ( 1 , i ) + fwk ( 1 , 3 ) * work ( i - 8 ) rdat % r01 ( 2 , i ) = rdat % r01 ( 2 , i ) + fwk ( 2 , 3 ) * work ( i - 8 ) rdat % r01 ( 3 , i ) = rdat % r01 ( 3 , i ) + fwk ( 3 , 3 ) * work ( i - 8 ) enddo do i = 1 , 4 fwk ( 1 , i ) = rdat % fq2 ( 1 , i ) * rdat % aqx2 - rdat % fq1 ( 1 , i ) fwk ( 2 , i ) = rdat % fq2 ( 1 , i ) * rdat % acy2 - rdat % fq1 ( 1 , i ) fwk ( 3 , i ) = rdat % fq2 ( 3 , i ) - rdat % fq1 ( 1 , i ) fwk ( 4 , i ) = rdat % fq2 ( 1 , i ) * rdat % aqxy fwk ( 5 , i ) =- rdat % fq2 ( 2 , i ) * rdat % aqx fwk ( 6 , i ) =- rdat % fq2 ( 2 , i ) * rdat % acy enddo do i = 1 , 4 do j = 1 , 6 rdat % r02 ( j , i ) = rdat % r02 ( j , i ) + fwk ( j , 1 ) * work ( i + 9 ) enddo enddo do i = 5 , 8 do j = 1 , 6 rdat % r02 ( j , i ) = rdat % r02 ( j , i ) + fwk ( j , 2 ) * work ( i + 5 ) enddo enddo do i = 9 , 12 do j = 1 , 6 rdat % r02 ( j , i ) = rdat % r02 ( j , i ) + fwk ( j , 3 ) * work ( i - 3 ) enddo enddo do i = 13 , 17 do j = 1 , 6 rdat % r02 ( j , i ) = rdat % r02 ( j , i ) + fwk ( j , 4 ) * work ( i - 12 ) enddo enddo do i = 1 , 4 fwk ( 1 , i ) =- ( rdat % fq3 ( 1 , i ) * rdat % aqx2 - rdat % fq2 ( 1 , i ) * 3 ) * rdat % aqx fwk ( 2 , i ) =- ( rdat % fq3 ( 1 , i ) * rdat % aqx2 - rdat % fq2 ( 1 , i ) ) * rdat % acy fwk ( 3 , i ) = rdat % fq3 ( 2 , i ) * rdat % aqx2 - rdat % fq2 ( 2 , i ) fwk ( 4 , i ) =- ( rdat % fq3 ( 1 , i ) * rdat % acy2 - rdat % fq2 ( 1 , i ) ) * rdat % aqx fwk ( 5 , i ) = rdat % fq3 ( 2 , i ) * rdat % aqxy fwk ( 6 , i ) =- ( rdat % fq3 ( 3 , i ) - rdat % fq2 ( 1 , i ) ) * rdat % aqx fwk ( 7 , i ) =- ( rdat % fq3 ( 1 , i ) * rdat % acy2 - rdat % fq2 ( 1 , i ) * 3 ) * rdat % acy fwk ( 8 , i ) = rdat % fq3 ( 2 , i ) * rdat % acy2 - rdat % fq2 ( 2 , i ) fwk ( 9 , i ) =- ( rdat % fq3 ( 3 , i ) - rdat % fq2 ( 1 , i ) ) * rdat % acy fwk ( 10 , i ) = rdat % fq3 ( 4 , i ) - rdat % fq2 ( 2 , i ) * 3 enddo do i = 1 , 2 do j = 1 , 10 rdat % r03 ( j , i ) = rdat % r03 ( j , i ) + fwk ( j , 1 ) * work ( i + 13 ) enddo enddo do i = 3 , 4 do j = 1 , 10 rdat % r03 ( j , i ) = rdat % r03 ( j , i ) + fwk ( j , 2 ) * work ( i + 11 ) enddo enddo do i = 5 , 8 do j = 1 , 10 rdat % r03 ( j , i ) = rdat % r03 ( j , i ) + fwk ( j , 3 ) * work ( i + 5 ) enddo enddo do i = 9 , 12 do j = 1 , 10 rdat % r03 ( j , i ) = rdat % r03 ( j , i ) + fwk ( j , 4 ) * work ( i - 3 ) enddo enddo aqx4 = rdat % aqx2 * rdat % aqx2 acy4 = rdat % acy2 * rdat % acy2 x2y2 = rdat % aqx2 * rdat % acy2 q2c2 = rdat % aqx2 + rdat % acy2 do i = 1 , 2 rdat % r04 ( 1 , i ) = rdat % r04 ( 1 , i ) + ( rdat % fq4 ( 1 , i ) * aqx4 - rdat % fq3 ( 1 , i ) * 6 * rdat % aqx2 & & + rdat % fq2 ( 1 , i ) * 3 ) * xmdt rdat % r04 ( 2 , i ) = rdat % r04 ( 2 , i ) + ( rdat % fq4 ( 1 , i ) * rdat % aqx2 - rdat % fq3 ( 1 , i ) * 3 ) * xmdtxy rdat % r04 ( 3 , i ) = rdat % r04 ( 3 , i ) + ( rdat % fq4 ( 2 , i ) * rdat % aqx2 - rdat % fq3 ( 2 , i ) * 3 ) * xmdtx rdat % r04 ( 4 , i ) = rdat % r04 ( 4 , i ) + ( rdat % fq4 ( 1 , i ) * x2y2 - rdat % fq3 ( 1 , i ) * q2c2 & & + rdat % fq2 ( 1 , i ) ) * xmdt rdat % r04 ( 5 , i ) = rdat % r04 ( 5 , i ) + ( rdat % fq4 ( 2 , i ) * rdat % aqx2 - rdat % fq3 ( 2 , i ) ) * xmdty rdat % r04 ( 6 , i ) = rdat % r04 ( 6 , i ) + ( rdat % fq4 ( 3 , i ) * rdat % aqx2 - rdat % fq3 ( 1 , i ) * rdat % aqx2 & & - rdat % fq3 ( 3 , i ) + rdat % fq2 ( 1 , i ) ) * xmdt rdat % r04 ( 7 , i ) = rdat % r04 ( 7 , i ) + ( rdat % fq4 ( 1 , i ) * rdat % acy2 - rdat % fq3 ( 1 , i ) * 3 ) * xmdtxy rdat % r04 ( 8 , i ) = rdat % r04 ( 8 , i ) + ( rdat % fq4 ( 2 , i ) * rdat % acy2 - rdat % fq3 ( 2 , i ) ) * xmdtx rdat % r04 ( 9 , i ) = rdat % r04 ( 9 , i ) + ( rdat % fq4 ( 3 , i ) - rdat % fq3 ( 1 , i ) ) * xmdtxy rdat % r04 ( 10 , i ) = rdat % r04 ( 10 , i ) + ( rdat % fq4 ( 4 , i ) - rdat % fq3 ( 2 , i ) * 3 ) * xmdtx rdat % r04 ( 11 , i ) = rdat % r04 ( 11 , i ) + ( rdat % fq4 ( 1 , i ) * acy4 - rdat % fq3 ( 1 , i ) * 6 * rdat % acy2 & & + rdat % fq2 ( 1 , i ) * 3 ) * xmdt rdat % r04 ( 12 , i ) = rdat % r04 ( 12 , i ) + ( rdat % fq4 ( 2 , i ) * rdat % acy2 - rdat % fq3 ( 2 , i ) * 3 ) * xmdty rdat % r04 ( 13 , i ) = rdat % r04 ( 13 , i ) + ( rdat % fq4 ( 3 , i ) * rdat % acy2 - rdat % fq3 ( 1 , i ) * rdat % acy2 & & - rdat % fq3 ( 3 , i ) + rdat % fq2 ( 1 , i ) ) * xmdt rdat % r04 ( 14 , i ) = rdat % r04 ( 14 , i ) + ( rdat % fq4 ( 4 , i ) - rdat % fq3 ( 2 , i ) * 3 ) * xmdty rdat % r04 ( 15 , i ) = rdat % r04 ( 15 , i ) + ( rdat % fq4 ( 5 , i ) - rdat % fq3 ( 3 , i ) * 6 & & + rdat % fq2 ( 1 , i ) * 3 ) * xmdt enddo do i = 3 , 4 fwk ( 1 , i ) = rdat % fq4 ( 1 , i ) * aqx4 - rdat % fq3 ( 1 , i ) * 6 * rdat % aqx2 + rdat % fq2 ( 1 , i ) * 3 fwk ( 2 , i ) = ( rdat % fq4 ( 1 , i ) * rdat % aqx2 - rdat % fq3 ( 1 , i ) * 3 ) * rdat % aqxy fwk ( 3 , i ) =- ( rdat % fq4 ( 2 , i ) * rdat % aqx2 - rdat % fq3 ( 2 , i ) * 3 ) * rdat % aqx fwk ( 4 , i ) = rdat % fq4 ( 1 , i ) * x2y2 - rdat % fq3 ( 1 , i ) * q2c2 + rdat % fq2 ( 1 , i ) fwk ( 5 , i ) =- ( rdat % fq4 ( 2 , i ) * rdat % aqx2 - rdat % fq3 ( 2 , i ) ) * rdat % acy fwk ( 6 , i ) = rdat % fq4 ( 3 , i ) * rdat % aqx2 - rdat % fq3 ( 1 , i ) * rdat % aqx2 - rdat % fq3 ( 3 , i ) + rdat % fq2 ( 1 , i ) fwk ( 7 , i ) = ( rdat % fq4 ( 1 , i ) * rdat % acy2 - rdat % fq3 ( 1 , i ) * 3 ) * rdat % aqxy fwk ( 8 , i ) =- ( rdat % fq4 ( 2 , i ) * rdat % acy2 - rdat % fq3 ( 2 , i ) ) * rdat % aqx fwk ( 9 , i ) = ( rdat % fq4 ( 3 , i ) - rdat % fq3 ( 1 , i ) ) * rdat % aqxy fwk ( 10 , i ) =- ( rdat % fq4 ( 4 , i ) - rdat % fq3 ( 2 , i ) * 3 ) * rdat % aqx fwk ( 11 , i ) = rdat % fq4 ( 1 , i ) * acy4 - rdat % fq3 ( 1 , i ) * 6 * rdat % acy2 + rdat % fq2 ( 1 , i ) * 3 fwk ( 12 , i ) =- ( rdat % fq4 ( 2 , i ) * rdat % acy2 - rdat % fq3 ( 2 , i ) * 3 ) * rdat % acy fwk ( 13 , i ) = rdat % fq4 ( 3 , i ) * rdat % acy2 - rdat % fq3 ( 1 , i ) * rdat % acy2 - rdat % fq3 ( 3 , i ) + rdat % fq2 ( 1 , i ) fwk ( 14 , i ) =- ( rdat % fq4 ( 4 , i ) - rdat % fq3 ( 2 , i ) * 3 ) * rdat % acy fwk ( 15 , i ) = rdat % fq4 ( 5 , i ) - rdat % fq3 ( 3 , i ) * 6 + rdat % fq2 ( 1 , i ) * 3 enddo do i = 3 , 4 do j = 1 , 15 rdat % r04 ( j , i ) = rdat % r04 ( j , i ) + fwk ( j , 3 ) * work ( i + 11 ) enddo enddo do i = 5 , 8 do j = 1 , 15 rdat % r04 ( j , i ) = rdat % r04 ( j , i ) + fwk ( j , 4 ) * work ( i + 5 ) enddo enddo rdat % r05 ( 1 , 1 ) = rdat % r05 ( 1 , 1 ) + ( rdat % fq5 ( 1 , 1 ) * aqx4 - rdat % fq4 ( 1 , 3 ) * 10 * rdat % aqx2 & & + rdat % fq3 ( 1 , 3 ) * 15 ) * xmdtx rdat % r05 ( 2 , 1 ) = rdat % r05 ( 2 , 1 ) + ( rdat % fq5 ( 1 , 1 ) * aqx4 - rdat % fq4 ( 1 , 3 ) * 6 * rdat % aqx2 & & + rdat % fq3 ( 1 , 3 ) * 3 ) * xmdty rdat % r05 ( 3 , 1 ) = rdat % r05 ( 3 , 1 ) + ( rdat % fq5 ( 2 , 1 ) * aqx4 - rdat % fq4 ( 2 , 3 ) * 6 * rdat % aqx2 & & + rdat % fq3 ( 2 , 3 ) * 3 ) * xmdt rdat % r05 ( 4 , 1 ) = rdat % r05 ( 4 , 1 ) + ( rdat % fq5 ( 1 , 1 ) * x2y2 - rdat % fq4 ( 1 , 3 ) * rdat % aqx2 & & - rdat % fq4 ( 1 , 3 ) * 3 * rdat % acy2 + rdat % fq3 ( 1 , 3 ) * 3 ) * xmdtx rdat % r05 ( 5 , 1 ) = rdat % r05 ( 5 , 1 ) + ( rdat % fq5 ( 2 , 1 ) * rdat % aqx2 - rdat % fq4 ( 2 , 3 ) * 3 ) * xmdtxy rdat % r05 ( 6 , 1 ) = rdat % r05 ( 6 , 1 ) + ( rdat % fq5 ( 3 , 1 ) * rdat % aqx2 - rdat % fq4 ( 1 , 3 ) * rdat % aqx2 & & - rdat % fq4 ( 3 , 3 ) * 3 + rdat % fq3 ( 1 , 3 ) * 3 ) * xmdtx rdat % r05 ( 7 , 1 ) = rdat % r05 ( 7 , 1 ) + ( rdat % fq5 ( 1 , 1 ) * x2y2 - rdat % fq4 ( 1 , 3 ) * 3 * rdat % aqx2 & & - rdat % fq4 ( 1 , 3 ) * rdat % acy2 + rdat % fq3 ( 1 , 3 ) * 3 ) * xmdty rdat % r05 ( 8 , 1 ) = rdat % r05 ( 8 , 1 ) + ( rdat % fq5 ( 2 , 1 ) * x2y2 - rdat % fq4 ( 2 , 3 ) * q2c2 & & + rdat % fq3 ( 2 , 3 ) ) * xmdt rdat % r05 ( 9 , 1 ) = rdat % r05 ( 9 , 1 ) + ( rdat % fq5 ( 3 , 1 ) * rdat % aqx2 - rdat % fq4 ( 1 , 3 ) * rdat % aqx2 - rdat % fq4 ( 3 , 3 ) & & + rdat % fq3 ( 1 , 3 ) ) * xmdty rdat % r05 ( 10 , 1 ) = rdat % r05 ( 10 , 1 ) + ( rdat % fq5 ( 4 , 1 ) * rdat % aqx2 - rdat % fq4 ( 2 , 3 ) * 3 * rdat % aqx2 & & - rdat % fq4 ( 4 , 3 ) + rdat % fq3 ( 2 , 3 ) * 3 ) * xmdt rdat % r05 ( 11 , 1 ) = rdat % r05 ( 11 , 1 ) + ( rdat % fq5 ( 1 , 1 ) * acy4 - rdat % fq4 ( 1 , 3 ) * 6 * rdat % acy2 & & + rdat % fq3 ( 1 , 3 ) * 3 ) * xmdtx rdat % r05 ( 12 , 1 ) = rdat % r05 ( 12 , 1 ) + ( rdat % fq5 ( 2 , 1 ) * rdat % acy2 - rdat % fq4 ( 2 , 3 ) * 3 ) * xmdtxy rdat % r05 ( 13 , 1 ) = rdat % r05 ( 13 , 1 ) + ( rdat % fq5 ( 3 , 1 ) * rdat % acy2 - rdat % fq4 ( 1 , 3 ) * rdat % acy2 - rdat % fq4 ( 3 , 3 ) & & + rdat % fq3 ( 1 , 3 ) ) * xmdtx rdat % r05 ( 14 , 1 ) = rdat % r05 ( 14 , 1 ) + ( rdat % fq5 ( 4 , 1 ) - rdat % fq4 ( 2 , 3 ) * 3 ) * xmdtxy rdat % r05 ( 15 , 1 ) = rdat % r05 ( 15 , 1 ) + ( rdat % fq5 ( 5 , 1 ) - rdat % fq4 ( 3 , 3 ) * 6 & & + rdat % fq3 ( 1 , 3 ) * 3 ) * xmdtx rdat % r05 ( 16 , 1 ) = rdat % r05 ( 16 , 1 ) + ( rdat % fq5 ( 1 , 1 ) * acy4 - rdat % fq4 ( 1 , 3 ) * 10 * rdat % acy2 & & + rdat % fq3 ( 1 , 3 ) * 15 ) * xmdty rdat % r05 ( 17 , 1 ) = rdat % r05 ( 17 , 1 ) + ( rdat % fq5 ( 2 , 1 ) * acy4 - rdat % fq4 ( 2 , 3 ) * 6 * rdat % acy2 & & + rdat % fq3 ( 2 , 3 ) * 3 ) * xmdt rdat % r05 ( 18 , 1 ) = rdat % r05 ( 18 , 1 ) + ( rdat % fq5 ( 3 , 1 ) * rdat % acy2 - rdat % fq4 ( 1 , 3 ) * rdat % acy2 & & - rdat % fq4 ( 3 , 3 ) * 3 + rdat % fq3 ( 1 , 3 ) * 3 ) * xmdty rdat % r05 ( 19 , 1 ) = rdat % r05 ( 19 , 1 ) + ( rdat % fq5 ( 4 , 1 ) * rdat % acy2 - rdat % fq4 ( 2 , 3 ) * 3 * rdat % acy2 & & - rdat % fq4 ( 4 , 3 ) + rdat % fq3 ( 2 , 3 ) * 3 ) * xmdt rdat % r05 ( 20 , 1 ) = rdat % r05 ( 20 , 1 ) + ( rdat % fq5 ( 5 , 1 ) - rdat % fq4 ( 3 , 3 ) * 6 & & + rdat % fq3 ( 1 , 3 ) * 3 ) * xmdty rdat % r05 ( 21 , 1 ) = rdat % r05 ( 21 , 1 ) + ( rdat % fq5 ( 6 , 1 ) - rdat % fq4 ( 4 , 3 ) * 10 & & + rdat % fq3 ( 2 , 3 ) * 15 ) * xmdt fwk ( 1 , 2 ) =- ( rdat % fq5 ( 1 , 2 ) * aqx4 - rdat % fq4 ( 1 , 4 ) * 10 * rdat % aqx2 + rdat % fq3 ( 1 , 4 ) * 15 ) * rdat % aqx fwk ( 2 , 2 ) =- ( rdat % fq5 ( 1 , 2 ) * aqx4 - rdat % fq4 ( 1 , 4 ) * 6 * rdat % aqx2 + rdat % fq3 ( 1 , 4 ) * 3 ) * rdat % acy fwk ( 3 , 2 ) = rdat % fq5 ( 2 , 2 ) * aqx4 - rdat % fq4 ( 2 , 4 ) * 6 * rdat % aqx2 + rdat % fq3 ( 2 , 4 ) * 3 fwk ( 4 , 2 ) =- ( rdat % fq5 ( 1 , 2 ) * x2y2 - rdat % fq4 ( 1 , 4 ) * rdat % aqx2 - rdat % fq4 ( 1 , 4 ) * 3 * rdat % acy2 & & + rdat % fq3 ( 1 , 4 ) * 3 ) * rdat % aqx fwk ( 5 , 2 ) = ( rdat % fq5 ( 2 , 2 ) * rdat % aqx2 - rdat % fq4 ( 2 , 4 ) * 3 ) * rdat % aqxy fwk ( 6 , 2 ) =- ( rdat % fq5 ( 3 , 2 ) * rdat % aqx2 - rdat % fq4 ( 1 , 4 ) * rdat % aqx2 - rdat % fq4 ( 3 , 4 ) * 3 & & + rdat % fq3 ( 1 , 4 ) * 3 ) * rdat % aqx fwk ( 7 , 2 ) =- ( rdat % fq5 ( 1 , 2 ) * x2y2 - rdat % fq4 ( 1 , 4 ) * 3 * rdat % aqx2 - rdat % fq4 ( 1 , 4 ) * rdat % acy2 & & + rdat % fq3 ( 1 , 4 ) * 3 ) * rdat % acy fwk ( 8 , 2 ) = rdat % fq5 ( 2 , 2 ) * x2y2 - rdat % fq4 ( 2 , 4 ) * q2c2 + rdat % fq3 ( 2 , 4 ) fwk ( 9 , 2 ) =- ( rdat % fq5 ( 3 , 2 ) * rdat % aqx2 - rdat % fq4 ( 1 , 4 ) * rdat % aqx2 - rdat % fq4 ( 3 , 4 ) & & + rdat % fq3 ( 1 , 4 ) ) * rdat % acy fwk ( 10 , 2 ) = rdat % fq5 ( 4 , 2 ) * rdat % aqx2 - rdat % fq4 ( 2 , 4 ) * 3 * rdat % aqx2 - rdat % fq4 ( 4 , 4 ) & & + rdat % fq3 ( 2 , 4 ) * 3 fwk ( 11 , 2 ) =- ( rdat % fq5 ( 1 , 2 ) * acy4 - rdat % fq4 ( 1 , 4 ) * 6 * rdat % acy2 & & + rdat % fq3 ( 1 , 4 ) * 3 ) * rdat % aqx fwk ( 12 , 2 ) = ( rdat % fq5 ( 2 , 2 ) * rdat % acy2 - rdat % fq4 ( 2 , 4 ) * 3 ) * rdat % aqxy fwk ( 13 , 2 ) =- ( rdat % fq5 ( 3 , 2 ) * rdat % acy2 - rdat % fq4 ( 1 , 4 ) * rdat % acy2 - rdat % fq4 ( 3 , 4 ) & & + rdat % fq3 ( 1 , 4 ) ) * rdat % aqx fwk ( 14 , 2 ) = ( rdat % fq5 ( 4 , 2 ) - rdat % fq4 ( 2 , 4 ) * 3 ) * rdat % aqxy fwk ( 15 , 2 ) =- ( rdat % fq5 ( 5 , 2 ) - rdat % fq4 ( 3 , 4 ) * 6 + rdat % fq3 ( 1 , 4 ) * 3 ) * rdat % aqx fwk ( 16 , 2 ) =- ( rdat % fq5 ( 1 , 2 ) * acy4 - rdat % fq4 ( 1 , 4 ) * 10 * rdat % acy2 + rdat % fq3 ( 1 , 4 ) * 15 ) * rdat % acy fwk ( 17 , 2 ) = rdat % fq5 ( 2 , 2 ) * acy4 - rdat % fq4 ( 2 , 4 ) * 6 * rdat % acy2 + rdat % fq3 ( 2 , 4 ) * 3 fwk ( 18 , 2 ) =- ( rdat % fq5 ( 3 , 2 ) * rdat % acy2 - rdat % fq4 ( 1 , 4 ) * rdat % acy2 - rdat % fq4 ( 3 , 4 ) * 3 & & + rdat % fq3 ( 1 , 4 ) * 3 ) * rdat % acy fwk ( 19 , 2 ) = rdat % fq5 ( 4 , 2 ) * rdat % acy2 - rdat % fq4 ( 2 , 4 ) * 3 * rdat % acy2 - rdat % fq4 ( 4 , 4 ) & & + rdat % fq3 ( 2 , 4 ) * 3 fwk ( 20 , 2 ) =- ( rdat % fq5 ( 5 , 2 ) - rdat % fq4 ( 3 , 4 ) * 6 + rdat % fq3 ( 1 , 4 ) * 3 ) * rdat % acy fwk ( 21 , 2 ) = rdat % fq5 ( 6 , 2 ) - rdat % fq4 ( 4 , 4 ) * 10 + rdat % fq3 ( 2 , 4 ) * 15 do i = 2 , 3 do j = 1 , 21 rdat % r05 ( j , i ) = rdat % r05 ( j , i ) + fwk ( j , 2 ) * work ( i + 12 ) end do end do call frikr6 ( rdat , 1 , 1 , fw6 , rdat % fq6 , 1 , rdat % fq5 , 3 , rdat % fq4 , 3 , rdat % fq3 ) do j = 1 , 28 rdat % r06 ( j , 1 ) = rdat % r06 ( j , 1 ) + fw6 ( j ) * fcc ( j , 6 ) enddo end subroutine intk_17 ! > ! >    @brief   ddpp case ! > ! >    @details integration of the ddpp case ! > subroutine intk_18 ( rdat , ikl ) implicit none type ( rotaxis_data_t ) :: rdat integer :: ikl real ( kind = dp ) :: xmd2 , xmd3 , xmd4 , xmd6 real ( kind = dp ) :: xmdt , xmdtx , xmdtxy , xmdty real ( kind = dp ) :: aqx4 , acy4 , q2c2 , x2y2 real ( kind = dp ) :: fqd11 , fqd12 , fqd21 , fqd22 , fqd23 , & fqd31 , fqd32 , fqd33 , fqd34 real ( kind = dp ) :: y33 , y34 , y44 real ( kind = dp ) :: work , fwk , fw6 , fcu , fcc integer :: i , j ! Generate jtype=18 integrals dimension work ( 15 ), fwk ( 21 , 10 ), fw6 ( 28 ) dimension fcu ( 45 , 8 ), fcc ( 45 , 8 ) if ( ikl == 0 ) then rdat % r00 = 0.0_dp rdat % r01 = 0.0_dp rdat % r02 (:, 1 : 41 ) = 0.0_dp rdat % r03 (:, 1 : 30 ) = 0.0_dp rdat % r04 (:, 1 : 17 ) = 0.0_dp rdat % r05 (:, 1 : 6 ) = 0.0_dp rdat % r06 ( 1 : 28 , 1 ) = 0.0_dp return endif xmd2 = rdat % x43 * 0.5d+00 xmd3 = xmd2 xmd4 = xmd3 * xmd2 xmd6 = xmd4 * xmd2 xmdt = xmd6 * xmd2 xmd2 = xmd3 xmdty =- xmdt * rdat % acy xmdtx =- xmdt * rdat % aqx xmdtxy = xmdt * rdat % aqxy y33 = rdat % y03 * rdat % y03 y34 =- rdat % y03 * rdat % y04 y44 = rdat % y04 * rdat % y04 work ( 1 ) = xmd4 work ( 2 ) = xmd2 * y33 work ( 3 ) = xmd2 * y34 work ( 4 ) = xmd2 * y44 work ( 5 ) = y33 * y44 work ( 6 ) =- xmd4 * rdat % y03 work ( 7 ) = xmd4 * rdat % y04 work ( 8 ) = xmd2 * y33 * rdat % y04 work ( 9 ) = xmd2 * y34 * rdat % y04 work ( 10 ) = xmd6 work ( 11 ) = xmd4 * y33 work ( 12 ) = xmd4 * y34 work ( 13 ) = xmd4 * y44 work ( 14 ) =- xmd6 * rdat % y03 work ( 15 ) = xmd6 * rdat % y04 call fcufcc ( rdat , 6 , xmdt , fcu , fcc ) do i = 1 , 5 do j = 1 , 5 rdat % r00 ( j , i ) = rdat % r00 ( j , i ) + rdat % fq0 ( i ) * work ( j ) end do end do do i = 1 , 8 fwk ( 1 , i ) =- rdat % fq1 ( 1 , i ) * rdat % aqx fwk ( 2 , i ) =- rdat % fq1 ( 1 , i ) * rdat % acy fwk ( 3 , i ) = rdat % fq1 ( 2 , i ) enddo fqd11 = rdat % fq1 ( 1 , 5 ) * rdat % rab + rdat % fq1 ( 1 , 8 ) fqd12 = rdat % fq1 ( 2 , 5 ) * rdat % rab + rdat % fq1 ( 2 , 8 ) fwk ( 1 , 9 ) =- fqd11 * rdat % aqx fwk ( 2 , 9 ) =- fqd11 * rdat % acy fwk ( 3 , 9 ) = fqd12 do i = 1 , 4 rdat % r01 ( 1 , i ) = rdat % r01 ( 1 , i ) + fwk ( 1 , 1 ) * work ( i + 5 ) rdat % r01 ( 2 , i ) = rdat % r01 ( 2 , i ) + fwk ( 2 , 1 ) * work ( i + 5 ) rdat % r01 ( 3 , i ) = rdat % r01 ( 3 , i ) + fwk ( 3 , 1 ) * work ( i + 5 ) enddo do i = 5 , 8 rdat % r01 ( 1 , i ) = rdat % r01 ( 1 , i ) + fwk ( 1 , 2 ) * work ( i + 1 ) rdat % r01 ( 2 , i ) = rdat % r01 ( 2 , i ) + fwk ( 2 , 2 ) * work ( i + 1 ) rdat % r01 ( 3 , i ) = rdat % r01 ( 3 , i ) + fwk ( 3 , 2 ) * work ( i + 1 ) enddo do i = 9 , 12 rdat % r01 ( 1 , i ) = rdat % r01 ( 1 , i ) + fwk ( 1 , 3 ) * work ( i - 3 ) rdat % r01 ( 2 , i ) = rdat % r01 ( 2 , i ) + fwk ( 2 , 3 ) * work ( i - 3 ) rdat % r01 ( 3 , i ) = rdat % r01 ( 3 , i ) + fwk ( 3 , 3 ) * work ( i - 3 ) enddo do i = 13 , 16 rdat % r01 ( 1 , i ) = rdat % r01 ( 1 , i ) + fwk ( 1 , 4 ) * work ( i - 7 ) rdat % r01 ( 2 , i ) = rdat % r01 ( 2 , i ) + fwk ( 2 , 4 ) * work ( i - 7 ) rdat % r01 ( 3 , i ) = rdat % r01 ( 3 , i ) + fwk ( 3 , 4 ) * work ( i - 7 ) enddo do i = 17 , 20 rdat % r01 ( 1 , i ) = rdat % r01 ( 1 , i ) + fwk ( 1 , 5 ) * work ( i - 11 ) rdat % r01 ( 2 , i ) = rdat % r01 ( 2 , i ) + fwk ( 2 , 5 ) * work ( i - 11 ) rdat % r01 ( 3 , i ) = rdat % r01 ( 3 , i ) + fwk ( 3 , 5 ) * work ( i - 11 ) enddo do i = 21 , 25 rdat % r01 ( 1 , i ) = rdat % r01 ( 1 , i ) + fwk ( 1 , 6 ) * work ( i - 20 ) rdat % r01 ( 2 , i ) = rdat % r01 ( 2 , i ) + fwk ( 2 , 6 ) * work ( i - 20 ) rdat % r01 ( 3 , i ) = rdat % r01 ( 3 , i ) + fwk ( 3 , 6 ) * work ( i - 20 ) enddo do i = 26 , 30 rdat % r01 ( 1 , i ) = rdat % r01 ( 1 , i ) + fwk ( 1 , 7 ) * work ( i - 25 ) rdat % r01 ( 2 , i ) = rdat % r01 ( 2 , i ) + fwk ( 2 , 7 ) * work ( i - 25 ) rdat % r01 ( 3 , i ) = rdat % r01 ( 3 , i ) + fwk ( 3 , 7 ) * work ( i - 25 ) enddo do i = 31 , 35 rdat % r01 ( 1 , i ) = rdat % r01 ( 1 , i ) + fwk ( 1 , 8 ) * work ( i - 30 ) rdat % r01 ( 2 , i ) = rdat % r01 ( 2 , i ) + fwk ( 2 , 8 ) * work ( i - 30 ) rdat % r01 ( 3 , i ) = rdat % r01 ( 3 , i ) + fwk ( 3 , 8 ) * work ( i - 30 ) enddo do i = 36 , 40 rdat % r01 ( 1 , i ) = rdat % r01 ( 1 , i ) + fwk ( 1 , 9 ) * work ( i - 35 ) rdat % r01 ( 2 , i ) = rdat % r01 ( 2 , i ) + fwk ( 2 , 9 ) * work ( i - 35 ) rdat % r01 ( 3 , i ) = rdat % r01 ( 3 , i ) + fwk ( 3 , 9 ) * work ( i - 35 ) enddo do i = 1 , 9 fwk ( 1 , i ) = rdat % fq2 ( 1 , i ) * rdat % aqx2 - rdat % fq1 ( 1 , i ) fwk ( 2 , i ) = rdat % fq2 ( 1 , i ) * rdat % acy2 - rdat % fq1 ( 1 , i ) fwk ( 3 , i ) = rdat % fq2 ( 3 , i ) - rdat % fq1 ( 1 , i ) fwk ( 4 , i ) = rdat % fq2 ( 1 , i ) * rdat % aqxy fwk ( 5 , i ) =- rdat % fq2 ( 2 , i ) * rdat % aqx fwk ( 6 , i ) =- rdat % fq2 ( 2 , i ) * rdat % acy enddo fqd21 = rdat % fq2 ( 1 , 5 ) * rdat % rab + rdat % fq2 ( 1 , 8 ) fqd22 = rdat % fq2 ( 2 , 5 ) * rdat % rab + rdat % fq2 ( 2 , 8 ) fqd23 = rdat % fq2 ( 3 , 5 ) * rdat % rab + rdat % fq2 ( 3 , 8 ) fwk ( 1 , 10 ) = fqd21 * rdat % aqx2 - fqd11 fwk ( 2 , 10 ) = fqd21 * rdat % acy2 - fqd11 fwk ( 3 , 10 ) = fqd23 - fqd11 fwk ( 4 , 10 ) = fqd21 * rdat % aqxy fwk ( 5 , 10 ) =- fqd22 * rdat % aqx fwk ( 6 , 10 ) =- fqd22 * rdat % acy do i = 1 , 4 do j = 1 , 6 rdat % r02 ( j , i ) = rdat % r02 ( j , i ) + fwk ( j , 1 ) * work ( i + 9 ) enddo enddo do i = 5 , 8 do j = 1 , 6 rdat % r02 ( j , i ) = rdat % r02 ( j , i ) + fwk ( j , 2 ) * work ( i + 5 ) enddo enddo do i = 9 , 12 do j = 1 , 6 rdat % r02 ( j , i ) = rdat % r02 ( j , i ) + fwk ( j , 3 ) * work ( i + 1 ) enddo enddo do i = 13 , 16 do j = 1 , 6 rdat % r02 ( j , i ) = rdat % r02 ( j , i ) + fwk ( j , 4 ) * work ( i - 3 ) enddo enddo do i = 17 , 20 do j = 1 , 6 rdat % r02 ( j , i ) = rdat % r02 ( j , i ) + fwk ( j , 5 ) * work ( i - 7 ) enddo enddo do i = 21 , 24 do j = 1 , 6 rdat % r02 ( j , i ) = rdat % r02 ( j , i ) + fwk ( j , 6 ) * work ( i - 15 ) enddo enddo do i = 25 , 28 do j = 1 , 6 rdat % r02 ( j , i ) = rdat % r02 ( j , i ) + fwk ( j , 7 ) * work ( i - 19 ) enddo enddo do i = 29 , 32 do j = 1 , 6 rdat % r02 ( j , i ) = rdat % r02 ( j , i ) + fwk ( j , 8 ) * work ( i - 23 ) enddo enddo do i = 33 , 36 do j = 1 , 6 rdat % r02 ( j , i ) = rdat % r02 ( j , i ) + fwk ( j , 10 ) * work ( i - 27 ) enddo enddo do i = 37 , 41 do j = 1 , 6 rdat % r02 ( j , i ) = rdat % r02 ( j , i ) + fwk ( j , 9 ) * work ( i - 36 ) enddo enddo do i = 1 , 9 fwk ( 1 , i ) =- ( rdat % fq3 ( 1 , i ) * rdat % aqx2 - rdat % fq2 ( 1 , i ) * 3 ) * rdat % aqx fwk ( 2 , i ) =- ( rdat % fq3 ( 1 , i ) * rdat % aqx2 - rdat % fq2 ( 1 , i ) ) * rdat % acy fwk ( 3 , i ) = rdat % fq3 ( 2 , i ) * rdat % aqx2 - rdat % fq2 ( 2 , i ) fwk ( 4 , i ) =- ( rdat % fq3 ( 1 , i ) * rdat % acy2 - rdat % fq2 ( 1 , i ) ) * rdat % aqx fwk ( 5 , i ) = rdat % fq3 ( 2 , i ) * rdat % aqxy fwk ( 6 , i ) =- ( rdat % fq3 ( 3 , i ) - rdat % fq2 ( 1 , i ) ) * rdat % aqx fwk ( 7 , i ) =- ( rdat % fq3 ( 1 , i ) * rdat % acy2 - rdat % fq2 ( 1 , i ) * 3 ) * rdat % acy fwk ( 8 , i ) = rdat % fq3 ( 2 , i ) * rdat % acy2 - rdat % fq2 ( 2 , i ) fwk ( 9 , i ) =- ( rdat % fq3 ( 3 , i ) - rdat % fq2 ( 1 , i ) ) * rdat % acy fwk ( 10 , i ) = rdat % fq3 ( 4 , i ) - rdat % fq2 ( 2 , i ) * 3 enddo fqd31 = rdat % fq3 ( 1 , 5 ) * rdat % rab + rdat % fq3 ( 1 , 8 ) fqd32 = rdat % fq3 ( 2 , 5 ) * rdat % rab + rdat % fq3 ( 2 , 8 ) fqd33 = rdat % fq3 ( 3 , 5 ) * rdat % rab + rdat % fq3 ( 3 , 8 ) fqd34 = rdat % fq3 ( 4 , 5 ) * rdat % rab + rdat % fq3 ( 4 , 8 ) fwk ( 1 , 10 ) =- ( fqd31 * rdat % aqx2 - fqd21 * 3 ) * rdat % aqx fwk ( 2 , 10 ) =- ( fqd31 * rdat % aqx2 - fqd21 ) * rdat % acy fwk ( 3 , 10 ) = fqd32 * rdat % aqx2 - fqd22 fwk ( 4 , 10 ) =- ( fqd31 * rdat % acy2 - fqd21 ) * rdat % aqx fwk ( 5 , 10 ) = fqd32 * rdat % aqxy fwk ( 6 , 10 ) =- ( fqd33 - fqd21 ) * rdat % aqx fwk ( 7 , 10 ) =- ( fqd31 * rdat % acy2 - fqd21 * 3 ) * rdat % acy fwk ( 8 , 10 ) = fqd32 * rdat % acy2 - fqd22 fwk ( 9 , 10 ) =- ( fqd33 - fqd21 ) * rdat % acy fwk ( 10 , 10 ) = fqd34 - fqd22 * 3 do i = 1 , 2 do j = 1 , 10 rdat % r03 ( j , i ) = rdat % r03 ( j , i ) + fwk ( j , 1 ) * work ( i + 13 ) enddo enddo do i = 3 , 4 do j = 1 , 10 rdat % r03 ( j , i ) = rdat % r03 ( j , i ) + fwk ( j , 2 ) * work ( i + 11 ) enddo enddo do i = 5 , 6 do j = 1 , 10 rdat % r03 ( j , i ) = rdat % r03 ( j , i ) + fwk ( j , 3 ) * work ( i + 9 ) enddo enddo do i = 7 , 8 do j = 1 , 10 rdat % r03 ( j , i ) = rdat % r03 ( j , i ) + fwk ( j , 4 ) * work ( i + 7 ) enddo enddo do i = 9 , 10 do j = 1 , 10 rdat % r03 ( j , i ) = rdat % r03 ( j , i ) + fwk ( j , 5 ) * work ( i + 5 ) enddo enddo do i = 11 , 14 do j = 1 , 10 rdat % r03 ( j , i ) = rdat % r03 ( j , i ) + fwk ( j , 6 ) * work ( i - 1 ) enddo enddo do i = 15 , 18 do j = 1 , 10 rdat % r03 ( j , i ) = rdat % r03 ( j , i ) + fwk ( j , 7 ) * work ( i - 5 ) enddo enddo do i = 19 , 22 do j = 1 , 10 rdat % r03 ( j , i ) = rdat % r03 ( j , i ) + fwk ( j , 8 ) * work ( i - 9 ) enddo enddo do i = 23 , 26 do j = 1 , 10 rdat % r03 ( j , i ) = rdat % r03 ( j , i ) + fwk ( j , 10 ) * work ( i - 13 ) enddo enddo do i = 27 , 30 do j = 1 , 10 rdat % r03 ( j , i ) = rdat % r03 ( j , i ) + fwk ( j , 9 ) * work ( i - 21 ) enddo enddo aqx4 = rdat % aqx2 * rdat % aqx2 acy4 = rdat % acy2 * rdat % acy2 x2y2 = rdat % aqx2 * rdat % acy2 q2c2 = rdat % aqx2 + rdat % acy2 do i = 1 , 5 rdat % r04 ( 1 , i ) = rdat % r04 ( 1 , i ) + ( rdat % fq4 ( 1 , i ) * aqx4 - rdat % fq3 ( 1 , i ) * 6 * rdat % aqx2 & & + rdat % fq2 ( 1 , i ) * 3 ) * xmdt rdat % r04 ( 2 , i ) = rdat % r04 ( 2 , i ) + ( rdat % fq4 ( 1 , i ) * rdat % aqx2 - rdat % fq3 ( 1 , i ) * 3 ) * xmdtxy rdat % r04 ( 3 , i ) = rdat % r04 ( 3 , i ) + ( rdat % fq4 ( 2 , i ) * rdat % aqx2 - rdat % fq3 ( 2 , i ) * 3 ) * xmdtx rdat % r04 ( 4 , i ) = rdat % r04 ( 4 , i ) + ( rdat % fq4 ( 1 , i ) * x2y2 - rdat % fq3 ( 1 , i ) * q2c2 & & + rdat % fq2 ( 1 , i ) ) * xmdt rdat % r04 ( 5 , i ) = rdat % r04 ( 5 , i ) + ( rdat % fq4 ( 2 , i ) * rdat % aqx2 - rdat % fq3 ( 2 , i ) ) * xmdty rdat % r04 ( 6 , i ) = rdat % r04 ( 6 , i ) + ( rdat % fq4 ( 3 , i ) * rdat % aqx2 - rdat % fq3 ( 1 , i ) * rdat % aqx2 & & - rdat % fq3 ( 3 , i ) + rdat % fq2 ( 1 , i ) ) * xmdt rdat % r04 ( 7 , i ) = rdat % r04 ( 7 , i ) + ( rdat % fq4 ( 1 , i ) * rdat % acy2 - rdat % fq3 ( 1 , i ) * 3 ) * xmdtxy rdat % r04 ( 8 , i ) = rdat % r04 ( 8 , i ) + ( rdat % fq4 ( 2 , i ) * rdat % acy2 - rdat % fq3 ( 2 , i ) ) * xmdtx rdat % r04 ( 9 , i ) = rdat % r04 ( 9 , i ) + ( rdat % fq4 ( 3 , i ) - rdat % fq3 ( 1 , i ) ) * xmdtxy rdat % r04 ( 10 , i ) = rdat % r04 ( 10 , i ) + ( rdat % fq4 ( 4 , i ) - rdat % fq3 ( 2 , i ) * 3 ) * xmdtx rdat % r04 ( 11 , i ) = rdat % r04 ( 11 , i ) + ( rdat % fq4 ( 1 , i ) * acy4 - rdat % fq3 ( 1 , i ) * 6 * rdat % acy2 & & + rdat % fq2 ( 1 , i ) * 3 ) * xmdt rdat % r04 ( 12 , i ) = rdat % r04 ( 12 , i ) + ( rdat % fq4 ( 2 , i ) * rdat % acy2 - rdat % fq3 ( 2 , i ) * 3 ) * xmdty rdat % r04 ( 13 , i ) = rdat % r04 ( 13 , i ) + ( rdat % fq4 ( 3 , i ) * rdat % acy2 - rdat % fq3 ( 1 , i ) * rdat % acy2 & & - rdat % fq3 ( 3 , i ) + rdat % fq2 ( 1 , i ) ) * xmdt rdat % r04 ( 14 , i ) = rdat % r04 ( 14 , i ) + ( rdat % fq4 ( 4 , i ) - rdat % fq3 ( 2 , i ) * 3 ) * xmdty rdat % r04 ( 15 , i ) = rdat % r04 ( 15 , i ) + ( rdat % fq4 ( 5 , i ) - rdat % fq3 ( 3 , i ) * 6 & & + rdat % fq2 ( 1 , i ) * 3 ) * xmdt enddo rdat % fq2 ( 1 , 5 ) = fqd21 rdat % fq3 ( 1 , 5 ) = fqd31 rdat % fq3 ( 2 , 5 ) = fqd32 rdat % fq3 ( 3 , 5 ) = fqd33 do j = 1 , 5 rdat % fq4 ( j , 5 ) = rdat % fq4 ( j , 5 ) * rdat % rab + rdat % fq4 ( j , 8 ) enddo do i = 5 , 9 fwk ( 1 , i ) = rdat % fq4 ( 1 , i ) * aqx4 - rdat % fq3 ( 1 , i ) * 6 * rdat % aqx2 + rdat % fq2 ( 1 , i ) * 3 fwk ( 2 , i ) = ( rdat % fq4 ( 1 , i ) * rdat % aqx2 - rdat % fq3 ( 1 , i ) * 3 ) * rdat % aqxy fwk ( 3 , i ) =- ( rdat % fq4 ( 2 , i ) * rdat % aqx2 - rdat % fq3 ( 2 , i ) * 3 ) * rdat % aqx fwk ( 4 , i ) = rdat % fq4 ( 1 , i ) * x2y2 - rdat % fq3 ( 1 , i ) * q2c2 + rdat % fq2 ( 1 , i ) fwk ( 5 , i ) =- ( rdat % fq4 ( 2 , i ) * rdat % aqx2 - rdat % fq3 ( 2 , i ) ) * rdat % acy fwk ( 6 , i ) = rdat % fq4 ( 3 , i ) * rdat % aqx2 - rdat % fq3 ( 1 , i ) * rdat % aqx2 - rdat % fq3 ( 3 , i ) + rdat % fq2 ( 1 , i ) fwk ( 7 , i ) = ( rdat % fq4 ( 1 , i ) * rdat % acy2 - rdat % fq3 ( 1 , i ) * 3 ) * rdat % aqxy fwk ( 8 , i ) =- ( rdat % fq4 ( 2 , i ) * rdat % acy2 - rdat % fq3 ( 2 , i ) ) * rdat % aqx fwk ( 9 , i ) = ( rdat % fq4 ( 3 , i ) - rdat % fq3 ( 1 , i ) ) * rdat % aqxy fwk ( 10 , i ) =- ( rdat % fq4 ( 4 , i ) - rdat % fq3 ( 2 , i ) * 3 ) * rdat % aqx fwk ( 11 , i ) = rdat % fq4 ( 1 , i ) * acy4 - rdat % fq3 ( 1 , i ) * 6 * rdat % acy2 + rdat % fq2 ( 1 , i ) * 3 fwk ( 12 , i ) =- ( rdat % fq4 ( 2 , i ) * rdat % acy2 - rdat % fq3 ( 2 , i ) * 3 ) * rdat % acy fwk ( 13 , i ) = rdat % fq4 ( 3 , i ) * rdat % acy2 - rdat % fq3 ( 1 , i ) * rdat % acy2 - rdat % fq3 ( 3 , i ) + rdat % fq2 ( 1 , i ) fwk ( 14 , i ) =- ( rdat % fq4 ( 4 , i ) - rdat % fq3 ( 2 , i ) * 3 ) * rdat % acy fwk ( 15 , i ) = rdat % fq4 ( 5 , i ) - rdat % fq3 ( 3 , i ) * 6 + rdat % fq2 ( 1 , i ) * 3 enddo do i = 6 , 7 do j = 1 , 15 rdat % r04 ( j , i ) = rdat % r04 ( j , i ) + fwk ( j , 5 ) * work ( i + 8 ) enddo enddo do i = 8 , 9 do j = 1 , 15 rdat % r04 ( j , i ) = rdat % r04 ( j , i ) + fwk ( j , 6 ) * work ( i + 6 ) enddo enddo do i = 10 , 11 do j = 1 , 15 rdat % r04 ( j , i ) = rdat % r04 ( j , i ) + fwk ( j , 7 ) * work ( i + 4 ) enddo enddo do i = 12 , 13 do j = 1 , 15 rdat % r04 ( j , i ) = rdat % r04 ( j , i ) + fwk ( j , 8 ) * work ( i + 2 ) enddo enddo do i = 14 , 17 do j = 1 , 15 rdat % r04 ( j , i ) = rdat % r04 ( j , i ) + fwk ( j , 9 ) * work ( i - 4 ) enddo enddo do j = 1 , 6 rdat % fq5 ( j , 1 ) = rdat % fq5 ( j , 1 ) * rdat % rab + rdat % fq5 ( j , 4 ) enddo do i = 1 , 4 rdat % r05 ( 1 , i ) = rdat % r05 ( 1 , i ) + ( rdat % fq5 ( 1 , i ) * aqx4 - rdat % fq4 ( 1 , i + 4 ) * 10 * rdat % aqx2 & & + rdat % fq3 ( 1 , i + 4 ) * 15 ) * xmdtx rdat % r05 ( 2 , i ) = rdat % r05 ( 2 , i ) + ( rdat % fq5 ( 1 , i ) * aqx4 - rdat % fq4 ( 1 , i + 4 ) * 6 * rdat % aqx2 & & + rdat % fq3 ( 1 , i + 4 ) * 3 ) * xmdty rdat % r05 ( 3 , i ) = rdat % r05 ( 3 , i ) + ( rdat % fq5 ( 2 , i ) * aqx4 - rdat % fq4 ( 2 , i + 4 ) * 6 * rdat % aqx2 & & + rdat % fq3 ( 2 , i + 4 ) * 3 ) * xmdt rdat % r05 ( 4 , i ) = rdat % r05 ( 4 , i ) + ( rdat % fq5 ( 1 , i ) * x2y2 - rdat % fq4 ( 1 , i + 4 ) * 3 * rdat % acy2 & & - rdat % fq4 ( 1 , i + 4 ) * rdat % aqx2 + rdat % fq3 ( 1 , i + 4 ) * 3 ) * xmdtx rdat % r05 ( 5 , i ) = rdat % r05 ( 5 , i ) + ( rdat % fq5 ( 2 , i ) * rdat % aqx2 - rdat % fq4 ( 2 , i + 4 ) * 3 ) * xmdtxy rdat % r05 ( 6 , i ) = rdat % r05 ( 6 , i ) + ( rdat % fq5 ( 3 , i ) * rdat % aqx2 - rdat % fq4 ( 1 , i + 4 ) * rdat % aqx2 & & - rdat % fq4 ( 3 , i + 4 ) * 3 + rdat % fq3 ( 1 , i + 4 ) * 3 ) * xmdtx rdat % r05 ( 7 , i ) = rdat % r05 ( 7 , i ) + ( rdat % fq5 ( 1 , i ) * x2y2 - rdat % fq4 ( 1 , i + 4 ) * 3 * rdat % aqx2 & & - rdat % fq4 ( 1 , i + 4 ) * rdat % acy2 + rdat % fq3 ( 1 , i + 4 ) * 3 ) * xmdty rdat % r05 ( 8 , i ) = rdat % r05 ( 8 , i ) + ( rdat % fq5 ( 2 , i ) * x2y2 - rdat % fq4 ( 2 , i + 4 ) * q2c2 & & + rdat % fq3 ( 2 , i + 4 ) ) * xmdt rdat % r05 ( 9 , i ) = rdat % r05 ( 9 , i ) + ( rdat % fq5 ( 3 , i ) * rdat % aqx2 - rdat % fq4 ( 1 , i + 4 ) * rdat % aqx2 & & - rdat % fq4 ( 3 , i + 4 ) + rdat % fq3 ( 1 , i + 4 ) ) * xmdty rdat % r05 ( 10 , i ) = rdat % r05 ( 10 , i ) + ( rdat % fq5 ( 4 , i ) * rdat % aqx2 - rdat % fq4 ( 2 , i + 4 ) * 3 * rdat % aqx2 & & - rdat % fq4 ( 4 , i + 4 ) + rdat % fq3 ( 2 , i + 4 ) * 3 ) * xmdt rdat % r05 ( 11 , i ) = rdat % r05 ( 11 , i ) + ( rdat % fq5 ( 1 , i ) * acy4 - rdat % fq4 ( 1 , i + 4 ) * 6 * rdat % acy2 & & + rdat % fq3 ( 1 , i + 4 ) * 3 ) * xmdtx rdat % r05 ( 12 , i ) = rdat % r05 ( 12 , i ) + ( rdat % fq5 ( 2 , i ) * rdat % acy2 - rdat % fq4 ( 2 , i + 4 ) * 3 ) * xmdtxy rdat % r05 ( 13 , i ) = rdat % r05 ( 13 , i ) + ( rdat % fq5 ( 3 , i ) * rdat % acy2 - rdat % fq4 ( 1 , i + 4 ) * rdat % acy2 & & - rdat % fq4 ( 3 , i + 4 ) + rdat % fq3 ( 1 , i + 4 ) ) * xmdtx rdat % r05 ( 14 , i ) = rdat % r05 ( 14 , i ) + ( rdat % fq5 ( 4 , i ) - rdat % fq4 ( 2 , i + 4 ) * 3 ) * xmdtxy rdat % r05 ( 15 , i ) = rdat % r05 ( 15 , i ) + ( rdat % fq5 ( 5 , i ) - rdat % fq4 ( 3 , i + 4 ) * 6 & & + rdat % fq3 ( 1 , i + 4 ) * 3 ) * xmdtx rdat % r05 ( 16 , i ) = rdat % r05 ( 16 , i ) + ( rdat % fq5 ( 1 , i ) * acy4 - rdat % fq4 ( 1 , i + 4 ) * 10 * rdat % acy2 & & + rdat % fq3 ( 1 , i + 4 ) * 15 ) * xmdty rdat % r05 ( 17 , i ) = rdat % r05 ( 17 , i ) + ( rdat % fq5 ( 2 , i ) * acy4 - rdat % fq4 ( 2 , i + 4 ) * 6 * rdat % acy2 & & + rdat % fq3 ( 2 , i + 4 ) * 3 ) * xmdt rdat % r05 ( 18 , i ) = rdat % r05 ( 18 , i ) + ( rdat % fq5 ( 3 , i ) * rdat % acy2 - rdat % fq4 ( 1 , i + 4 ) * rdat % acy2 & & - rdat % fq4 ( 3 , i + 4 ) * 3 + rdat % fq3 ( 1 , i + 4 ) * 3 ) * xmdty rdat % r05 ( 19 , i ) = rdat % r05 ( 19 , i ) + ( rdat % fq5 ( 4 , i ) * rdat % acy2 - rdat % fq4 ( 2 , i + 4 ) * 3 * rdat % acy2 & & - rdat % fq4 ( 4 , i + 4 ) + rdat % fq3 ( 2 , i + 4 ) * 3 ) * xmdt rdat % r05 ( 20 , i ) = rdat % r05 ( 20 , i ) + ( rdat % fq5 ( 5 , i ) - rdat % fq4 ( 3 , i + 4 ) * 6 & & + rdat % fq3 ( 1 , i + 4 ) * 3 ) * xmdty rdat % r05 ( 21 , i ) = rdat % r05 ( 21 , i ) + ( rdat % fq5 ( 6 , i ) - rdat % fq4 ( 4 , i + 4 ) * 10 & & + rdat % fq3 ( 2 , i + 4 ) * 15 ) * xmdt enddo fwk ( 1 , 5 ) =- ( rdat % fq5 ( 1 , 5 ) * aqx4 - rdat % fq4 ( 1 , 9 ) * 10 * rdat % aqx2 + rdat % fq3 ( 1 , 9 ) * 15 ) * rdat % aqx fwk ( 2 , 5 ) =- ( rdat % fq5 ( 1 , 5 ) * aqx4 - rdat % fq4 ( 1 , 9 ) * 6 * rdat % aqx2 + rdat % fq3 ( 1 , 9 ) * 3 ) * rdat % acy fwk ( 3 , 5 ) = rdat % fq5 ( 2 , 5 ) * aqx4 - rdat % fq4 ( 2 , 9 ) * 6 * rdat % aqx2 + rdat % fq3 ( 2 , 9 ) * 3 fwk ( 4 , 5 ) =- ( rdat % fq5 ( 1 , 5 ) * x2y2 - rdat % fq4 ( 1 , 9 ) * rdat % aqx2 - rdat % fq4 ( 1 , 9 ) * 3 * rdat % acy2 & & + rdat % fq3 ( 1 , 9 ) * 3 ) * rdat % aqx fwk ( 5 , 5 ) = ( rdat % fq5 ( 2 , 5 ) * rdat % aqx2 - rdat % fq4 ( 2 , 9 ) * 3 ) * rdat % aqxy fwk ( 6 , 5 ) =- ( rdat % fq5 ( 3 , 5 ) * rdat % aqx2 - rdat % fq4 ( 1 , 9 ) * rdat % aqx2 - rdat % fq4 ( 3 , 9 ) * 3 & & + rdat % fq3 ( 1 , 9 ) * 3 ) * rdat % aqx fwk ( 7 , 5 ) =- ( rdat % fq5 ( 1 , 5 ) * x2y2 - rdat % fq4 ( 1 , 9 ) * 3 * rdat % aqx2 - rdat % fq4 ( 1 , 9 ) * rdat % acy2 & & + rdat % fq3 ( 1 , 9 ) * 3 ) * rdat % acy fwk ( 8 , 5 ) = rdat % fq5 ( 2 , 5 ) * x2y2 - rdat % fq4 ( 2 , 9 ) * q2c2 + rdat % fq3 ( 2 , 9 ) fwk ( 9 , 5 ) =- ( rdat % fq5 ( 3 , 5 ) * rdat % aqx2 - rdat % fq4 ( 1 , 9 ) * rdat % aqx2 - rdat % fq4 ( 3 , 9 ) & & + rdat % fq3 ( 1 , 9 ) ) * rdat % acy fwk ( 10 , 5 ) = rdat % fq5 ( 4 , 5 ) * rdat % aqx2 - rdat % fq4 ( 2 , 9 ) * 3 * rdat % aqx2 - rdat % fq4 ( 4 , 9 ) & & + rdat % fq3 ( 2 , 9 ) * 3 fwk ( 11 , 5 ) =- ( rdat % fq5 ( 1 , 5 ) * acy4 - rdat % fq4 ( 1 , 9 ) * 6 * rdat % acy2 + rdat % fq3 ( 1 , 9 ) * 3 ) * rdat % aqx fwk ( 12 , 5 ) = ( rdat % fq5 ( 2 , 5 ) * rdat % acy2 - rdat % fq4 ( 2 , 9 ) * 3 ) * rdat % aqxy fwk ( 13 , 5 ) =- ( rdat % fq5 ( 3 , 5 ) * rdat % acy2 - rdat % fq4 ( 1 , 9 ) * rdat % acy2 - rdat % fq4 ( 3 , 9 ) & & + rdat % fq3 ( 1 , 9 ) ) * rdat % aqx fwk ( 14 , 5 ) = ( rdat % fq5 ( 4 , 5 ) - rdat % fq4 ( 2 , 9 ) * 3 ) * rdat % aqxy fwk ( 15 , 5 ) =- ( rdat % fq5 ( 5 , 5 ) - rdat % fq4 ( 3 , 9 ) * 6 + rdat % fq3 ( 1 , 9 ) * 3 ) * rdat % aqx fwk ( 16 , 5 ) =- ( rdat % fq5 ( 1 , 5 ) * acy4 - rdat % fq4 ( 1 , 9 ) * 10 * rdat % acy2 + rdat % fq3 ( 1 , 9 ) * 15 ) * rdat % acy fwk ( 17 , 5 ) = rdat % fq5 ( 2 , 5 ) * acy4 - rdat % fq4 ( 2 , 9 ) * 6 * rdat % acy2 + rdat % fq3 ( 2 , 9 ) * 3 fwk ( 18 , 5 ) =- ( rdat % fq5 ( 3 , 5 ) * rdat % acy2 - rdat % fq4 ( 1 , 9 ) * rdat % acy2 - rdat % fq4 ( 3 , 9 ) * 3 & & + rdat % fq3 ( 1 , 9 ) * 3 ) * rdat % acy fwk ( 19 , 5 ) = rdat % fq5 ( 4 , 5 ) * rdat % acy2 - rdat % fq4 ( 2 , 9 ) * 3 * rdat % acy2 - rdat % fq4 ( 4 , 9 ) & & + rdat % fq3 ( 2 , 9 ) * 3 fwk ( 20 , 5 ) =- ( rdat % fq5 ( 5 , 5 ) - rdat % fq4 ( 3 , 9 ) * 6 + rdat % fq3 ( 1 , 9 ) * 3 ) * rdat % acy fwk ( 21 , 5 ) = rdat % fq5 ( 6 , 5 ) - rdat % fq4 ( 4 , 9 ) * 10 + rdat % fq3 ( 2 , 9 ) * 15 do i = 5 , 6 do j = 1 , 21 rdat % r05 ( j , i ) = rdat % r05 ( j , i ) + fwk ( j , 5 ) * work ( i + 9 ) end do end do call frikr6 ( rdat , 1 , 1 , fw6 , rdat % fq6 , 4 , rdat % fq5 , 8 , rdat % fq4 , 8 , rdat % fq3 ) do j = 1 , 28 rdat % r06 ( j , 1 ) = rdat % r06 ( j , 1 ) + fw6 ( j ) * fcc ( j , 6 ) enddo end subroutine intk_18 ! > ! >    @brief   dpdp case ! > ! >    @details integration of the dpdp case ! > subroutine intk_19 ( rdat , ikl ) implicit none type ( rotaxis_data_t ) :: rdat integer :: ikl real ( kind = dp ) :: xmd1 , xmd2 , xmd3 , xmd4 , xmd5 real ( kind = dp ) :: xmdt , xmdtx , xmdtxy , xmdty real ( kind = dp ) :: aqx4 , acy4 , q2c2 , x2y2 real ( kind = dp ) :: fqd11 , fqd12 , fqd13 , fqd21 , & fqd22 , fqd23 , fqd24 , fqd25 , fqd26 , & fqd31 , fqd32 , fqd33 , fqd34 real ( kind = dp ) :: y33 , y34 real ( kind = dp ) :: work , fwk , fw6 , fcu , fcc integer :: i , j ! Generate jtype=19 integrals dimension work ( 12 ), fwk ( 21 , 12 ), fw6 ( 28 ) dimension fcu ( 45 , 8 ), fcc ( 45 , 8 ) if ( ikl == 0 ) then rdat % r00 = 0.0_dp rdat % r01 = 0.0_dp rdat % r02 (:, 1 : 46 ) = 0.0_dp rdat % r03 (:, 1 : 34 ) = 0.0_dp rdat % r04 (:, 1 : 17 ) = 0.0_dp rdat % r05 (:, 1 : 6 ) = 0.0_dp rdat % r06 (:, 1 ) = 0.0_dp return endif xmd2 = rdat % x43 * 0.5d+00 xmd1 = xmd2 xmd3 = xmd2 xmd4 = xmd2 * xmd2 xmd5 = xmd4 xmdt = xmd4 * xmd3 xmdty =- xmdt * rdat % acy xmdtx =- xmdt * rdat % aqx xmdtxy = xmdt * rdat % aqxy y33 = rdat % y03 * rdat % y03 y34 =- rdat % y03 * rdat % y04 work ( 1 ) = xmd1 work ( 2 ) = y33 work ( 3 ) =- xmd3 * rdat % y03 work ( 4 ) = xmd3 * rdat % y04 work ( 5 ) = y33 * rdat % y04 work ( 6 ) =- xmd1 * rdat % y03 work ( 7 ) = xmd5 work ( 8 ) = xmd3 * y33 work ( 9 ) = xmd3 * y34 work ( 10 ) = xmd4 work ( 11 ) =- xmd5 * rdat % y03 work ( 12 ) = xmd5 * rdat % y04 call fcufcc ( rdat , 6 , xmdt , fcu , fcc ) do i = 1 , 5 do j = 1 , 5 rdat % r00 ( j , i ) = rdat % r00 ( j , i ) + rdat % fq0 ( i ) * work ( j ) end do end do do i = 1 , 8 fwk ( 1 , i ) =- rdat % fq1 ( 1 , i ) * rdat % aqx fwk ( 2 , i ) =- rdat % fq1 ( 1 , i ) * rdat % acy fwk ( 3 , i ) = rdat % fq1 ( 2 , i ) enddo fqd11 = rdat % fq1 ( 1 , 5 ) * rdat % rab + rdat % fq1 ( 1 , 7 ) fqd12 = rdat % fq1 ( 2 , 5 ) * rdat % rab + rdat % fq1 ( 2 , 7 ) fwk ( 1 , 9 ) =- fqd11 * rdat % aqx fwk ( 2 , 9 ) =- fqd11 * rdat % acy fwk ( 3 , 9 ) = fqd12 do i = 1 , 4 rdat % r01 ( 1 , i ) = rdat % r01 ( 1 , i ) + fwk ( 1 , 1 ) * work ( i + 5 ) rdat % r01 ( 2 , i ) = rdat % r01 ( 2 , i ) + fwk ( 2 , 1 ) * work ( i + 5 ) rdat % r01 ( 3 , i ) = rdat % r01 ( 3 , i ) + fwk ( 3 , 1 ) * work ( i + 5 ) enddo do i = 5 , 8 rdat % r01 ( 1 , i ) = rdat % r01 ( 1 , i ) + fwk ( 1 , 2 ) * work ( i + 1 ) rdat % r01 ( 2 , i ) = rdat % r01 ( 2 , i ) + fwk ( 2 , 2 ) * work ( i + 1 ) rdat % r01 ( 3 , i ) = rdat % r01 ( 3 , i ) + fwk ( 3 , 2 ) * work ( i + 1 ) enddo do i = 9 , 12 rdat % r01 ( 1 , i ) = rdat % r01 ( 1 , i ) + fwk ( 1 , 3 ) * work ( i - 3 ) rdat % r01 ( 2 , i ) = rdat % r01 ( 2 , i ) + fwk ( 2 , 3 ) * work ( i - 3 ) rdat % r01 ( 3 , i ) = rdat % r01 ( 3 , i ) + fwk ( 3 , 3 ) * work ( i - 3 ) enddo do i = 13 , 16 rdat % r01 ( 1 , i ) = rdat % r01 ( 1 , i ) + fwk ( 1 , 4 ) * work ( i - 7 ) rdat % r01 ( 2 , i ) = rdat % r01 ( 2 , i ) + fwk ( 2 , 4 ) * work ( i - 7 ) rdat % r01 ( 3 , i ) = rdat % r01 ( 3 , i ) + fwk ( 3 , 4 ) * work ( i - 7 ) enddo do i = 17 , 20 rdat % r01 ( 1 , i ) = rdat % r01 ( 1 , i ) + fwk ( 1 , 5 ) * work ( i - 11 ) rdat % r01 ( 2 , i ) = rdat % r01 ( 2 , i ) + fwk ( 2 , 5 ) * work ( i - 11 ) rdat % r01 ( 3 , i ) = rdat % r01 ( 3 , i ) + fwk ( 3 , 5 ) * work ( i - 11 ) enddo do i = 21 , 25 rdat % r01 ( 1 , i ) = rdat % r01 ( 1 , i ) + fwk ( 1 , 6 ) * work ( i - 20 ) rdat % r01 ( 2 , i ) = rdat % r01 ( 2 , i ) + fwk ( 2 , 6 ) * work ( i - 20 ) rdat % r01 ( 3 , i ) = rdat % r01 ( 3 , i ) + fwk ( 3 , 6 ) * work ( i - 20 ) enddo do i = 26 , 30 rdat % r01 ( 1 , i ) = rdat % r01 ( 1 , i ) + fwk ( 1 , 7 ) * work ( i - 25 ) rdat % r01 ( 2 , i ) = rdat % r01 ( 2 , i ) + fwk ( 2 , 7 ) * work ( i - 25 ) rdat % r01 ( 3 , i ) = rdat % r01 ( 3 , i ) + fwk ( 3 , 7 ) * work ( i - 25 ) enddo do i = 31 , 35 rdat % r01 ( 1 , i ) = rdat % r01 ( 1 , i ) + fwk ( 1 , 8 ) * work ( i - 30 ) rdat % r01 ( 2 , i ) = rdat % r01 ( 2 , i ) + fwk ( 2 , 8 ) * work ( i - 30 ) rdat % r01 ( 3 , i ) = rdat % r01 ( 3 , i ) + fwk ( 3 , 8 ) * work ( i - 30 ) enddo do i = 36 , 40 rdat % r01 ( 1 , i ) = rdat % r01 ( 1 , i ) + fwk ( 1 , 9 ) * work ( i - 35 ) rdat % r01 ( 2 , i ) = rdat % r01 ( 2 , i ) + fwk ( 2 , 9 ) * work ( i - 35 ) rdat % r01 ( 3 , i ) = rdat % r01 ( 3 , i ) + fwk ( 3 , 9 ) * work ( i - 35 ) enddo do i = 1 , 10 fwk ( 1 , i ) = rdat % fq2 ( 1 , i ) * rdat % aqx2 - rdat % fq1 ( 1 , i ) fwk ( 2 , i ) = rdat % fq2 ( 1 , i ) * rdat % acy2 - rdat % fq1 ( 1 , i ) fwk ( 3 , i ) = rdat % fq2 ( 3 , i ) - rdat % fq1 ( 1 , i ) fwk ( 4 , i ) = rdat % fq2 ( 1 , i ) * rdat % aqxy fwk ( 5 , i ) =- rdat % fq2 ( 2 , i ) * rdat % aqx fwk ( 6 , i ) =- rdat % fq2 ( 2 , i ) * rdat % acy enddo fqd21 = rdat % fq2 ( 1 , 5 ) * rdat % rab + rdat % fq2 ( 1 , 7 ) fqd22 = rdat % fq2 ( 2 , 5 ) * rdat % rab + rdat % fq2 ( 2 , 7 ) fqd23 = rdat % fq2 ( 3 , 5 ) * rdat % rab + rdat % fq2 ( 3 , 7 ) fwk ( 1 , 11 ) = fqd21 * rdat % aqx2 - fqd11 fwk ( 2 , 11 ) = fqd21 * rdat % acy2 - fqd11 fwk ( 3 , 11 ) = fqd23 - fqd11 fwk ( 4 , 11 ) = fqd21 * rdat % aqxy fwk ( 5 , 11 ) =- fqd22 * rdat % aqx fwk ( 6 , 11 ) =- fqd22 * rdat % acy fqd13 = rdat % fq1 ( 1 , 8 ) * rdat % rab + rdat % fq1 ( 1 , 10 ) fqd24 = rdat % fq2 ( 1 , 8 ) * rdat % rab + rdat % fq2 ( 1 , 10 ) fqd25 = rdat % fq2 ( 2 , 8 ) * rdat % rab + rdat % fq2 ( 2 , 10 ) fqd26 = rdat % fq2 ( 3 , 8 ) * rdat % rab + rdat % fq2 ( 3 , 10 ) fwk ( 1 , 12 ) = fqd24 * rdat % aqx2 - fqd13 fwk ( 2 , 12 ) = fqd24 * rdat % acy2 - fqd13 fwk ( 3 , 12 ) = fqd26 - fqd13 fwk ( 4 , 12 ) = fqd24 * rdat % aqxy fwk ( 5 , 12 ) =- fqd25 * rdat % aqx fwk ( 6 , 12 ) =- fqd25 * rdat % acy do i = 1 , 3 do j = 1 , 6 rdat % r02 ( j , i ) = rdat % r02 ( j , i ) + fwk ( j , 1 ) * work ( i + 9 ) enddo enddo do i = 4 , 6 do j = 1 , 6 rdat % r02 ( j , i ) = rdat % r02 ( j , i ) + fwk ( j , 2 ) * work ( i + 6 ) enddo enddo do i = 7 , 9 do j = 1 , 6 rdat % r02 ( j , i ) = rdat % r02 ( j , i ) + fwk ( j , 3 ) * work ( i + 3 ) enddo enddo do i = 10 , 12 do j = 1 , 6 rdat % r02 ( j , i ) = rdat % r02 ( j , i ) + fwk ( j , 4 ) * work ( i ) enddo enddo do i = 13 , 15 do j = 1 , 6 rdat % r02 ( j , i ) = rdat % r02 ( j , i ) + fwk ( j , 5 ) * work ( i - 3 ) enddo enddo do i = 16 , 19 do j = 1 , 6 rdat % r02 ( j , i ) = rdat % r02 ( j , i ) + fwk ( j , 6 ) * work ( i - 10 ) enddo enddo do i = 20 , 23 do j = 1 , 6 rdat % r02 ( j , i ) = rdat % r02 ( j , i ) + fwk ( j , 7 ) * work ( i - 14 ) enddo enddo do i = 24 , 27 do j = 1 , 6 rdat % r02 ( j , i ) = rdat % r02 ( j , i ) + fwk ( j , 8 ) * work ( i - 18 ) enddo enddo do i = 28 , 31 do j = 1 , 6 rdat % r02 ( j , i ) = rdat % r02 ( j , i ) + fwk ( j , 11 ) * work ( i - 22 ) enddo enddo do i = 32 , 36 do j = 1 , 6 rdat % r02 ( j , i ) = rdat % r02 ( j , i ) + fwk ( j , 9 ) * work ( i - 31 ) enddo enddo do i = 37 , 41 do j = 1 , 6 rdat % r02 ( j , i ) = rdat % r02 ( j , i ) + fwk ( j , 10 ) * work ( i - 36 ) enddo enddo do i = 42 , 46 do j = 1 , 6 rdat % r02 ( j , i ) = rdat % r02 ( j , i ) + fwk ( j , 12 ) * work ( i - 41 ) enddo enddo do i = 1 , 5 rdat % r03 ( 1 , i ) = rdat % r03 ( 1 , i ) + ( rdat % fq3 ( 1 , i ) * rdat % aqx2 - rdat % fq2 ( 1 , i ) * 3 ) * xmdtx rdat % r03 ( 2 , i ) = rdat % r03 ( 2 , i ) + ( rdat % fq3 ( 1 , i ) * rdat % aqx2 - rdat % fq2 ( 1 , i ) ) * xmdty rdat % r03 ( 3 , i ) = rdat % r03 ( 3 , i ) + ( rdat % fq3 ( 2 , i ) * rdat % aqx2 - rdat % fq2 ( 2 , i ) ) * xmdt rdat % r03 ( 4 , i ) = rdat % r03 ( 4 , i ) + ( rdat % fq3 ( 1 , i ) * rdat % acy2 - rdat % fq2 ( 1 , i ) ) * xmdtx rdat % r03 ( 5 , i ) = rdat % r03 ( 5 , i ) + rdat % fq3 ( 2 , i ) * xmdtxy rdat % r03 ( 6 , i ) = rdat % r03 ( 6 , i ) + ( rdat % fq3 ( 3 , i ) - rdat % fq2 ( 1 , i ) ) * xmdtx rdat % r03 ( 7 , i ) = rdat % r03 ( 7 , i ) + ( rdat % fq3 ( 1 , i ) * rdat % acy2 - rdat % fq2 ( 1 , i ) * 3 ) * xmdty rdat % r03 ( 8 , i ) = rdat % r03 ( 8 , i ) + ( rdat % fq3 ( 2 , i ) * rdat % acy2 - rdat % fq2 ( 2 , i ) ) * xmdt rdat % r03 ( 9 , i ) = rdat % r03 ( 9 , i ) + ( rdat % fq3 ( 3 , i ) - rdat % fq2 ( 1 , i ) ) * xmdty rdat % r03 ( 10 , i ) = rdat % r03 ( 10 , i ) + ( rdat % fq3 ( 4 , i ) - rdat % fq2 ( 2 , i ) * 3 ) * xmdt enddo rdat % fq2 ( 1 , 5 ) = fqd21 rdat % fq2 ( 2 , 5 ) = fqd22 rdat % fq3 ( 1 , 5 ) = rdat % fq3 ( 1 , 5 ) * rdat % rab + rdat % fq3 ( 1 , 7 ) rdat % fq3 ( 2 , 5 ) = rdat % fq3 ( 2 , 5 ) * rdat % rab + rdat % fq3 ( 2 , 7 ) rdat % fq3 ( 3 , 5 ) = rdat % fq3 ( 3 , 5 ) * rdat % rab + rdat % fq3 ( 3 , 7 ) rdat % fq3 ( 4 , 5 ) = rdat % fq3 ( 4 , 5 ) * rdat % rab + rdat % fq3 ( 4 , 7 ) do i = 5 , 11 fwk ( 1 , i ) =- ( rdat % fq3 ( 1 , i ) * rdat % aqx2 - rdat % fq2 ( 1 , i ) * 3 ) * rdat % aqx fwk ( 2 , i ) =- ( rdat % fq3 ( 1 , i ) * rdat % aqx2 - rdat % fq2 ( 1 , i ) ) * rdat % acy fwk ( 3 , i ) = rdat % fq3 ( 2 , i ) * rdat % aqx2 - rdat % fq2 ( 2 , i ) fwk ( 4 , i ) =- ( rdat % fq3 ( 1 , i ) * rdat % acy2 - rdat % fq2 ( 1 , i ) ) * rdat % aqx fwk ( 5 , i ) = rdat % fq3 ( 2 , i ) * rdat % aqxy fwk ( 6 , i ) =- ( rdat % fq3 ( 3 , i ) - rdat % fq2 ( 1 , i ) ) * rdat % aqx fwk ( 7 , i ) =- ( rdat % fq3 ( 1 , i ) * rdat % acy2 - rdat % fq2 ( 1 , i ) * 3 ) * rdat % acy fwk ( 8 , i ) = rdat % fq3 ( 2 , i ) * rdat % acy2 - rdat % fq2 ( 2 , i ) fwk ( 9 , i ) =- ( rdat % fq3 ( 3 , i ) - rdat % fq2 ( 1 , i ) ) * rdat % acy fwk ( 10 , i ) = rdat % fq3 ( 4 , i ) - rdat % fq2 ( 2 , i ) * 3 enddo fqd31 = rdat % fq3 ( 1 , 8 ) * rdat % rab + rdat % fq3 ( 1 , 10 ) fqd32 = rdat % fq3 ( 2 , 8 ) * rdat % rab + rdat % fq3 ( 2 , 10 ) fqd33 = rdat % fq3 ( 3 , 8 ) * rdat % rab + rdat % fq3 ( 3 , 10 ) fqd34 = rdat % fq3 ( 4 , 8 ) * rdat % rab + rdat % fq3 ( 4 , 10 ) fwk ( 1 , 12 ) =- ( fqd31 * rdat % aqx2 - fqd24 * 3 ) * rdat % aqx fwk ( 2 , 12 ) =- ( fqd31 * rdat % aqx2 - fqd24 ) * rdat % acy fwk ( 3 , 12 ) = fqd32 * rdat % aqx2 - fqd25 fwk ( 4 , 12 ) =- ( fqd31 * rdat % acy2 - fqd24 ) * rdat % aqx fwk ( 5 , 12 ) = fqd32 * rdat % aqxy fwk ( 6 , 12 ) =- ( fqd33 - fqd24 ) * rdat % aqx fwk ( 7 , 12 ) =- ( fqd31 * rdat % acy2 - fqd24 * 3 ) * rdat % acy fwk ( 8 , 12 ) = fqd32 * rdat % acy2 - fqd25 fwk ( 9 , 12 ) =- ( fqd33 - fqd24 ) * rdat % acy fwk ( 10 , 12 ) = fqd34 - fqd25 * 3 do i = 6 , 8 do j = 1 , 10 rdat % r03 ( j , i ) = rdat % r03 ( j , i ) + fwk ( j , 5 ) * work ( i + 4 ) enddo enddo do i = 9 , 11 do j = 1 , 10 rdat % r03 ( j , i ) = rdat % r03 ( j , i ) + fwk ( j , 6 ) * work ( i + 1 ) enddo enddo do i = 12 , 14 do j = 1 , 10 rdat % r03 ( j , i ) = rdat % r03 ( j , i ) + fwk ( j , 7 ) * work ( i - 2 ) enddo enddo do i = 15 , 17 do j = 1 , 10 rdat % r03 ( j , i ) = rdat % r03 ( j , i ) + fwk ( j , 8 ) * work ( i - 5 ) enddo enddo do i = 18 , 21 do j = 1 , 10 rdat % r03 ( j , i ) = rdat % r03 ( j , i ) + fwk ( j , 9 ) * work ( i - 12 ) enddo enddo do i = 22 , 25 do j = 1 , 10 rdat % r03 ( j , i ) = rdat % r03 ( j , i ) + fwk ( j , 10 ) * work ( i - 16 ) enddo enddo do i = 26 , 29 do j = 1 , 10 rdat % r03 ( j , i ) = rdat % r03 ( j , i ) + fwk ( j , 12 ) * work ( i - 20 ) enddo enddo do i = 30 , 34 do j = 1 , 10 rdat % r03 ( j , i ) = rdat % r03 ( j , i ) + fwk ( j , 11 ) * work ( i - 29 ) enddo enddo do j = 1 , 5 rdat % fq4 ( j , 1 ) = rdat % fq4 ( j , 1 ) * rdat % rab + rdat % fq4 ( j , 3 ) enddo aqx4 = rdat % aqx2 * rdat % aqx2 acy4 = rdat % acy2 * rdat % acy2 x2y2 = rdat % aqx2 * rdat % acy2 q2c2 = rdat % aqx2 + rdat % acy2 do i = 1 , 4 rdat % r04 ( 1 , i ) = rdat % r04 ( 1 , i ) + ( rdat % fq4 ( 1 , i ) * aqx4 - rdat % fq3 ( 1 , i + 4 ) * 6 * rdat % aqx2 & & + rdat % fq2 ( 1 , i + 4 ) * 3 ) * xmdt rdat % r04 ( 2 , i ) = rdat % r04 ( 2 , i ) + ( rdat % fq4 ( 1 , i ) * rdat % aqx2 - rdat % fq3 ( 1 , i + 4 ) * 3 ) * xmdtxy rdat % r04 ( 3 , i ) = rdat % r04 ( 3 , i ) + ( rdat % fq4 ( 2 , i ) * rdat % aqx2 - rdat % fq3 ( 2 , i + 4 ) * 3 ) * xmdtx rdat % r04 ( 4 , i ) = rdat % r04 ( 4 , i ) + ( rdat % fq4 ( 1 , i ) * x2y2 - rdat % fq3 ( 1 , i + 4 ) * q2c2 & & + rdat % fq2 ( 1 , i + 4 ) ) * xmdt rdat % r04 ( 5 , i ) = rdat % r04 ( 5 , i ) + ( rdat % fq4 ( 2 , i ) * rdat % aqx2 - rdat % fq3 ( 2 , i + 4 ) ) * xmdty rdat % r04 ( 6 , i ) = rdat % r04 ( 6 , i ) + ( rdat % fq4 ( 3 , i ) * rdat % aqx2 - rdat % fq3 ( 1 , i + 4 ) * rdat % aqx2 & & - rdat % fq3 ( 3 , i + 4 ) + rdat % fq2 ( 1 , i + 4 ) ) * xmdt rdat % r04 ( 7 , i ) = rdat % r04 ( 7 , i ) + ( rdat % fq4 ( 1 , i ) * rdat % acy2 - rdat % fq3 ( 1 , i + 4 ) * 3 ) * xmdtxy rdat % r04 ( 8 , i ) = rdat % r04 ( 8 , i ) + ( rdat % fq4 ( 2 , i ) * rdat % acy2 - rdat % fq3 ( 2 , i + 4 ) ) * xmdtx rdat % r04 ( 9 , i ) = rdat % r04 ( 9 , i ) + ( rdat % fq4 ( 3 , i ) - rdat % fq3 ( 1 , i + 4 ) ) * xmdtxy rdat % r04 ( 10 , i ) = rdat % r04 ( 10 , i ) + ( rdat % fq4 ( 4 , i ) - rdat % fq3 ( 2 , i + 4 ) * 3 ) * xmdtx rdat % r04 ( 11 , i ) = rdat % r04 ( 11 , i ) + ( rdat % fq4 ( 1 , i ) * acy4 - rdat % fq3 ( 1 , i + 4 ) * 6 * rdat % acy2 & & + rdat % fq2 ( 1 , i + 4 ) * 3 ) * xmdt rdat % r04 ( 12 , i ) = rdat % r04 ( 12 , i ) + ( rdat % fq4 ( 2 , i ) * rdat % acy2 - rdat % fq3 ( 2 , i + 4 ) * 3 ) * xmdty rdat % r04 ( 13 , i ) = rdat % r04 ( 13 , i ) + ( rdat % fq4 ( 3 , i ) * rdat % acy2 - rdat % fq3 ( 1 , i + 4 ) * rdat % acy2 & & - rdat % fq3 ( 3 , i + 4 ) + rdat % fq2 ( 1 , i + 4 ) ) * xmdt rdat % r04 ( 14 , i ) = rdat % r04 ( 14 , i ) + ( rdat % fq4 ( 4 , i ) - rdat % fq3 ( 2 , i + 4 ) * 3 ) * xmdty rdat % r04 ( 15 , i ) = rdat % r04 ( 15 , i ) + ( rdat % fq4 ( 5 , i ) - rdat % fq3 ( 3 , i + 4 ) * 6 & & + rdat % fq2 ( 1 , i + 4 ) * 3 ) * xmdt enddo rdat % fq2 ( 1 , 8 ) = fqd24 rdat % fq3 ( 1 , 8 ) = fqd31 rdat % fq3 ( 2 , 8 ) = fqd32 rdat % fq3 ( 3 , 8 ) = fqd33 do j = 1 , 5 rdat % fq4 ( j , 4 ) = rdat % fq4 ( j , 4 ) * rdat % rab + rdat % fq4 ( j , 6 ) enddo do i = 4 , 7 fwk ( 1 , i ) = rdat % fq4 ( 1 , i ) * aqx4 - rdat % fq3 ( 1 , i + 4 ) * 6 * rdat % aqx2 & & + rdat % fq2 ( 1 , i + 4 ) * 3 fwk ( 2 , i ) = ( rdat % fq4 ( 1 , i ) * rdat % aqx2 - rdat % fq3 ( 1 , i + 4 ) * 3 ) * rdat % aqxy fwk ( 3 , i ) =- ( rdat % fq4 ( 2 , i ) * rdat % aqx2 - rdat % fq3 ( 2 , i + 4 ) * 3 ) * rdat % aqx fwk ( 4 , i ) = rdat % fq4 ( 1 , i ) * x2y2 - rdat % fq3 ( 1 , i + 4 ) * q2c2 + rdat % fq2 ( 1 , i + 4 ) fwk ( 5 , i ) =- ( rdat % fq4 ( 2 , i ) * rdat % aqx2 - rdat % fq3 ( 2 , i + 4 ) ) * rdat % acy fwk ( 6 , i ) = rdat % fq4 ( 3 , i ) * rdat % aqx2 - rdat % fq3 ( 1 , i + 4 ) * rdat % aqx2 - rdat % fq3 ( 3 , i + 4 ) & & + rdat % fq2 ( 1 , i + 4 ) fwk ( 7 , i ) = ( rdat % fq4 ( 1 , i ) * rdat % acy2 - rdat % fq3 ( 1 , i + 4 ) * 3 ) * rdat % aqxy fwk ( 8 , i ) =- ( rdat % fq4 ( 2 , i ) * rdat % acy2 - rdat % fq3 ( 2 , i + 4 ) ) * rdat % aqx fwk ( 9 , i ) = ( rdat % fq4 ( 3 , i ) - rdat % fq3 ( 1 , i + 4 ) ) * rdat % aqxy fwk ( 10 , i ) =- ( rdat % fq4 ( 4 , i ) - rdat % fq3 ( 2 , i + 4 ) * 3 ) * rdat % aqx fwk ( 11 , i ) = rdat % fq4 ( 1 , i ) * acy4 - rdat % fq3 ( 1 , i + 4 ) * 6 * rdat % acy2 & & + rdat % fq2 ( 1 , i + 4 ) * 3 fwk ( 12 , i ) =- ( rdat % fq4 ( 2 , i ) * rdat % acy2 - rdat % fq3 ( 2 , i + 4 ) * 3 ) * rdat % acy fwk ( 13 , i ) = rdat % fq4 ( 3 , i ) * rdat % acy2 - rdat % fq3 ( 1 , i + 4 ) * rdat % acy2 - rdat % fq3 ( 3 , i + 4 ) & & + rdat % fq2 ( 1 , i + 4 ) fwk ( 14 , i ) =- ( rdat % fq4 ( 4 , i ) - rdat % fq3 ( 2 , i + 4 ) * 3 ) * rdat % acy fwk ( 15 , i ) = rdat % fq4 ( 5 , i ) - rdat % fq3 ( 3 , i + 4 ) * 6 + rdat % fq2 ( 1 , i + 4 ) * 3 enddo do i = 5 , 7 do j = 1 , 15 rdat % r04 ( j , i ) = rdat % r04 ( j , i ) + fwk ( j , 5 ) * work ( i + 5 ) enddo enddo do i = 8 , 10 do j = 1 , 15 rdat % r04 ( j , i ) = rdat % r04 ( j , i ) + fwk ( j , 6 ) * work ( i + 2 ) enddo enddo do i = 11 , 13 do j = 1 , 15 rdat % r04 ( j , i ) = rdat % r04 ( j , i ) + fwk ( j , 4 ) * work ( i - 1 ) enddo enddo do i = 14 , 17 do j = 1 , 15 rdat % r04 ( j , i ) = rdat % r04 ( j , i ) + fwk ( j , 7 ) * work ( i - 8 ) enddo enddo do j = 1 , 6 rdat % fq5 ( j , 1 ) = rdat % fq5 ( j , 1 ) * rdat % rab + rdat % fq5 ( j , 3 ) enddo do i = 1 , 3 rdat % r05 ( 1 , i ) = rdat % r05 ( 1 , i ) + ( rdat % fq5 ( 1 , i ) * aqx4 - rdat % fq4 ( 1 , i + 3 ) * 10 * rdat % aqx2 & & + rdat % fq3 ( 1 , i + 7 ) * 15 ) * xmdtx rdat % r05 ( 2 , i ) = rdat % r05 ( 2 , i ) + ( rdat % fq5 ( 1 , i ) * aqx4 - rdat % fq4 ( 1 , i + 3 ) * 6 * rdat % aqx2 & & + rdat % fq3 ( 1 , i + 7 ) * 3 ) * xmdty rdat % r05 ( 3 , i ) = rdat % r05 ( 3 , i ) + ( rdat % fq5 ( 2 , i ) * aqx4 - rdat % fq4 ( 2 , i + 3 ) * 6 * rdat % aqx2 & & + rdat % fq3 ( 2 , i + 7 ) * 3 ) * xmdt rdat % r05 ( 4 , i ) = rdat % r05 ( 4 , i ) + ( rdat % fq5 ( 1 , i ) * x2y2 - rdat % fq4 ( 1 , i + 3 ) * 3 * rdat % acy2 & & - rdat % fq4 ( 1 , i + 3 ) * rdat % aqx2 + rdat % fq3 ( 1 , i + 7 ) * 3 ) * xmdtx rdat % r05 ( 5 , i ) = rdat % r05 ( 5 , i ) + ( rdat % fq5 ( 2 , i ) * rdat % aqx2 - rdat % fq4 ( 2 , i + 3 ) * 3 ) * xmdtxy rdat % r05 ( 6 , i ) = rdat % r05 ( 6 , i ) + ( rdat % fq5 ( 3 , i ) * rdat % aqx2 - rdat % fq4 ( 1 , i + 3 ) * rdat % aqx2 & & - rdat % fq4 ( 3 , i + 3 ) * 3 + rdat % fq3 ( 1 , i + 7 ) * 3 ) * xmdtx rdat % r05 ( 7 , i ) = rdat % r05 ( 7 , i ) + ( rdat % fq5 ( 1 , i ) * x2y2 - rdat % fq4 ( 1 , i + 3 ) * 3 * rdat % aqx2 & & - rdat % fq4 ( 1 , i + 3 ) * rdat % acy2 + rdat % fq3 ( 1 , i + 7 ) * 3 ) * xmdty rdat % r05 ( 8 , i ) = rdat % r05 ( 8 , i ) + ( rdat % fq5 ( 2 , i ) * x2y2 - rdat % fq4 ( 2 , i + 3 ) * q2c2 & & + rdat % fq3 ( 2 , i + 7 ) ) * xmdt rdat % r05 ( 9 , i ) = rdat % r05 ( 9 , i ) + ( rdat % fq5 ( 3 , i ) * rdat % aqx2 - rdat % fq4 ( 1 , i + 3 ) * rdat % aqx2 & & - rdat % fq4 ( 3 , i + 3 ) + rdat % fq3 ( 1 , i + 7 ) ) * xmdty rdat % r05 ( 10 , i ) = rdat % r05 ( 10 , i ) + ( rdat % fq5 ( 4 , i ) * rdat % aqx2 - rdat % fq4 ( 2 , i + 3 ) * 3 * rdat % aqx2 & & - rdat % fq4 ( 4 , i + 3 ) + rdat % fq3 ( 2 , i + 7 ) * 3 ) * xmdt rdat % r05 ( 11 , i ) = rdat % r05 ( 11 , i ) + ( rdat % fq5 ( 1 , i ) * acy4 - rdat % fq4 ( 1 , i + 3 ) * 6 * rdat % acy2 & & + rdat % fq3 ( 1 , i + 7 ) * 3 ) * xmdtx rdat % r05 ( 12 , i ) = rdat % r05 ( 12 , i ) + ( rdat % fq5 ( 2 , i ) * rdat % acy2 - rdat % fq4 ( 2 , i + 3 ) * 3 ) * xmdtxy rdat % r05 ( 13 , i ) = rdat % r05 ( 13 , i ) + ( rdat % fq5 ( 3 , i ) * rdat % acy2 - rdat % fq4 ( 1 , i + 3 ) * rdat % acy2 & & - rdat % fq4 ( 3 , i + 3 ) + rdat % fq3 ( 1 , i + 7 ) ) * xmdtx rdat % r05 ( 14 , i ) = rdat % r05 ( 14 , i ) + ( rdat % fq5 ( 4 , i ) - rdat % fq4 ( 2 , i + 3 ) * 3 ) * xmdtxy rdat % r05 ( 15 , i ) = rdat % r05 ( 15 , i ) + ( rdat % fq5 ( 5 , i ) - rdat % fq4 ( 3 , i + 3 ) * 6 & & + rdat % fq3 ( 1 , i + 7 ) * 3 ) * xmdtx rdat % r05 ( 16 , i ) = rdat % r05 ( 16 , i ) + ( rdat % fq5 ( 1 , i ) * acy4 - rdat % fq4 ( 1 , i + 3 ) * 10 * rdat % acy2 & & + rdat % fq3 ( 1 , i + 7 ) * 15 ) * xmdty rdat % r05 ( 17 , i ) = rdat % r05 ( 17 , i ) + ( rdat % fq5 ( 2 , i ) * acy4 - rdat % fq4 ( 2 , i + 3 ) * 6 * rdat % acy2 & & + rdat % fq3 ( 2 , i + 7 ) * 3 ) * xmdt rdat % r05 ( 18 , i ) = rdat % r05 ( 18 , i ) + ( rdat % fq5 ( 3 , i ) * rdat % acy2 - rdat % fq4 ( 1 , i + 3 ) * rdat % acy2 & & - rdat % fq4 ( 3 , i + 3 ) * 3 + rdat % fq3 ( 1 , i + 7 ) * 3 ) * xmdty rdat % r05 ( 19 , i ) = rdat % r05 ( 19 , i ) + ( rdat % fq5 ( 4 , i ) * rdat % acy2 - rdat % fq4 ( 2 , i + 3 ) * 3 * rdat % acy2 & & - rdat % fq4 ( 4 , i + 3 ) + rdat % fq3 ( 2 , i + 7 ) * 3 ) * xmdt rdat % r05 ( 20 , i ) = rdat % r05 ( 20 , i ) + ( rdat % fq5 ( 5 , i ) - rdat % fq4 ( 3 , i + 3 ) * 6 & & + rdat % fq3 ( 1 , i + 7 ) * 3 ) * xmdty rdat % r05 ( 21 , i ) = rdat % r05 ( 21 , i ) + ( rdat % fq5 ( 6 , i ) - rdat % fq4 ( 4 , i + 3 ) * 10 & & + rdat % fq3 ( 2 , i + 7 ) * 15 ) * xmdt enddo fwk ( 1 , 4 ) =- ( rdat % fq5 ( 1 , 4 ) * aqx4 - rdat % fq4 ( 1 , 7 ) * 10 * rdat % aqx2 + rdat % fq3 ( 1 , 11 ) * 15 ) * rdat % aqx fwk ( 2 , 4 ) =- ( rdat % fq5 ( 1 , 4 ) * aqx4 - rdat % fq4 ( 1 , 7 ) * 6 * rdat % aqx2 + rdat % fq3 ( 1 , 11 ) * 3 ) * rdat % acy fwk ( 3 , 4 ) = rdat % fq5 ( 2 , 4 ) * aqx4 - rdat % fq4 ( 2 , 7 ) * 6 * rdat % aqx2 + rdat % fq3 ( 2 , 11 ) * 3 fwk ( 4 , 4 ) =- ( rdat % fq5 ( 1 , 4 ) * x2y2 - rdat % fq4 ( 1 , 7 ) * rdat % aqx2 - rdat % fq4 ( 1 , 7 ) * 3 * rdat % acy2 & & + rdat % fq3 ( 1 , 11 ) * 3 ) * rdat % aqx fwk ( 5 , 4 ) = ( rdat % fq5 ( 2 , 4 ) * rdat % aqx2 - rdat % fq4 ( 2 , 7 ) * 3 ) * rdat % aqxy fwk ( 6 , 4 ) =- ( rdat % fq5 ( 3 , 4 ) * rdat % aqx2 - rdat % fq4 ( 1 , 7 ) * rdat % aqx2 - rdat % fq4 ( 3 , 7 ) * 3 & & + rdat % fq3 ( 1 , 11 ) * 3 ) * rdat % aqx fwk ( 7 , 4 ) =- ( rdat % fq5 ( 1 , 4 ) * x2y2 - rdat % fq4 ( 1 , 7 ) * 3 * rdat % aqx2 - rdat % fq4 ( 1 , 7 ) * rdat % acy2 & & + rdat % fq3 ( 1 , 11 ) * 3 ) * rdat % acy fwk ( 8 , 4 ) = rdat % fq5 ( 2 , 4 ) * x2y2 - rdat % fq4 ( 2 , 7 ) * q2c2 + rdat % fq3 ( 2 , 11 ) fwk ( 9 , 4 ) =- ( rdat % fq5 ( 3 , 4 ) * rdat % aqx2 - rdat % fq4 ( 1 , 7 ) * rdat % aqx2 - rdat % fq4 ( 3 , 7 ) & & + rdat % fq3 ( 1 , 11 ) ) * rdat % acy fwk ( 10 , 4 ) = rdat % fq5 ( 4 , 4 ) * rdat % aqx2 - rdat % fq4 ( 2 , 7 ) * 3 * rdat % aqx2 - rdat % fq4 ( 4 , 7 ) & & + rdat % fq3 ( 2 , 11 ) * 3 fwk ( 11 , 4 ) =- ( rdat % fq5 ( 1 , 4 ) * acy4 - rdat % fq4 ( 1 , 7 ) * 6 * rdat % acy2 & & + rdat % fq3 ( 1 , 11 ) * 3 ) * rdat % aqx fwk ( 12 , 4 ) = ( rdat % fq5 ( 2 , 4 ) * rdat % acy2 - rdat % fq4 ( 2 , 7 ) * 3 ) * rdat % aqxy fwk ( 13 , 4 ) =- ( rdat % fq5 ( 3 , 4 ) * rdat % acy2 - rdat % fq4 ( 1 , 7 ) * rdat % acy2 - rdat % fq4 ( 3 , 7 ) & & + rdat % fq3 ( 1 , 11 ) ) * rdat % aqx fwk ( 14 , 4 ) = ( rdat % fq5 ( 4 , 4 ) - rdat % fq4 ( 2 , 7 ) * 3 ) * rdat % aqxy fwk ( 15 , 4 ) =- ( rdat % fq5 ( 5 , 4 ) - rdat % fq4 ( 3 , 7 ) * 6 + rdat % fq3 ( 1 , 11 ) * 3 ) * rdat % aqx fwk ( 16 , 4 ) =- ( rdat % fq5 ( 1 , 4 ) * acy4 - rdat % fq4 ( 1 , 7 ) * 10 * rdat % acy2 & & + rdat % fq3 ( 1 , 11 ) * 15 ) * rdat % acy fwk ( 17 , 4 ) = rdat % fq5 ( 2 , 4 ) * acy4 - rdat % fq4 ( 2 , 7 ) * 6 * rdat % acy2 + rdat % fq3 ( 2 , 11 ) * 3 fwk ( 18 , 4 ) =- ( rdat % fq5 ( 3 , 4 ) * rdat % acy2 - rdat % fq4 ( 1 , 7 ) * rdat % acy2 - rdat % fq4 ( 3 , 7 ) * 3 & & + rdat % fq3 ( 1 , 11 ) * 3 ) * rdat % acy fwk ( 19 , 4 ) = rdat % fq5 ( 4 , 4 ) * rdat % acy2 - rdat % fq4 ( 2 , 7 ) * 3 * rdat % acy2 - rdat % fq4 ( 4 , 7 ) & & + rdat % fq3 ( 2 , 11 ) * 3 fwk ( 20 , 4 ) =- ( rdat % fq5 ( 5 , 4 ) - rdat % fq4 ( 3 , 7 ) * 6 + rdat % fq3 ( 1 , 11 ) * 3 ) * rdat % acy fwk ( 21 , 4 ) = rdat % fq5 ( 6 , 4 ) - rdat % fq4 ( 4 , 7 ) * 10 + rdat % fq3 ( 2 , 11 ) * 15 do i = 4 , 6 do j = 1 , 21 rdat % r05 ( j , i ) = rdat % r05 ( j , i ) + fwk ( j , 4 ) * work ( i + 6 ) end do end do call frikr6 ( rdat , 1 , 1 , fw6 , rdat % fq6 , 3 , rdat % fq5 , 6 , rdat % fq4 , 10 , rdat % fq3 ) do j = 1 , 28 rdat % r06 ( j , 1 ) = rdat % r06 ( j , 1 ) + fw6 ( j ) * fcc ( j , 6 ) enddo end subroutine intk_19 ! > ! >    @brief   dddp case ! > ! >    @details integration of the dddp case ! > subroutine intk_20 ( rdat , ikl ) implicit none type ( rotaxis_data_t ) :: rdat integer :: ikl real ( kind = dp ) :: xmd2 , xmd3 , xmd4 , xmd6 real ( kind = dp ) :: xmdt , xmdtx , xmdtxy , xmdty real ( kind = dp ) :: aqx4 , acy4 , q2c2 , x2y2 real ( kind = dp ) :: y33 , y34 , y44 real ( kind = dp ) :: work , fwk , fw6 , fw7 , fcu , fcc integer :: i , j ! Generate jtype=20 integrals dimension work ( 15 ), fwk ( 28 , 13 ), fw6 ( 28 , 4 ), fw7 ( 36 ) dimension fcu ( 45 , 8 ), fcc ( 45 , 8 ) if ( ikl == 0 ) then rdat % r00 = 0.0_dp rdat % r01 = 0.0_dp rdat % r02 (:, 1 : 51 ) = 0.0_dp rdat % r03 (:, 1 : 43 ) = 0.0_dp rdat % r04 (:, 1 : 29 ) = 0.0_dp rdat % r05 (:, 1 : 14 ) = 0.0_dp rdat % r06 (:, 1 : 5 ) = 0.0_dp rdat % r07 (:, 1 ) = 0.0_dp return endif xmd2 = rdat % x43 * 0.5d+00 xmd3 = xmd2 xmd4 = xmd3 * xmd2 xmd6 = xmd4 * xmd2 xmdt = xmd6 * xmd2 xmd2 = xmd3 xmdty =- xmdt * rdat % acy xmdtx =- xmdt * rdat % aqx xmdtxy = xmdt * rdat % aqxy y33 = rdat % y03 * rdat % y03 y34 =- rdat % y03 * rdat % y04 y44 = rdat % y04 * rdat % y04 work ( 1 ) = xmd4 work ( 2 ) = xmd2 * y33 work ( 3 ) = xmd2 * y34 work ( 4 ) = xmd2 * y44 work ( 5 ) = y33 * y44 work ( 6 ) =- xmd4 * rdat % y03 work ( 7 ) = xmd4 * rdat % y04 work ( 8 ) = xmd2 * y33 * rdat % y04 work ( 9 ) = xmd2 * y34 * rdat % y04 work ( 10 ) = xmd6 work ( 11 ) = xmd4 * y33 work ( 12 ) = xmd4 * y34 work ( 13 ) = xmd4 * y44 work ( 14 ) =- xmd6 * rdat % y03 work ( 15 ) = xmd6 * rdat % y04 call fcufcc ( rdat , 7 , xmdt , fcu , fcc ) do i = 1 , 5 do j = 1 , 5 rdat % r00 ( j , i ) = rdat % r00 ( j , i ) + rdat % fq0 ( i ) * work ( j ) end do end do do i = 1 , 8 fwk ( 1 , i ) =- rdat % fq1 ( 1 , i ) * rdat % aqx fwk ( 2 , i ) =- rdat % fq1 ( 1 , i ) * rdat % acy fwk ( 3 , i ) = rdat % fq1 ( 2 , i ) enddo rdat % fq1 ( 1 , 12 ) = rdat % fq1 ( 1 , 8 ) * rdat % rab + rdat % fq1 ( 1 , 10 ) rdat % fq1 ( 1 , 13 ) = rdat % fq1 ( 1 , 5 ) * rdat % rab + rdat % fq1 ( 1 , 7 ) rdat % fq1 ( 2 , 13 ) = rdat % fq1 ( 2 , 5 ) * rdat % rab + rdat % fq1 ( 2 , 7 ) fwk ( 1 , 9 ) =- rdat % fq1 ( 1 , 13 ) * rdat % aqx fwk ( 2 , 9 ) =- rdat % fq1 ( 1 , 13 ) * rdat % acy fwk ( 3 , 9 ) = rdat % fq1 ( 2 , 13 ) do i = 1 , 4 rdat % r01 ( 1 , i ) = rdat % r01 ( 1 , i ) + fwk ( 1 , 1 ) * work ( i + 5 ) rdat % r01 ( 2 , i ) = rdat % r01 ( 2 , i ) + fwk ( 2 , 1 ) * work ( i + 5 ) rdat % r01 ( 3 , i ) = rdat % r01 ( 3 , i ) + fwk ( 3 , 1 ) * work ( i + 5 ) enddo do i = 5 , 8 rdat % r01 ( 1 , i ) = rdat % r01 ( 1 , i ) + fwk ( 1 , 2 ) * work ( i + 1 ) rdat % r01 ( 2 , i ) = rdat % r01 ( 2 , i ) + fwk ( 2 , 2 ) * work ( i + 1 ) rdat % r01 ( 3 , i ) = rdat % r01 ( 3 , i ) + fwk ( 3 , 2 ) * work ( i + 1 ) enddo do i = 9 , 12 rdat % r01 ( 1 , i ) = rdat % r01 ( 1 , i ) + fwk ( 1 , 3 ) * work ( i - 3 ) rdat % r01 ( 2 , i ) = rdat % r01 ( 2 , i ) + fwk ( 2 , 3 ) * work ( i - 3 ) rdat % r01 ( 3 , i ) = rdat % r01 ( 3 , i ) + fwk ( 3 , 3 ) * work ( i - 3 ) enddo do i = 13 , 16 rdat % r01 ( 1 , i ) = rdat % r01 ( 1 , i ) + fwk ( 1 , 4 ) * work ( i - 7 ) rdat % r01 ( 2 , i ) = rdat % r01 ( 2 , i ) + fwk ( 2 , 4 ) * work ( i - 7 ) rdat % r01 ( 3 , i ) = rdat % r01 ( 3 , i ) + fwk ( 3 , 4 ) * work ( i - 7 ) enddo do i = 17 , 20 rdat % r01 ( 1 , i ) = rdat % r01 ( 1 , i ) + fwk ( 1 , 5 ) * work ( i - 11 ) rdat % r01 ( 2 , i ) = rdat % r01 ( 2 , i ) + fwk ( 2 , 5 ) * work ( i - 11 ) rdat % r01 ( 3 , i ) = rdat % r01 ( 3 , i ) + fwk ( 3 , 5 ) * work ( i - 11 ) enddo do i = 21 , 25 rdat % r01 ( 1 , i ) = rdat % r01 ( 1 , i ) + fwk ( 1 , 6 ) * work ( i - 20 ) rdat % r01 ( 2 , i ) = rdat % r01 ( 2 , i ) + fwk ( 2 , 6 ) * work ( i - 20 ) rdat % r01 ( 3 , i ) = rdat % r01 ( 3 , i ) + fwk ( 3 , 6 ) * work ( i - 20 ) enddo do i = 26 , 30 rdat % r01 ( 1 , i ) = rdat % r01 ( 1 , i ) + fwk ( 1 , 7 ) * work ( i - 25 ) rdat % r01 ( 2 , i ) = rdat % r01 ( 2 , i ) + fwk ( 2 , 7 ) * work ( i - 25 ) rdat % r01 ( 3 , i ) = rdat % r01 ( 3 , i ) + fwk ( 3 , 7 ) * work ( i - 25 ) enddo do i = 31 , 35 rdat % r01 ( 1 , i ) = rdat % r01 ( 1 , i ) + fwk ( 1 , 8 ) * work ( i - 30 ) rdat % r01 ( 2 , i ) = rdat % r01 ( 2 , i ) + fwk ( 2 , 8 ) * work ( i - 30 ) rdat % r01 ( 3 , i ) = rdat % r01 ( 3 , i ) + fwk ( 3 , 8 ) * work ( i - 30 ) enddo do i = 36 , 40 rdat % r01 ( 1 , i ) = rdat % r01 ( 1 , i ) + fwk ( 1 , 9 ) * work ( i - 35 ) rdat % r01 ( 2 , i ) = rdat % r01 ( 2 , i ) + fwk ( 2 , 9 ) * work ( i - 35 ) rdat % r01 ( 3 , i ) = rdat % r01 ( 3 , i ) + fwk ( 3 , 9 ) * work ( i - 35 ) enddo do i = 1 , 10 fwk ( 1 , i ) = rdat % fq2 ( 1 , i ) * rdat % aqx2 - rdat % fq1 ( 1 , i ) fwk ( 2 , i ) = rdat % fq2 ( 1 , i ) * rdat % acy2 - rdat % fq1 ( 1 , i ) fwk ( 3 , i ) = rdat % fq2 ( 3 , i ) - rdat % fq1 ( 1 , i ) fwk ( 4 , i ) = rdat % fq2 ( 1 , i ) * rdat % aqxy fwk ( 5 , i ) =- rdat % fq2 ( 2 , i ) * rdat % aqx fwk ( 6 , i ) =- rdat % fq2 ( 2 , i ) * rdat % acy enddo do i = 1 , 3 rdat % fq2 ( i , 12 ) = rdat % fq2 ( i , 8 ) * rdat % rab + rdat % fq2 ( i , 10 ) rdat % fq2 ( i , 13 ) = rdat % fq2 ( i , 5 ) * rdat % rab + rdat % fq2 ( i , 7 ) enddo do i = 12 , 13 fwk ( 1 , i ) = rdat % fq2 ( 1 , i ) * rdat % aqx2 - rdat % fq1 ( 1 , i ) fwk ( 2 , i ) = rdat % fq2 ( 1 , i ) * rdat % acy2 - rdat % fq1 ( 1 , i ) fwk ( 3 , i ) = rdat % fq2 ( 3 , i ) - rdat % fq1 ( 1 , i ) fwk ( 4 , i ) = rdat % fq2 ( 1 , i ) * rdat % aqxy fwk ( 5 , i ) =- rdat % fq2 ( 2 , i ) * rdat % aqx fwk ( 6 , i ) =- rdat % fq2 ( 2 , i ) * rdat % acy enddo do i = 1 , 4 do j = 1 , 6 rdat % r02 ( j , i ) = rdat % r02 ( j , i ) + fwk ( j , 1 ) * work ( i + 9 ) enddo enddo do i = 5 , 8 do j = 1 , 6 rdat % r02 ( j , i ) = rdat % r02 ( j , i ) + fwk ( j , 2 ) * work ( i + 5 ) enddo enddo do i = 9 , 12 do j = 1 , 6 rdat % r02 ( j , i ) = rdat % r02 ( j , i ) + fwk ( j , 3 ) * work ( i + 1 ) enddo enddo do i = 13 , 16 do j = 1 , 6 rdat % r02 ( j , i ) = rdat % r02 ( j , i ) + fwk ( j , 4 ) * work ( i - 3 ) enddo enddo do i = 17 , 20 do j = 1 , 6 rdat % r02 ( j , i ) = rdat % r02 ( j , i ) + fwk ( j , 5 ) * work ( i - 7 ) enddo enddo do i = 21 , 24 do j = 1 , 6 rdat % r02 ( j , i ) = rdat % r02 ( j , i ) + fwk ( j , 6 ) * work ( i - 15 ) enddo enddo do i = 25 , 28 do j = 1 , 6 rdat % r02 ( j , i ) = rdat % r02 ( j , i ) + fwk ( j , 7 ) * work ( i - 19 ) enddo enddo do i = 29 , 32 do j = 1 , 6 rdat % r02 ( j , i ) = rdat % r02 ( j , i ) + fwk ( j , 8 ) * work ( i - 23 ) enddo enddo do i = 33 , 36 do j = 1 , 6 rdat % r02 ( j , i ) = rdat % r02 ( j , i ) + fwk ( j , 13 ) * work ( i - 27 ) enddo enddo do i = 37 , 41 do j = 1 , 6 rdat % r02 ( j , i ) = rdat % r02 ( j , i ) + fwk ( j , 9 ) * work ( i - 36 ) enddo enddo do i = 42 , 46 do j = 1 , 6 rdat % r02 ( j , i ) = rdat % r02 ( j , i ) + fwk ( j , 10 ) * work ( i - 41 ) enddo enddo do i = 47 , 51 do j = 1 , 6 rdat % r02 ( j , i ) = rdat % r02 ( j , i ) + fwk ( j , 12 ) * work ( i - 46 ) enddo enddo do j = 1 , 4 rdat % fq3 ( j , 12 ) = rdat % fq3 ( j , 8 ) * rdat % rab + rdat % fq3 ( j , 10 ) rdat % fq3 ( j , 13 ) = rdat % fq3 ( j , 5 ) * rdat % rab + rdat % fq3 ( j , 7 ) enddo do i = 1 , 13 fwk ( 1 , i ) =- ( rdat % fq3 ( 1 , i ) * rdat % aqx2 - rdat % fq2 ( 1 , i ) * 3 ) * rdat % aqx fwk ( 2 , i ) =- ( rdat % fq3 ( 1 , i ) * rdat % aqx2 - rdat % fq2 ( 1 , i ) ) * rdat % acy fwk ( 3 , i ) = rdat % fq3 ( 2 , i ) * rdat % aqx2 - rdat % fq2 ( 2 , i ) fwk ( 4 , i ) =- ( rdat % fq3 ( 1 , i ) * rdat % acy2 - rdat % fq2 ( 1 , i ) ) * rdat % aqx fwk ( 5 , i ) = rdat % fq3 ( 2 , i ) * rdat % aqxy fwk ( 6 , i ) =- ( rdat % fq3 ( 3 , i ) - rdat % fq2 ( 1 , i ) ) * rdat % aqx fwk ( 7 , i ) =- ( rdat % fq3 ( 1 , i ) * rdat % acy2 - rdat % fq2 ( 1 , i ) * 3 ) * rdat % acy fwk ( 8 , i ) = rdat % fq3 ( 2 , i ) * rdat % acy2 - rdat % fq2 ( 2 , i ) fwk ( 9 , i ) =- ( rdat % fq3 ( 3 , i ) - rdat % fq2 ( 1 , i ) ) * rdat % acy fwk ( 10 , i ) = rdat % fq3 ( 4 , i ) - rdat % fq2 ( 2 , i ) * 3 enddo do i = 1 , 2 do j = 1 , 10 rdat % r03 ( j , i ) = rdat % r03 ( j , i ) + fwk ( j , 1 ) * work ( i + 13 ) enddo enddo do i = 3 , 4 do j = 1 , 10 rdat % r03 ( j , i ) = rdat % r03 ( j , i ) + fwk ( j , 2 ) * work ( i + 11 ) enddo enddo do i = 5 , 6 do j = 1 , 10 rdat % r03 ( j , i ) = rdat % r03 ( j , i ) + fwk ( j , 3 ) * work ( i + 9 ) enddo enddo do i = 7 , 8 do j = 1 , 10 rdat % r03 ( j , i ) = rdat % r03 ( j , i ) + fwk ( j , 4 ) * work ( i + 7 ) enddo enddo do i = 9 , 10 do j = 1 , 10 rdat % r03 ( j , i ) = rdat % r03 ( j , i ) + fwk ( j , 5 ) * work ( i + 5 ) enddo enddo do i = 11 , 14 do j = 1 , 10 rdat % r03 ( j , i ) = rdat % r03 ( j , i ) + fwk ( j , 6 ) * work ( i - 1 ) enddo enddo do i = 15 , 18 do j = 1 , 10 rdat % r03 ( j , i ) = rdat % r03 ( j , i ) + fwk ( j , 7 ) * work ( i - 5 ) enddo enddo do i = 19 , 22 do j = 1 , 10 rdat % r03 ( j , i ) = rdat % r03 ( j , i ) + fwk ( j , 8 ) * work ( i - 9 ) enddo enddo do i = 23 , 26 do j = 1 , 10 rdat % r03 ( j , i ) = rdat % r03 ( j , i ) + fwk ( j , 13 ) * work ( i - 13 ) enddo enddo do i = 27 , 30 do j = 1 , 10 rdat % r03 ( j , i ) = rdat % r03 ( j , i ) + fwk ( j , 9 ) * work ( i - 21 ) enddo enddo do i = 31 , 34 do j = 1 , 10 rdat % r03 ( j , i ) = rdat % r03 ( j , i ) + fwk ( j , 10 ) * work ( i - 25 ) enddo enddo do i = 35 , 38 do j = 1 , 10 rdat % r03 ( j , i ) = rdat % r03 ( j , i ) + fwk ( j , 12 ) * work ( i - 29 ) enddo enddo do i = 39 , 43 do j = 1 , 10 rdat % r03 ( j , i ) = rdat % r03 ( j , i ) + fwk ( j , 11 ) * work ( i - 38 ) enddo enddo aqx4 = rdat % aqx2 * rdat % aqx2 acy4 = rdat % acy2 * rdat % acy2 x2y2 = rdat % aqx2 * rdat % acy2 q2c2 = rdat % aqx2 + rdat % acy2 do i = 1 , 5 rdat % r04 ( 1 , i ) = rdat % r04 ( 1 , i ) + ( rdat % fq4 ( 1 , i ) * aqx4 - rdat % fq3 ( 1 , i ) * 6 * rdat % aqx2 & & + rdat % fq2 ( 1 , i ) * 3 ) * xmdt rdat % r04 ( 2 , i ) = rdat % r04 ( 2 , i ) + ( rdat % fq4 ( 1 , i ) * rdat % aqx2 - rdat % fq3 ( 1 , i ) * 3 ) * xmdtxy rdat % r04 ( 3 , i ) = rdat % r04 ( 3 , i ) + ( rdat % fq4 ( 2 , i ) * rdat % aqx2 - rdat % fq3 ( 2 , i ) * 3 ) * xmdtx rdat % r04 ( 4 , i ) = rdat % r04 ( 4 , i ) + ( rdat % fq4 ( 1 , i ) * x2y2 - rdat % fq3 ( 1 , i ) * q2c2 & & + rdat % fq2 ( 1 , i ) ) * xmdt rdat % r04 ( 5 , i ) = rdat % r04 ( 5 , i ) + ( rdat % fq4 ( 2 , i ) * rdat % aqx2 - rdat % fq3 ( 2 , i ) ) * xmdty rdat % r04 ( 6 , i ) = rdat % r04 ( 6 , i ) + ( rdat % fq4 ( 3 , i ) * rdat % aqx2 - rdat % fq3 ( 1 , i ) * rdat % aqx2 & & - rdat % fq3 ( 3 , i ) + rdat % fq2 ( 1 , i )) * xmdt rdat % r04 ( 7 , i ) = rdat % r04 ( 7 , i ) + ( rdat % fq4 ( 1 , i ) * rdat % acy2 - rdat % fq3 ( 1 , i ) * 3 ) * xmdtxy rdat % r04 ( 8 , i ) = rdat % r04 ( 8 , i ) + ( rdat % fq4 ( 2 , i ) * rdat % acy2 - rdat % fq3 ( 2 , i ) ) * xmdtx rdat % r04 ( 9 , i ) = rdat % r04 ( 9 , i ) + ( rdat % fq4 ( 3 , i ) - rdat % fq3 ( 1 , i ) ) * xmdtxy rdat % r04 ( 10 , i ) = rdat % r04 ( 10 , i ) + ( rdat % fq4 ( 4 , i ) - rdat % fq3 ( 2 , i ) * 3 ) * xmdtx rdat % r04 ( 11 , i ) = rdat % r04 ( 11 , i ) + ( rdat % fq4 ( 1 , i ) * acy4 - rdat % fq3 ( 1 , i ) * 6 * rdat % acy2 & & + rdat % fq2 ( 1 , i ) * 3 ) * xmdt rdat % r04 ( 12 , i ) = rdat % r04 ( 12 , i ) + ( rdat % fq4 ( 2 , i ) * rdat % acy2 - rdat % fq3 ( 2 , i ) * 3 ) * xmdty rdat % r04 ( 13 , i ) = rdat % r04 ( 13 , i ) + ( rdat % fq4 ( 3 , i ) * rdat % acy2 - rdat % fq3 ( 1 , i ) * rdat % acy2 & & - rdat % fq3 ( 3 , i ) + rdat % fq2 ( 1 , i )) * xmdt rdat % r04 ( 14 , i ) = rdat % r04 ( 14 , i ) + ( rdat % fq4 ( 4 , i ) - rdat % fq3 ( 2 , i ) * 3 ) * xmdty rdat % r04 ( 15 , i ) = rdat % r04 ( 15 , i ) + ( rdat % fq4 ( 5 , i ) - rdat % fq3 ( 3 , i ) * 6 & & + rdat % fq2 ( 1 , i ) * 3 ) * xmdt enddo rdat % fq2 ( 1 , 5 ) = rdat % fq2 ( 1 , 13 ) rdat % fq3 ( 1 , 5 ) = rdat % fq3 ( 1 , 13 ) rdat % fq3 ( 2 , 5 ) = rdat % fq3 ( 2 , 13 ) rdat % fq3 ( 3 , 5 ) = rdat % fq3 ( 3 , 13 ) do j = 1 , 5 rdat % fq4 ( j , 5 ) = rdat % fq4 ( j , 5 ) * rdat % rab + rdat % fq4 ( j , 7 ) rdat % fq4 ( j , 12 ) = rdat % fq4 ( j , 8 ) * rdat % rab + rdat % fq4 ( j , 10 ) enddo do i = 5 , 12 fwk ( 1 , i ) = rdat % fq4 ( 1 , i ) * aqx4 - rdat % fq3 ( 1 , i ) * 6 * rdat % aqx2 + rdat % fq2 ( 1 , i ) * 3 fwk ( 2 , i ) = ( rdat % fq4 ( 1 , i ) * rdat % aqx2 - rdat % fq3 ( 1 , i ) * 3 ) * rdat % aqxy fwk ( 3 , i ) =- ( rdat % fq4 ( 2 , i ) * rdat % aqx2 - rdat % fq3 ( 2 , i ) * 3 ) * rdat % aqx fwk ( 4 , i ) = rdat % fq4 ( 1 , i ) * x2y2 - rdat % fq3 ( 1 , i ) * q2c2 + rdat % fq2 ( 1 , i ) fwk ( 5 , i ) =- ( rdat % fq4 ( 2 , i ) * rdat % aqx2 - rdat % fq3 ( 2 , i ) ) * rdat % acy fwk ( 6 , i ) = rdat % fq4 ( 3 , i ) * rdat % aqx2 - rdat % fq3 ( 1 , i ) * rdat % aqx2 - rdat % fq3 ( 3 , i ) + rdat % fq2 ( 1 , i ) fwk ( 7 , i ) = ( rdat % fq4 ( 1 , i ) * rdat % acy2 - rdat % fq3 ( 1 , i ) * 3 ) * rdat % aqxy fwk ( 8 , i ) =- ( rdat % fq4 ( 2 , i ) * rdat % acy2 - rdat % fq3 ( 2 , i ) ) * rdat % aqx fwk ( 9 , i ) = ( rdat % fq4 ( 3 , i ) - rdat % fq3 ( 1 , i ) ) * rdat % aqxy fwk ( 10 , i ) =- ( rdat % fq4 ( 4 , i ) - rdat % fq3 ( 2 , i ) * 3 ) * rdat % aqx fwk ( 11 , i ) = rdat % fq4 ( 1 , i ) * acy4 - rdat % fq3 ( 1 , i ) * 6 * rdat % acy2 + rdat % fq2 ( 1 , i ) * 3 fwk ( 12 , i ) =- ( rdat % fq4 ( 2 , i ) * rdat % acy2 - rdat % fq3 ( 2 , i ) * 3 ) * rdat % acy fwk ( 13 , i ) = rdat % fq4 ( 3 , i ) * rdat % acy2 - rdat % fq3 ( 1 , i ) * rdat % acy2 - rdat % fq3 ( 3 , i ) + rdat % fq2 ( 1 , i ) fwk ( 14 , i ) =- ( rdat % fq4 ( 4 , i ) - rdat % fq3 ( 2 , i ) * 3 ) * rdat % acy fwk ( 15 , i ) = rdat % fq4 ( 5 , i ) - rdat % fq3 ( 3 , i ) * 6 + rdat % fq2 ( 1 , i ) * 3 enddo do i = 6 , 7 do j = 1 , 15 rdat % r04 ( j , i ) = rdat % r04 ( j , i ) + fwk ( j , 5 ) * work ( i + 8 ) enddo enddo do i = 8 , 9 do j = 1 , 15 rdat % r04 ( j , i ) = rdat % r04 ( j , i ) + fwk ( j , 6 ) * work ( i + 6 ) enddo enddo do i = 10 , 11 do j = 1 , 15 rdat % r04 ( j , i ) = rdat % r04 ( j , i ) + fwk ( j , 7 ) * work ( i + 4 ) enddo enddo do i = 12 , 13 do j = 1 , 15 rdat % r04 ( j , i ) = rdat % r04 ( j , i ) + fwk ( j , 8 ) * work ( i + 2 ) enddo enddo do i = 14 , 17 do j = 1 , 15 rdat % r04 ( j , i ) = rdat % r04 ( j , i ) + fwk ( j , 9 ) * work ( i - 4 ) enddo enddo do i = 18 , 21 do j = 1 , 15 rdat % r04 ( j , i ) = rdat % r04 ( j , i ) + fwk ( j , 10 ) * work ( i - 8 ) enddo enddo do i = 22 , 25 do j = 1 , 15 rdat % r04 ( j , i ) = rdat % r04 ( j , i ) + fwk ( j , 12 ) * work ( i - 12 ) enddo enddo do i = 26 , 29 do j = 1 , 15 rdat % r04 ( j , i ) = rdat % r04 ( j , i ) + fwk ( j , 11 ) * work ( i - 20 ) enddo enddo do j = 1 , 6 rdat % fq5 ( j , 1 ) = rdat % fq5 ( j , 1 ) * rdat % rab + rdat % fq5 ( j , 3 ) enddo do i = 1 , 4 rdat % r05 ( 1 , i ) = rdat % r05 ( 1 , i ) + ( rdat % fq5 ( 1 , i ) * aqx4 - rdat % fq4 ( 1 , i + 4 ) * 10 * rdat % aqx2 & & + rdat % fq3 ( 1 , i + 4 ) * 15 ) * xmdtx rdat % r05 ( 2 , i ) = rdat % r05 ( 2 , i ) + ( rdat % fq5 ( 1 , i ) * aqx4 - rdat % fq4 ( 1 , i + 4 ) * 6 * rdat % aqx2 & & + rdat % fq3 ( 1 , i + 4 ) * 3 ) * xmdty rdat % r05 ( 3 , i ) = rdat % r05 ( 3 , i ) + ( rdat % fq5 ( 2 , i ) * aqx4 - rdat % fq4 ( 2 , i + 4 ) * 6 * rdat % aqx2 & & + rdat % fq3 ( 2 , i + 4 ) * 3 ) * xmdt rdat % r05 ( 4 , i ) = rdat % r05 ( 4 , i ) + ( rdat % fq5 ( 1 , i ) * x2y2 - rdat % fq4 ( 1 , i + 4 ) * 3 * rdat % acy2 & & - rdat % fq4 ( 1 , i + 4 ) * rdat % aqx2 + rdat % fq3 ( 1 , i + 4 ) * 3 ) * xmdtx rdat % r05 ( 5 , i ) = rdat % r05 ( 5 , i ) + ( rdat % fq5 ( 2 , i ) * rdat % aqx2 - rdat % fq4 ( 2 , i + 4 ) * 3 ) * xmdtxy rdat % r05 ( 6 , i ) = rdat % r05 ( 6 , i ) + ( rdat % fq5 ( 3 , i ) * rdat % aqx2 - rdat % fq4 ( 1 , i + 4 ) * rdat % aqx2 & & - rdat % fq4 ( 3 , i + 4 ) * 3 + rdat % fq3 ( 1 , i + 4 ) * 3 ) * xmdtx rdat % r05 ( 7 , i ) = rdat % r05 ( 7 , i ) + ( rdat % fq5 ( 1 , i ) * x2y2 - rdat % fq4 ( 1 , i + 4 ) * 3 * rdat % aqx2 & & - rdat % fq4 ( 1 , i + 4 ) * rdat % acy2 + rdat % fq3 ( 1 , i + 4 ) * 3 ) * xmdty rdat % r05 ( 8 , i ) = rdat % r05 ( 8 , i ) + ( rdat % fq5 ( 2 , i ) * x2y2 - rdat % fq4 ( 2 , i + 4 ) * q2c2 & & + rdat % fq3 ( 2 , i + 4 ) ) * xmdt rdat % r05 ( 9 , i ) = rdat % r05 ( 9 , i ) + ( rdat % fq5 ( 3 , i ) * rdat % aqx2 - rdat % fq4 ( 1 , i + 4 ) * rdat % aqx2 & & - rdat % fq4 ( 3 , i + 4 ) + rdat % fq3 ( 1 , i + 4 ) ) * xmdty rdat % r05 ( 10 , i ) = rdat % r05 ( 10 , i ) + ( rdat % fq5 ( 4 , i ) * rdat % aqx2 - rdat % fq4 ( 2 , i + 4 ) * 3 * rdat % aqx2 & & - rdat % fq4 ( 4 , i + 4 ) + rdat % fq3 ( 2 , i + 4 ) * 3 ) * xmdt rdat % r05 ( 11 , i ) = rdat % r05 ( 11 , i ) + ( rdat % fq5 ( 1 , i ) * acy4 - rdat % fq4 ( 1 , i + 4 ) * 6 * rdat % acy2 & & + rdat % fq3 ( 1 , i + 4 ) * 3 ) * xmdtx rdat % r05 ( 12 , i ) = rdat % r05 ( 12 , i ) + ( rdat % fq5 ( 2 , i ) * rdat % acy2 - rdat % fq4 ( 2 , i + 4 ) * 3 ) * xmdtxy rdat % r05 ( 13 , i ) = rdat % r05 ( 13 , i ) + ( rdat % fq5 ( 3 , i ) * rdat % acy2 - rdat % fq4 ( 1 , i + 4 ) * rdat % acy2 & & - rdat % fq4 ( 3 , i + 4 ) + rdat % fq3 ( 1 , i + 4 ) ) * xmdtx rdat % r05 ( 14 , i ) = rdat % r05 ( 14 , i ) + ( rdat % fq5 ( 4 , i ) - rdat % fq4 ( 2 , i + 4 ) * 3 ) * xmdtxy rdat % r05 ( 15 , i ) = rdat % r05 ( 15 , i ) + ( rdat % fq5 ( 5 , i ) - rdat % fq4 ( 3 , i + 4 ) * 6 & & + rdat % fq3 ( 1 , i + 4 ) * 3 ) * xmdtx rdat % r05 ( 16 , i ) = rdat % r05 ( 16 , i ) + ( rdat % fq5 ( 1 , i ) * acy4 - rdat % fq4 ( 1 , i + 4 ) * 10 * rdat % acy2 & & + rdat % fq3 ( 1 , i + 4 ) * 15 ) * xmdty rdat % r05 ( 17 , i ) = rdat % r05 ( 17 , i ) + ( rdat % fq5 ( 2 , i ) * acy4 - rdat % fq4 ( 2 , i + 4 ) * 6 * rdat % acy2 & & + rdat % fq3 ( 2 , i + 4 ) * 3 ) * xmdt rdat % r05 ( 18 , i ) = rdat % r05 ( 18 , i ) + ( rdat % fq5 ( 3 , i ) * rdat % acy2 - rdat % fq4 ( 1 , i + 4 ) * rdat % acy2 & & - rdat % fq4 ( 3 , i + 4 ) * 3 + rdat % fq3 ( 1 , i + 4 ) * 3 ) * xmdty rdat % r05 ( 19 , i ) = rdat % r05 ( 19 , i ) + ( rdat % fq5 ( 4 , i ) * rdat % acy2 - rdat % fq4 ( 2 , i + 4 ) * 3 * rdat % acy2 & & - rdat % fq4 ( 4 , i + 4 ) + rdat % fq3 ( 2 , i + 4 ) * 3 ) * xmdt rdat % r05 ( 20 , i ) = rdat % r05 ( 20 , i ) + ( rdat % fq5 ( 5 , i ) - rdat % fq4 ( 3 , i + 4 ) * 6 & & + rdat % fq3 ( 1 , i + 4 ) * 3 ) * xmdty rdat % r05 ( 21 , i ) = rdat % r05 ( 21 , i ) + ( rdat % fq5 ( 6 , i ) - rdat % fq4 ( 4 , i + 4 ) * 10 & & + rdat % fq3 ( 2 , i + 4 ) * 15 ) * xmdt enddo rdat % fq3 ( 1 , 8 ) = rdat % fq3 ( 1 , 12 ) rdat % fq3 ( 2 , 8 ) = rdat % fq3 ( 2 , 12 ) rdat % fq4 ( 1 , 8 ) = rdat % fq4 ( 1 , 12 ) rdat % fq4 ( 2 , 8 ) = rdat % fq4 ( 2 , 12 ) rdat % fq4 ( 3 , 8 ) = rdat % fq4 ( 3 , 12 ) rdat % fq4 ( 4 , 8 ) = rdat % fq4 ( 4 , 12 ) do j = 1 , 6 rdat % fq5 ( j , 4 ) = rdat % fq5 ( j , 4 ) * rdat % rab + rdat % fq5 ( j , 6 ) enddo do i = 4 , 7 fwk ( 1 , i ) =- ( rdat % fq5 ( 1 , i ) * aqx4 - rdat % fq4 ( 1 , i + 4 ) * 10 * rdat % aqx2 & & + rdat % fq3 ( 1 , i + 4 ) * 15 ) * rdat % aqx fwk ( 2 , i ) =- ( rdat % fq5 ( 1 , i ) * aqx4 - rdat % fq4 ( 1 , i + 4 ) * 6 * rdat % aqx2 & & + rdat % fq3 ( 1 , i + 4 ) * 3 ) * rdat % acy fwk ( 3 , i ) = rdat % fq5 ( 2 , i ) * aqx4 - rdat % fq4 ( 2 , i + 4 ) * 6 * rdat % aqx2 & & + rdat % fq3 ( 2 , i + 4 ) * 3 fwk ( 4 , i ) =- ( rdat % fq5 ( 1 , i ) * x2y2 - rdat % fq4 ( 1 , i + 4 ) * rdat % aqx2 & & - rdat % fq4 ( 1 , i + 4 ) * 3 * rdat % acy2 + rdat % fq3 ( 1 , i + 4 ) * 3 ) * rdat % aqx fwk ( 5 , i ) = ( rdat % fq5 ( 2 , i ) * rdat % aqx2 - rdat % fq4 ( 2 , i + 4 ) * 3 ) * rdat % aqxy fwk ( 6 , i ) =- ( rdat % fq5 ( 3 , i ) * rdat % aqx2 - rdat % fq4 ( 1 , i + 4 ) * rdat % aqx2 - rdat % fq4 ( 3 , i + 4 ) * 3 & & + rdat % fq3 ( 1 , i + 4 ) * 3 ) * rdat % aqx fwk ( 7 , i ) =- ( rdat % fq5 ( 1 , i ) * x2y2 - rdat % fq4 ( 1 , i + 4 ) * 3 * rdat % aqx2 & & - rdat % fq4 ( 1 , i + 4 ) * rdat % acy2 + rdat % fq3 ( 1 , i + 4 ) * 3 ) * rdat % acy fwk ( 8 , i ) = rdat % fq5 ( 2 , i ) * x2y2 - rdat % fq4 ( 2 , i + 4 ) * q2c2 + rdat % fq3 ( 2 , i + 4 ) fwk ( 9 , i ) =- ( rdat % fq5 ( 3 , i ) * rdat % aqx2 - rdat % fq4 ( 1 , i + 4 ) * rdat % aqx2 - rdat % fq4 ( 3 , i + 4 ) & & + rdat % fq3 ( 1 , i + 4 ) ) * rdat % acy fwk ( 10 , i ) = rdat % fq5 ( 4 , i ) * rdat % aqx2 - rdat % fq4 ( 2 , i + 4 ) * 3 * rdat % aqx2 - rdat % fq4 ( 4 , i + 4 ) & & + rdat % fq3 ( 2 , i + 4 ) * 3 fwk ( 11 , i ) =- ( rdat % fq5 ( 1 , i ) * acy4 - rdat % fq4 ( 1 , i + 4 ) * 6 * rdat % acy2 & & + rdat % fq3 ( 1 , i + 4 ) * 3 ) * rdat % aqx fwk ( 12 , i ) = ( rdat % fq5 ( 2 , i ) * rdat % acy2 - rdat % fq4 ( 2 , i + 4 ) * 3 ) * rdat % aqxy fwk ( 13 , i ) =- ( rdat % fq5 ( 3 , i ) * rdat % acy2 - rdat % fq4 ( 1 , i + 4 ) * rdat % acy2 - rdat % fq4 ( 3 , i + 4 ) & & + rdat % fq3 ( 1 , i + 4 ) ) * rdat % aqx fwk ( 14 , i ) = ( rdat % fq5 ( 4 , i ) - rdat % fq4 ( 2 , i + 4 ) * 3 ) * rdat % aqxy fwk ( 15 , i ) =- ( rdat % fq5 ( 5 , i ) - rdat % fq4 ( 3 , i + 4 ) * 6 & & + rdat % fq3 ( 1 , i + 4 ) * 3 ) * rdat % aqx fwk ( 16 , i ) =- ( rdat % fq5 ( 1 , i ) * acy4 - rdat % fq4 ( 1 , i + 4 ) * 10 * rdat % acy2 & & + rdat % fq3 ( 1 , i + 4 ) * 15 ) * rdat % acy fwk ( 17 , i ) = rdat % fq5 ( 2 , i ) * acy4 - rdat % fq4 ( 2 , i + 4 ) * 6 * rdat % acy2 & & + rdat % fq3 ( 2 , i + 4 ) * 3 fwk ( 18 , i ) =- ( rdat % fq5 ( 3 , i ) * rdat % acy2 - rdat % fq4 ( 1 , i + 4 ) * rdat % acy2 - rdat % fq4 ( 3 , i + 4 ) * 3 & & + rdat % fq3 ( 1 , i + 4 ) * 3 ) * rdat % acy fwk ( 19 , i ) = rdat % fq5 ( 4 , i ) * rdat % acy2 - rdat % fq4 ( 2 , i + 4 ) * 3 * rdat % acy2 - rdat % fq4 ( 4 , i + 4 ) & & + rdat % fq3 ( 2 , i + 4 ) * 3 fwk ( 20 , i ) =- ( rdat % fq5 ( 5 , i ) - rdat % fq4 ( 3 , i + 4 ) * 6 + rdat % fq3 ( 1 , i + 4 ) * 3 ) * rdat % acy fwk ( 21 , i ) = rdat % fq5 ( 6 , i ) - rdat % fq4 ( 4 , i + 4 ) * 10 + rdat % fq3 ( 2 , i + 4 ) * 15 enddo do i = 5 , 6 do j = 1 , 21 rdat % r05 ( j , i ) = rdat % r05 ( j , i ) + fwk ( j , 5 ) * work ( i + 9 ) enddo enddo do i = 7 , 8 do j = 1 , 21 rdat % r05 ( j , i ) = rdat % r05 ( j , i ) + fwk ( j , 6 ) * work ( i + 7 ) enddo enddo do i = 9 , 10 do j = 1 , 21 rdat % r05 ( j , i ) = rdat % r05 ( j , i ) + fwk ( j , 4 ) * work ( i + 5 ) enddo enddo do i = 11 , 14 do j = 1 , 21 rdat % r05 ( j , i ) = rdat % r05 ( j , i ) + fwk ( j , 7 ) * work ( i - 1 ) enddo enddo do j = 1 , 7 rdat % fq6 ( j , 1 ) = rdat % fq6 ( j , 1 ) * rdat % rab + rdat % fq6 ( j , 3 ) enddo call frikr6 ( rdat , 1 , 4 , fw6 , rdat % fq6 , 3 , rdat % fq5 , 7 , rdat % fq4 , 7 , rdat % fq3 ) do i = 1 , 3 do j = 1 , 28 rdat % r06 ( j , i ) = rdat % r06 ( j , i ) + fw6 ( j , i ) * fcc ( j , 6 ) end do end do i = 4 ! Fw6( 1,i)= fw6( 1,i)*fcu( 1,6) fw6 ( 2 , i ) = fw6 ( 2 , i ) * fcu ( 2 , 6 ) fw6 ( 3 , i ) = fw6 ( 3 , i ) * fcu ( 3 , 6 ) ! Fw6( 4,i)= fw6( 4,i)*fcu( 4,6) fw6 ( 5 , i ) = fw6 ( 5 , i ) * fcu ( 5 , 6 ) ! Fw6( 6,i)= fw6( 6,i)*fcu( 6,6) fw6 ( 7 , i ) = fw6 ( 7 , i ) * fcu ( 7 , 6 ) fw6 ( 8 , i ) = fw6 ( 8 , i ) * fcu ( 8 , 6 ) fw6 ( 9 , i ) = fw6 ( 9 , i ) * fcu ( 9 , 6 ) fw6 ( 10 , i ) = fw6 ( 10 , i ) * fcu ( 10 , 6 ) ! Fw6(11,i)= fw6(11,i)*fcu(11,6) fw6 ( 12 , i ) = fw6 ( 12 , i ) * fcu ( 12 , 6 ) ! Fw6(13,i)= fw6(13,i)*fcu(13,6) fw6 ( 14 , i ) = fw6 ( 14 , i ) * fcu ( 14 , 6 ) ! Fw6(15,i)= fw6(15,i)*fcu(15,6) fw6 ( 16 , i ) = fw6 ( 16 , i ) * fcu ( 16 , 6 ) fw6 ( 17 , i ) = fw6 ( 17 , i ) * fcu ( 17 , 6 ) fw6 ( 18 , i ) = fw6 ( 18 , i ) * fcu ( 18 , 6 ) fw6 ( 19 , i ) = fw6 ( 19 , i ) * fcu ( 19 , 6 ) fw6 ( 20 , i ) = fw6 ( 20 , i ) * fcu ( 20 , 6 ) fw6 ( 21 , i ) = fw6 ( 21 , i ) * fcu ( 21 , 6 ) ! Fw6(22,i)= fw6(22,i)*fcu(22,6) fw6 ( 23 , i ) = fw6 ( 23 , i ) * fcu ( 23 , 6 ) ! Fw6(24,i)= fw6(24,i)*fcu(24,6) fw6 ( 25 , i ) = fw6 ( 25 , i ) * fcu ( 25 , 6 ) ! Fw6(26,i)= fw6(26,i)*fcu(26,6) fw6 ( 27 , i ) = fw6 ( 27 , i ) * fcu ( 27 , 6 ) ! Fw6(28,i)= fw6(28,i)*fcu(28,6) do i = 4 , 5 do j = 1 , 28 rdat % r06 ( j , i ) = rdat % r06 ( j , i ) + fw6 ( j , 4 ) * work ( i + 10 ) end do end do call frikr7 ( rdat , 1 , 1 , fw7 , rdat % fq7 , 3 , rdat % fq6 , 6 , rdat % fq5 , 10 , rdat % fq4 ) rdat % r07 (:, 1 ) = rdat % r07 (:, 1 ) + fw7 (:) * fcc ( 1 : 36 , 7 ) end subroutine intk_20 ! > ! >    @brief   dddd case ! > ! >    @details integration of the dddd case ! > subroutine intk_21 ( rdat , ikl ) implicit none type ( rotaxis_data_t ) :: rdat integer :: ikl real ( kind = dp ) :: xmd2 , xmd3 , xmd4 , xmd6 real ( kind = dp ) :: xmdt , xmdtx , xmdtxy , xmdty real ( kind = dp ) :: aqx4 , acy4 , q2c2 , x2y2 real ( kind = dp ) :: y33 , y34 , y44 real ( kind = dp ) :: work , fwk , fw6 , fw7 , fw8 , fcu , fcc integer :: i , j ! Generate jtype=21 integrals dimension work ( 15 ), fwk ( 36 , 16 ), fw6 ( 28 , 7 ), fw7 ( 36 , 3 ), fw8 ( 45 ) dimension fcu ( 45 , 8 ), fcc ( 45 , 8 ) if ( ikl == 0 ) then rdat % r00 = 0.0_dp rdat % r01 = 0.0_dp rdat % r02 = 0.0_dp rdat % r03 = 0.0_dp rdat % r04 = 0.0_dp rdat % r05 = 0.0_dp rdat % r06 = 0.0_dp rdat % r07 = 0.0_dp rdat % r08 = 0.0_dp return endif xmd2 = rdat % x43 * 0.5d+00 xmd3 = xmd2 xmd4 = xmd3 * xmd2 xmd6 = xmd4 * xmd2 xmdt = xmd6 * xmd2 xmd2 = xmd3 xmdty =- xmdt * rdat % acy xmdtx =- xmdt * rdat % aqx xmdtxy = xmdt * rdat % aqxy y33 = rdat % y03 * rdat % y03 y34 =- rdat % y03 * rdat % y04 y44 = rdat % y04 * rdat % y04 work ( 1 ) = xmd4 work ( 2 ) = xmd2 * y33 work ( 3 ) = xmd2 * y34 work ( 4 ) = xmd2 * y44 work ( 5 ) = y33 * y44 work ( 6 ) =- xmd4 * rdat % y03 work ( 7 ) = xmd4 * rdat % y04 work ( 8 ) = xmd2 * y33 * rdat % y04 work ( 9 ) = xmd2 * y34 * rdat % y04 work ( 10 ) = xmd6 work ( 11 ) = xmd4 * y33 work ( 12 ) = xmd4 * y34 work ( 13 ) = xmd4 * y44 work ( 14 ) =- xmd6 * rdat % y03 work ( 15 ) = xmd6 * rdat % y04 call fcufcc ( rdat , 8 , xmdt , fcu , fcc ) do i = 1 , 5 do j = 1 , 5 rdat % r00 ( j , i ) = rdat % r00 ( j , i ) + rdat % fq0 ( i ) * work ( j ) end do end do do i = 1 , 9 fwk ( 1 , i ) =- rdat % fq1 ( 1 , i ) * rdat % aqx fwk ( 2 , i ) =- rdat % fq1 ( 1 , i ) * rdat % acy fwk ( 3 , i ) = rdat % fq1 ( 2 , i ) enddo do i = 1 , 4 rdat % r01 ( 1 , i ) = rdat % r01 ( 1 , i ) + fwk ( 1 , 1 ) * work ( i + 5 ) rdat % r01 ( 2 , i ) = rdat % r01 ( 2 , i ) + fwk ( 2 , 1 ) * work ( i + 5 ) rdat % r01 ( 3 , i ) = rdat % r01 ( 3 , i ) + fwk ( 3 , 1 ) * work ( i + 5 ) enddo do i = 5 , 8 rdat % r01 ( 1 , i ) = rdat % r01 ( 1 , i ) + fwk ( 1 , 2 ) * work ( i + 1 ) rdat % r01 ( 2 , i ) = rdat % r01 ( 2 , i ) + fwk ( 2 , 2 ) * work ( i + 1 ) rdat % r01 ( 3 , i ) = rdat % r01 ( 3 , i ) + fwk ( 3 , 2 ) * work ( i + 1 ) enddo do i = 9 , 12 rdat % r01 ( 1 , i ) = rdat % r01 ( 1 , i ) + fwk ( 1 , 3 ) * work ( i - 3 ) rdat % r01 ( 2 , i ) = rdat % r01 ( 2 , i ) + fwk ( 2 , 3 ) * work ( i - 3 ) rdat % r01 ( 3 , i ) = rdat % r01 ( 3 , i ) + fwk ( 3 , 3 ) * work ( i - 3 ) enddo do i = 13 , 16 rdat % r01 ( 1 , i ) = rdat % r01 ( 1 , i ) + fwk ( 1 , 4 ) * work ( i - 7 ) rdat % r01 ( 2 , i ) = rdat % r01 ( 2 , i ) + fwk ( 2 , 4 ) * work ( i - 7 ) rdat % r01 ( 3 , i ) = rdat % r01 ( 3 , i ) + fwk ( 3 , 4 ) * work ( i - 7 ) enddo do i = 17 , 20 rdat % r01 ( 1 , i ) = rdat % r01 ( 1 , i ) + fwk ( 1 , 5 ) * work ( i - 11 ) rdat % r01 ( 2 , i ) = rdat % r01 ( 2 , i ) + fwk ( 2 , 5 ) * work ( i - 11 ) rdat % r01 ( 3 , i ) = rdat % r01 ( 3 , i ) + fwk ( 3 , 5 ) * work ( i - 11 ) enddo do i = 21 , 25 rdat % r01 ( 1 , i ) = rdat % r01 ( 1 , i ) + fwk ( 1 , 6 ) * work ( i - 20 ) rdat % r01 ( 2 , i ) = rdat % r01 ( 2 , i ) + fwk ( 2 , 6 ) * work ( i - 20 ) rdat % r01 ( 3 , i ) = rdat % r01 ( 3 , i ) + fwk ( 3 , 6 ) * work ( i - 20 ) enddo do i = 26 , 30 rdat % r01 ( 1 , i ) = rdat % r01 ( 1 , i ) + fwk ( 1 , 7 ) * work ( i - 25 ) rdat % r01 ( 2 , i ) = rdat % r01 ( 2 , i ) + fwk ( 2 , 7 ) * work ( i - 25 ) rdat % r01 ( 3 , i ) = rdat % r01 ( 3 , i ) + fwk ( 3 , 7 ) * work ( i - 25 ) enddo do i = 31 , 35 rdat % r01 ( 1 , i ) = rdat % r01 ( 1 , i ) + fwk ( 1 , 8 ) * work ( i - 30 ) rdat % r01 ( 2 , i ) = rdat % r01 ( 2 , i ) + fwk ( 2 , 8 ) * work ( i - 30 ) rdat % r01 ( 3 , i ) = rdat % r01 ( 3 , i ) + fwk ( 3 , 8 ) * work ( i - 30 ) enddo do i = 36 , 40 rdat % r01 ( 1 , i ) = rdat % r01 ( 1 , i ) + fwk ( 1 , 9 ) * work ( i - 35 ) rdat % r01 ( 2 , i ) = rdat % r01 ( 2 , i ) + fwk ( 2 , 9 ) * work ( i - 35 ) rdat % r01 ( 3 , i ) = rdat % r01 ( 3 , i ) + fwk ( 3 , 9 ) * work ( i - 35 ) enddo do i = 1 , 13 fwk ( 1 , i ) = rdat % fq2 ( 1 , i ) * rdat % aqx2 - rdat % fq1 ( 1 , i ) fwk ( 2 , i ) = rdat % fq2 ( 1 , i ) * rdat % acy2 - rdat % fq1 ( 1 , i ) fwk ( 3 , i ) = rdat % fq2 ( 3 , i ) - rdat % fq1 ( 1 , i ) fwk ( 4 , i ) = rdat % fq2 ( 1 , i ) * rdat % aqxy fwk ( 5 , i ) =- rdat % fq2 ( 2 , i ) * rdat % aqx fwk ( 6 , i ) =- rdat % fq2 ( 2 , i ) * rdat % acy enddo do i = 1 , 4 do j = 1 , 6 rdat % r02 ( j , i ) = rdat % r02 ( j , i ) + fwk ( j , 1 ) * work ( i + 9 ) enddo enddo do i = 5 , 8 do j = 1 , 6 rdat % r02 ( j , i ) = rdat % r02 ( j , i ) + fwk ( j , 2 ) * work ( i + 5 ) enddo enddo do i = 9 , 12 do j = 1 , 6 rdat % r02 ( j , i ) = rdat % r02 ( j , i ) + fwk ( j , 3 ) * work ( i + 1 ) enddo enddo do i = 13 , 16 do j = 1 , 6 rdat % r02 ( j , i ) = rdat % r02 ( j , i ) + fwk ( j , 4 ) * work ( i - 3 ) enddo enddo do i = 17 , 20 do j = 1 , 6 rdat % r02 ( j , i ) = rdat % r02 ( j , i ) + fwk ( j , 5 ) * work ( i - 7 ) enddo enddo do i = 21 , 24 do j = 1 , 6 rdat % r02 ( j , i ) = rdat % r02 ( j , i ) + fwk ( j , 6 ) * work ( i - 15 ) enddo enddo do i = 25 , 28 do j = 1 , 6 rdat % r02 ( j , i ) = rdat % r02 ( j , i ) + fwk ( j , 7 ) * work ( i - 19 ) enddo enddo do i = 29 , 32 do j = 1 , 6 rdat % r02 ( j , i ) = rdat % r02 ( j , i ) + fwk ( j , 8 ) * work ( i - 23 ) enddo enddo do i = 33 , 36 do j = 1 , 6 rdat % r02 ( j , i ) = rdat % r02 ( j , i ) + fwk ( j , 9 ) * work ( i - 27 ) enddo enddo do i = 37 , 41 do j = 1 , 6 rdat % r02 ( j , i ) = rdat % r02 ( j , i ) + fwk ( j , 10 ) * work ( i - 36 ) enddo enddo do i = 42 , 46 do j = 1 , 6 rdat % r02 ( j , i ) = rdat % r02 ( j , i ) + fwk ( j , 11 ) * work ( i - 41 ) enddo enddo do i = 47 , 51 do j = 1 , 6 rdat % r02 ( j , i ) = rdat % r02 ( j , i ) + fwk ( j , 12 ) * work ( i - 46 ) enddo enddo do i = 52 , 56 do j = 1 , 6 rdat % r02 ( j , i ) = rdat % r02 ( j , i ) + fwk ( j , 13 ) * work ( i - 51 ) enddo enddo do i = 1 , 15 fwk ( 1 , i ) =- ( rdat % fq3 ( 1 , i ) * rdat % aqx2 - rdat % fq2 ( 1 , i ) * 3 ) * rdat % aqx fwk ( 2 , i ) =- ( rdat % fq3 ( 1 , i ) * rdat % aqx2 - rdat % fq2 ( 1 , i ) ) * rdat % acy fwk ( 3 , i ) = rdat % fq3 ( 2 , i ) * rdat % aqx2 - rdat % fq2 ( 2 , i ) fwk ( 4 , i ) =- ( rdat % fq3 ( 1 , i ) * rdat % acy2 - rdat % fq2 ( 1 , i ) ) * rdat % aqx fwk ( 5 , i ) = rdat % fq3 ( 2 , i ) * rdat % aqxy fwk ( 6 , i ) =- ( rdat % fq3 ( 3 , i ) - rdat % fq2 ( 1 , i ) ) * rdat % aqx fwk ( 7 , i ) =- ( rdat % fq3 ( 1 , i ) * rdat % acy2 - rdat % fq2 ( 1 , i ) * 3 ) * rdat % acy fwk ( 8 , i ) = rdat % fq3 ( 2 , i ) * rdat % acy2 - rdat % fq2 ( 2 , i ) fwk ( 9 , i ) =- ( rdat % fq3 ( 3 , i ) - rdat % fq2 ( 1 , i ) ) * rdat % acy fwk ( 10 , i ) = rdat % fq3 ( 4 , i ) - rdat % fq2 ( 2 , i ) * 3 enddo do i = 1 , 2 do j = 1 , 10 rdat % r03 ( j , i ) = rdat % r03 ( j , i ) + fwk ( j , 1 ) * work ( i + 13 ) enddo enddo do i = 3 , 4 do j = 1 , 10 rdat % r03 ( j , i ) = rdat % r03 ( j , i ) + fwk ( j , 2 ) * work ( i + 11 ) enddo enddo do i = 5 , 6 do j = 1 , 10 rdat % r03 ( j , i ) = rdat % r03 ( j , i ) + fwk ( j , 3 ) * work ( i + 9 ) enddo enddo do i = 7 , 8 do j = 1 , 10 rdat % r03 ( j , i ) = rdat % r03 ( j , i ) + fwk ( j , 4 ) * work ( i + 7 ) enddo enddo do i = 9 , 10 do j = 1 , 10 rdat % r03 ( j , i ) = rdat % r03 ( j , i ) + fwk ( j , 5 ) * work ( i + 5 ) enddo enddo do i = 11 , 14 do j = 1 , 10 rdat % r03 ( j , i ) = rdat % r03 ( j , i ) + fwk ( j , 6 ) * work ( i - 1 ) enddo enddo do i = 15 , 18 do j = 1 , 10 rdat % r03 ( j , i ) = rdat % r03 ( j , i ) + fwk ( j , 7 ) * work ( i - 5 ) enddo enddo do i = 19 , 22 do j = 1 , 10 rdat % r03 ( j , i ) = rdat % r03 ( j , i ) + fwk ( j , 8 ) * work ( i - 9 ) enddo enddo do i = 23 , 26 do j = 1 , 10 rdat % r03 ( j , i ) = rdat % r03 ( j , i ) + fwk ( j , 9 ) * work ( i - 13 ) enddo enddo do i = 27 , 30 do j = 1 , 10 rdat % r03 ( j , i ) = rdat % r03 ( j , i ) + fwk ( j , 10 ) * work ( i - 21 ) enddo enddo do i = 31 , 34 do j = 1 , 10 rdat % r03 ( j , i ) = rdat % r03 ( j , i ) + fwk ( j , 11 ) * work ( i - 25 ) enddo enddo do i = 35 , 38 do j = 1 , 10 rdat % r03 ( j , i ) = rdat % r03 ( j , i ) + fwk ( j , 12 ) * work ( i - 29 ) enddo enddo do i = 39 , 42 do j = 1 , 10 rdat % r03 ( j , i ) = rdat % r03 ( j , i ) + fwk ( j , 13 ) * work ( i - 33 ) enddo enddo do i = 43 , 47 do j = 1 , 10 rdat % r03 ( j , i ) = rdat % r03 ( j , i ) + fwk ( j , 14 ) * work ( i - 42 ) enddo enddo do i = 48 , 52 do j = 1 , 10 rdat % r03 ( j , i ) = rdat % r03 ( j , i ) + fwk ( j , 15 ) * work ( i - 47 ) enddo enddo aqx4 = rdat % aqx2 * rdat % aqx2 acy4 = rdat % acy2 * rdat % acy2 x2y2 = rdat % aqx2 * rdat % acy2 q2c2 = rdat % aqx2 + rdat % acy2 do i = 1 , 5 rdat % r04 ( 1 , i ) = rdat % r04 ( 1 , i ) + ( rdat % fq4 ( 1 , i ) * aqx4 - rdat % fq3 ( 1 , i ) * 6 * rdat % aqx2 & & + rdat % fq2 ( 1 , i ) * 3 ) * xmdt rdat % r04 ( 2 , i ) = rdat % r04 ( 2 , i ) + ( rdat % fq4 ( 1 , i ) * rdat % aqx2 - rdat % fq3 ( 1 , i ) * 3 ) * xmdtxy rdat % r04 ( 3 , i ) = rdat % r04 ( 3 , i ) + ( rdat % fq4 ( 2 , i ) * rdat % aqx2 - rdat % fq3 ( 2 , i ) * 3 ) * xmdtx rdat % r04 ( 4 , i ) = rdat % r04 ( 4 , i ) + ( rdat % fq4 ( 1 , i ) * x2y2 - rdat % fq3 ( 1 , i ) * q2c2 & & + rdat % fq2 ( 1 , i ) ) * xmdt rdat % r04 ( 5 , i ) = rdat % r04 ( 5 , i ) + ( rdat % fq4 ( 2 , i ) * rdat % aqx2 - rdat % fq3 ( 2 , i ) ) * xmdty rdat % r04 ( 6 , i ) = rdat % r04 ( 6 , i ) + ( rdat % fq4 ( 3 , i ) * rdat % aqx2 - rdat % fq3 ( 1 , i ) * rdat % aqx2 & & - rdat % fq3 ( 3 , i ) + rdat % fq2 ( 1 , i ) ) * xmdt rdat % r04 ( 7 , i ) = rdat % r04 ( 7 , i ) + ( rdat % fq4 ( 1 , i ) * rdat % acy2 - rdat % fq3 ( 1 , i ) * 3 ) * xmdtxy rdat % r04 ( 8 , i ) = rdat % r04 ( 8 , i ) + ( rdat % fq4 ( 2 , i ) * rdat % acy2 - rdat % fq3 ( 2 , i ) ) * xmdtx rdat % r04 ( 9 , i ) = rdat % r04 ( 9 , i ) + ( rdat % fq4 ( 3 , i ) - rdat % fq3 ( 1 , i ) ) * xmdtxy rdat % r04 ( 10 , i ) = rdat % r04 ( 10 , i ) + ( rdat % fq4 ( 4 , i ) - rdat % fq3 ( 2 , i ) * 3 ) * xmdtx rdat % r04 ( 11 , i ) = rdat % r04 ( 11 , i ) + ( rdat % fq4 ( 1 , i ) * acy4 - rdat % fq3 ( 1 , i ) * 6 * rdat % acy2 & & + rdat % fq2 ( 1 , i ) * 3 ) * xmdt rdat % r04 ( 12 , i ) = rdat % r04 ( 12 , i ) + ( rdat % fq4 ( 2 , i ) * rdat % acy2 - rdat % fq3 ( 2 , i ) * 3 ) * xmdty rdat % r04 ( 13 , i ) = rdat % r04 ( 13 , i ) + ( rdat % fq4 ( 3 , i ) * rdat % acy2 - rdat % fq3 ( 1 , i ) * rdat % acy2 & & - rdat % fq3 ( 3 , i ) + rdat % fq2 ( 1 , i ) ) * xmdt rdat % r04 ( 14 , i ) = rdat % r04 ( 14 , i ) + ( rdat % fq4 ( 4 , i ) - rdat % fq3 ( 2 , i ) * 3 ) * xmdty rdat % r04 ( 15 , i ) = rdat % r04 ( 15 , i ) + ( rdat % fq4 ( 5 , i ) - rdat % fq3 ( 3 , i ) * 6 & & + rdat % fq2 ( 1 , i ) * 3 ) * xmdt enddo do i = 6 , 16 fwk ( 1 , i ) = rdat % fq4 ( 1 , i ) * aqx4 - rdat % fq3 ( 1 , i ) * 6 * rdat % aqx2 + rdat % fq2 ( 1 , i ) * 3 fwk ( 2 , i ) = ( rdat % fq4 ( 1 , i ) * rdat % aqx2 - rdat % fq3 ( 1 , i ) * 3 ) * rdat % aqxy fwk ( 3 , i ) =- ( rdat % fq4 ( 2 , i ) * rdat % aqx2 - rdat % fq3 ( 2 , i ) * 3 ) * rdat % aqx fwk ( 4 , i ) = rdat % fq4 ( 1 , i ) * x2y2 - rdat % fq3 ( 1 , i ) * q2c2 + rdat % fq2 ( 1 , i ) fwk ( 5 , i ) =- ( rdat % fq4 ( 2 , i ) * rdat % aqx2 - rdat % fq3 ( 2 , i ) ) * rdat % acy fwk ( 6 , i ) = rdat % fq4 ( 3 , i ) * rdat % aqx2 - rdat % fq3 ( 1 , i ) * rdat % aqx2 - rdat % fq3 ( 3 , i ) + rdat % fq2 ( 1 , i ) fwk ( 7 , i ) = ( rdat % fq4 ( 1 , i ) * rdat % acy2 - rdat % fq3 ( 1 , i ) * 3 ) * rdat % aqxy fwk ( 8 , i ) =- ( rdat % fq4 ( 2 , i ) * rdat % acy2 - rdat % fq3 ( 2 , i ) ) * rdat % aqx fwk ( 9 , i ) = ( rdat % fq4 ( 3 , i ) - rdat % fq3 ( 1 , i ) ) * rdat % aqxy fwk ( 10 , i ) =- ( rdat % fq4 ( 4 , i ) - rdat % fq3 ( 2 , i ) * 3 ) * rdat % aqx fwk ( 11 , i ) = rdat % fq4 ( 1 , i ) * acy4 - rdat % fq3 ( 1 , i ) * 6 * rdat % acy2 + rdat % fq2 ( 1 , i ) * 3 fwk ( 12 , i ) =- ( rdat % fq4 ( 2 , i ) * rdat % acy2 - rdat % fq3 ( 2 , i ) * 3 ) * rdat % acy fwk ( 13 , i ) = rdat % fq4 ( 3 , i ) * rdat % acy2 - rdat % fq3 ( 1 , i ) * rdat % acy2 - rdat % fq3 ( 3 , i ) + rdat % fq2 ( 1 , i ) fwk ( 14 , i ) =- ( rdat % fq4 ( 4 , i ) - rdat % fq3 ( 2 , i ) * 3 ) * rdat % acy fwk ( 15 , i ) = rdat % fq4 ( 5 , i ) - rdat % fq3 ( 3 , i ) * 6 + rdat % fq2 ( 1 , i ) * 3 enddo do i = 6 , 7 do j = 1 , 15 rdat % r04 ( j , i ) = rdat % r04 ( j , i ) + fwk ( j , 6 ) * work ( i + 8 ) enddo enddo do i = 8 , 9 do j = 1 , 15 rdat % r04 ( j , i ) = rdat % r04 ( j , i ) + fwk ( j , 7 ) * work ( i + 6 ) enddo enddo do i = 10 , 11 do j = 1 , 15 rdat % r04 ( j , i ) = rdat % r04 ( j , i ) + fwk ( j , 8 ) * work ( i + 4 ) enddo enddo do i = 12 , 13 do j = 1 , 15 rdat % r04 ( j , i ) = rdat % r04 ( j , i ) + fwk ( j , 9 ) * work ( i + 2 ) enddo enddo do i = 14 , 17 do j = 1 , 15 rdat % r04 ( j , i ) = rdat % r04 ( j , i ) + fwk ( j , 10 ) * work ( i - 4 ) enddo enddo do i = 18 , 21 do j = 1 , 15 rdat % r04 ( j , i ) = rdat % r04 ( j , i ) + fwk ( j , 11 ) * work ( i - 8 ) enddo enddo do i = 22 , 25 do j = 1 , 15 rdat % r04 ( j , i ) = rdat % r04 ( j , i ) + fwk ( j , 12 ) * work ( i - 12 ) enddo enddo do i = 26 , 29 do j = 1 , 15 rdat % r04 ( j , i ) = rdat % r04 ( j , i ) + fwk ( j , 13 ) * work ( i - 16 ) enddo enddo do i = 30 , 33 do j = 1 , 15 rdat % r04 ( j , i ) = rdat % r04 ( j , i ) + fwk ( j , 14 ) * work ( i - 24 ) enddo enddo do i = 34 , 37 do j = 1 , 15 rdat % r04 ( j , i ) = rdat % r04 ( j , i ) + fwk ( j , 15 ) * work ( i - 28 ) enddo enddo do i = 38 , 42 do j = 1 , 15 rdat % r04 ( j , i ) = rdat % r04 ( j , i ) + fwk ( j , 16 ) * work ( i - 37 ) enddo enddo do i = 1 , 4 rdat % r05 ( 1 , i ) = rdat % r05 ( 1 , i ) + ( rdat % fq5 ( 1 , i ) * aqx4 - rdat % fq4 ( 1 , i + 5 ) * 10 * rdat % aqx2 & & + rdat % fq3 ( 1 , i + 5 ) * 15 ) * xmdtx rdat % r05 ( 2 , i ) = rdat % r05 ( 2 , i ) + ( rdat % fq5 ( 1 , i ) * aqx4 - rdat % fq4 ( 1 , i + 5 ) * 6 * rdat % aqx2 & & + rdat % fq3 ( 1 , i + 5 ) * 3 ) * xmdty rdat % r05 ( 3 , i ) = rdat % r05 ( 3 , i ) + ( rdat % fq5 ( 2 , i ) * aqx4 - rdat % fq4 ( 2 , i + 5 ) * 6 * rdat % aqx2 & & + rdat % fq3 ( 2 , i + 5 ) * 3 ) * xmdt rdat % r05 ( 4 , i ) = rdat % r05 ( 4 , i ) + ( rdat % fq5 ( 1 , i ) * x2y2 - rdat % fq4 ( 1 , i + 5 ) * 3 * rdat % acy2 & & - rdat % fq4 ( 1 , i + 5 ) * rdat % aqx2 + rdat % fq3 ( 1 , i + 5 ) * 3 ) * xmdtx rdat % r05 ( 5 , i ) = rdat % r05 ( 5 , i ) + ( rdat % fq5 ( 2 , i ) * rdat % aqx2 - rdat % fq4 ( 2 , i + 5 ) * 3 ) * xmdtxy rdat % r05 ( 6 , i ) = rdat % r05 ( 6 , i ) + ( rdat % fq5 ( 3 , i ) * rdat % aqx2 - rdat % fq4 ( 1 , i + 5 ) * rdat % aqx2 & & - rdat % fq4 ( 3 , i + 5 ) * 3 + rdat % fq3 ( 1 , i + 5 ) * 3 ) * xmdtx rdat % r05 ( 7 , i ) = rdat % r05 ( 7 , i ) + ( rdat % fq5 ( 1 , i ) * x2y2 - rdat % fq4 ( 1 , i + 5 ) * 3 * rdat % aqx2 & & - rdat % fq4 ( 1 , i + 5 ) * rdat % acy2 + rdat % fq3 ( 1 , i + 5 ) * 3 ) * xmdty rdat % r05 ( 8 , i ) = rdat % r05 ( 8 , i ) + ( rdat % fq5 ( 2 , i ) * x2y2 - rdat % fq4 ( 2 , i + 5 ) * q2c2 & & + rdat % fq3 ( 2 , i + 5 ) ) * xmdt rdat % r05 ( 9 , i ) = rdat % r05 ( 9 , i ) + ( rdat % fq5 ( 3 , i ) * rdat % aqx2 - rdat % fq4 ( 1 , i + 5 ) * rdat % aqx2 & & - rdat % fq4 ( 3 , i + 5 ) + rdat % fq3 ( 1 , i + 5 ) ) * xmdty rdat % r05 ( 10 , i ) = rdat % r05 ( 10 , i ) + ( rdat % fq5 ( 4 , i ) * rdat % aqx2 - rdat % fq4 ( 2 , i + 5 ) * 3 * rdat % aqx2 & & - rdat % fq4 ( 4 , i + 5 ) + rdat % fq3 ( 2 , i + 5 ) * 3 ) * xmdt rdat % r05 ( 11 , i ) = rdat % r05 ( 11 , i ) + ( rdat % fq5 ( 1 , i ) * acy4 - rdat % fq4 ( 1 , i + 5 ) * 6 * rdat % acy2 & & + rdat % fq3 ( 1 , i + 5 ) * 3 ) * xmdtx rdat % r05 ( 12 , i ) = rdat % r05 ( 12 , i ) + ( rdat % fq5 ( 2 , i ) * rdat % acy2 - rdat % fq4 ( 2 , i + 5 ) * 3 ) * xmdtxy rdat % r05 ( 13 , i ) = rdat % r05 ( 13 , i ) + ( rdat % fq5 ( 3 , i ) * rdat % acy2 - rdat % fq4 ( 1 , i + 5 ) * rdat % acy2 & & - rdat % fq4 ( 3 , i + 5 ) + rdat % fq3 ( 1 , i + 5 ) ) * xmdtx rdat % r05 ( 14 , i ) = rdat % r05 ( 14 , i ) + ( rdat % fq5 ( 4 , i ) - rdat % fq4 ( 2 , i + 5 ) * 3 ) * xmdtxy rdat % r05 ( 15 , i ) = rdat % r05 ( 15 , i ) + ( rdat % fq5 ( 5 , i ) - rdat % fq4 ( 3 , i + 5 ) * 6 & & + rdat % fq3 ( 1 , i + 5 ) * 3 ) * xmdtx rdat % r05 ( 16 , i ) = rdat % r05 ( 16 , i ) + ( rdat % fq5 ( 1 , i ) * acy4 - rdat % fq4 ( 1 , i + 5 ) * 10 * rdat % acy2 & & + rdat % fq3 ( 1 , i + 5 ) * 15 ) * xmdty rdat % r05 ( 17 , i ) = rdat % r05 ( 17 , i ) + ( rdat % fq5 ( 2 , i ) * acy4 - rdat % fq4 ( 2 , i + 5 ) * 6 * rdat % acy2 & & + rdat % fq3 ( 2 , i + 5 ) * 3 ) * xmdt rdat % r05 ( 18 , i ) = rdat % r05 ( 18 , i ) + ( rdat % fq5 ( 3 , i ) * rdat % acy2 - rdat % fq4 ( 1 , i + 5 ) * rdat % acy2 & & - rdat % fq4 ( 3 , i + 5 ) * 3 + rdat % fq3 ( 1 , i + 5 ) * 3 ) * xmdty rdat % r05 ( 19 , i ) = rdat % r05 ( 19 , i ) + ( rdat % fq5 ( 4 , i ) * rdat % acy2 - rdat % fq4 ( 2 , i + 5 ) * 3 * rdat % acy2 & & - rdat % fq4 ( 4 , i + 5 ) + rdat % fq3 ( 2 , i + 5 ) * 3 ) * xmdt rdat % r05 ( 20 , i ) = rdat % r05 ( 20 , i ) + ( rdat % fq5 ( 5 , i ) - rdat % fq4 ( 3 , i + 5 ) * 6 & & + rdat % fq3 ( 1 , i + 5 ) * 3 ) * xmdty rdat % r05 ( 21 , i ) = rdat % r05 ( 21 , i ) + ( rdat % fq5 ( 6 , i ) - rdat % fq4 ( 4 , i + 5 ) * 10 & & + rdat % fq3 ( 2 , i + 5 ) * 15 ) * xmdt enddo do i = 5 , 11 fwk ( 1 , i ) =- ( rdat % fq5 ( 1 , i ) * aqx4 - rdat % fq4 ( 1 , i + 5 ) * 10 * rdat % aqx2 & & + rdat % fq3 ( 1 , i + 5 ) * 15 ) * rdat % aqx fwk ( 2 , i ) =- ( rdat % fq5 ( 1 , i ) * aqx4 - rdat % fq4 ( 1 , i + 5 ) * 6 * rdat % aqx2 & & + rdat % fq3 ( 1 , i + 5 ) * 3 ) * rdat % acy fwk ( 3 , i ) = rdat % fq5 ( 2 , i ) * aqx4 - rdat % fq4 ( 2 , i + 5 ) * 6 * rdat % aqx2 & & + rdat % fq3 ( 2 , i + 5 ) * 3 fwk ( 4 , i ) =- ( rdat % fq5 ( 1 , i ) * x2y2 - rdat % fq4 ( 1 , i + 5 ) * rdat % aqx2 & & - rdat % fq4 ( 1 , i + 5 ) * 3 * rdat % acy2 + rdat % fq3 ( 1 , i + 5 ) * 3 ) * rdat % aqx fwk ( 5 , i ) = ( rdat % fq5 ( 2 , i ) * rdat % aqx2 - rdat % fq4 ( 2 , i + 5 ) * 3 ) * rdat % aqxy fwk ( 6 , i ) =- ( rdat % fq5 ( 3 , i ) * rdat % aqx2 - rdat % fq4 ( 1 , i + 5 ) * rdat % aqx2 - rdat % fq4 ( 3 , i + 5 ) * 3 & & + rdat % fq3 ( 1 , i + 5 ) * 3 ) * rdat % aqx fwk ( 7 , i ) =- ( rdat % fq5 ( 1 , i ) * x2y2 - rdat % fq4 ( 1 , i + 5 ) * 3 * rdat % aqx2 & & - rdat % fq4 ( 1 , i + 5 ) * rdat % acy2 + rdat % fq3 ( 1 , i + 5 ) * 3 ) * rdat % acy fwk ( 8 , i ) = rdat % fq5 ( 2 , i ) * x2y2 - rdat % fq4 ( 2 , i + 5 ) * q2c2 + rdat % fq3 ( 2 , i + 5 ) fwk ( 9 , i ) =- ( rdat % fq5 ( 3 , i ) * rdat % aqx2 - rdat % fq4 ( 1 , i + 5 ) * rdat % aqx2 - rdat % fq4 ( 3 , i + 5 ) & & + rdat % fq3 ( 1 , i + 5 ) ) * rdat % acy fwk ( 10 , i ) = rdat % fq5 ( 4 , i ) * rdat % aqx2 - rdat % fq4 ( 2 , i + 5 ) * 3 * rdat % aqx2 - rdat % fq4 ( 4 , i + 5 ) & & + rdat % fq3 ( 2 , i + 5 ) * 3 fwk ( 11 , i ) =- ( rdat % fq5 ( 1 , i ) * acy4 - rdat % fq4 ( 1 , i + 5 ) * 6 * rdat % acy2 & & + rdat % fq3 ( 1 , i + 5 ) * 3 ) * rdat % aqx fwk ( 12 , i ) = ( rdat % fq5 ( 2 , i ) * rdat % acy2 - rdat % fq4 ( 2 , i + 5 ) * 3 ) * rdat % aqxy fwk ( 13 , i ) =- ( rdat % fq5 ( 3 , i ) * rdat % acy2 - rdat % fq4 ( 1 , i + 5 ) * rdat % acy2 - rdat % fq4 ( 3 , i + 5 ) & & + rdat % fq3 ( 1 , i + 5 ) ) * rdat % aqx fwk ( 14 , i ) = ( rdat % fq5 ( 4 , i ) - rdat % fq4 ( 2 , i + 5 ) * 3 ) * rdat % aqxy fwk ( 15 , i ) =- ( rdat % fq5 ( 5 , i ) - rdat % fq4 ( 3 , i + 5 ) * 6 & & + rdat % fq3 ( 1 , i + 5 ) * 3 ) * rdat % aqx fwk ( 16 , i ) =- ( rdat % fq5 ( 1 , i ) * acy4 - rdat % fq4 ( 1 , i + 5 ) * 10 * rdat % acy2 & & + rdat % fq3 ( 1 , i + 5 ) * 15 ) * rdat % acy fwk ( 17 , i ) = rdat % fq5 ( 2 , i ) * acy4 - rdat % fq4 ( 2 , i + 5 ) * 6 * rdat % acy2 & & + rdat % fq3 ( 2 , i + 5 ) * 3 fwk ( 18 , i ) =- ( rdat % fq5 ( 3 , i ) * rdat % acy2 - rdat % fq4 ( 1 , i + 5 ) * rdat % acy2 - rdat % fq4 ( 3 , i + 5 ) * 3 & & + rdat % fq3 ( 1 , i + 5 ) * 3 ) * rdat % acy fwk ( 19 , i ) = rdat % fq5 ( 4 , i ) * rdat % acy2 - rdat % fq4 ( 2 , i + 5 ) * 3 * rdat % acy2 - rdat % fq4 ( 4 , i + 5 ) & & + rdat % fq3 ( 2 , i + 5 ) * 3 fwk ( 20 , i ) =- ( rdat % fq5 ( 5 , i ) - rdat % fq4 ( 3 , i + 5 ) * 6 + rdat % fq3 ( 1 , i + 5 ) * 3 ) * rdat % acy fwk ( 21 , i ) = rdat % fq5 ( 6 , i ) - rdat % fq4 ( 4 , i + 5 ) * 10 + rdat % fq3 ( 2 , i + 5 ) * 15 enddo do i = 5 , 6 do j = 1 , 21 rdat % r05 ( j , i ) = rdat % r05 ( j , i ) + fwk ( j , 5 ) * work ( i + 9 ) enddo enddo do i = 7 , 8 do j = 1 , 21 rdat % r05 ( j , i ) = rdat % r05 ( j , i ) + fwk ( j , 6 ) * work ( i + 7 ) enddo enddo do i = 9 , 10 do j = 1 , 21 rdat % r05 ( j , i ) = rdat % r05 ( j , i ) + fwk ( j , 7 ) * work ( i + 5 ) enddo enddo do i = 11 , 12 do j = 1 , 21 rdat % r05 ( j , i ) = rdat % r05 ( j , i ) + fwk ( j , 8 ) * work ( i + 3 ) enddo enddo do i = 13 , 16 do j = 1 , 21 rdat % r05 ( j , i ) = rdat % r05 ( j , i ) + fwk ( j , 9 ) * work ( i - 3 ) enddo enddo do i = 17 , 20 do j = 1 , 21 rdat % r05 ( j , i ) = rdat % r05 ( j , i ) + fwk ( j , 10 ) * work ( i - 7 ) enddo enddo do i = 21 , 24 do j = 1 , 21 rdat % r05 ( j , i ) = rdat % r05 ( j , i ) + fwk ( j , 11 ) * work ( i - 15 ) enddo enddo call frikr6 ( rdat , 1 , 7 , fw6 , rdat % fq6 , 4 , rdat % fq5 , 9 , rdat % fq4 , 9 , rdat % fq3 ) do i = 1 , 4 do j = 1 , 28 rdat % r06 ( j , i ) = rdat % r06 ( j , i ) + fw6 ( j , i ) * fcc ( j , 6 ) end do end do do i = 5 , 7 ! Fw6( 1,i)= fw6( 1,i)*fcu( 1,6) fw6 ( 2 , i ) = fw6 ( 2 , i ) * fcu ( 2 , 6 ) fw6 ( 3 , i ) = fw6 ( 3 , i ) * fcu ( 3 , 6 ) ! Fw6( 4,i)= fw6( 4,i)*fcu( 4,6) fw6 ( 5 , i ) = fw6 ( 5 , i ) * fcu ( 5 , 6 ) ! Fw6( 6,i)= fw6( 6,i)*fcu( 6,6) fw6 ( 7 , i ) = fw6 ( 7 , i ) * fcu ( 7 , 6 ) fw6 ( 8 , i ) = fw6 ( 8 , i ) * fcu ( 8 , 6 ) fw6 ( 9 , i ) = fw6 ( 9 , i ) * fcu ( 9 , 6 ) fw6 ( 10 , i ) = fw6 ( 10 , i ) * fcu ( 10 , 6 ) ! Fw6(11,i)= fw6(11,i)*fcu(11,6) fw6 ( 12 , i ) = fw6 ( 12 , i ) * fcu ( 12 , 6 ) ! Fw6(13,i)= fw6(13,i)*fcu(13,6) fw6 ( 14 , i ) = fw6 ( 14 , i ) * fcu ( 14 , 6 ) ! Fw6(15,i)= fw6(15,i)*fcu(15,6) fw6 ( 16 , i ) = fw6 ( 16 , i ) * fcu ( 16 , 6 ) fw6 ( 17 , i ) = fw6 ( 17 , i ) * fcu ( 17 , 6 ) fw6 ( 18 , i ) = fw6 ( 18 , i ) * fcu ( 18 , 6 ) fw6 ( 19 , i ) = fw6 ( 19 , i ) * fcu ( 19 , 6 ) fw6 ( 20 , i ) = fw6 ( 20 , i ) * fcu ( 20 , 6 ) fw6 ( 21 , i ) = fw6 ( 21 , i ) * fcu ( 21 , 6 ) ! Fw6(22,i)= fw6(22,i)*fcu(22,6) fw6 ( 23 , i ) = fw6 ( 23 , i ) * fcu ( 23 , 6 ) ! Fw6(24,i)= fw6(24,i)*fcu(24,6) fw6 ( 25 , i ) = fw6 ( 25 , i ) * fcu ( 25 , 6 ) ! Fw6(26,i)= fw6(26,i)*fcu(26,6) fw6 ( 27 , i ) = fw6 ( 27 , i ) * fcu ( 27 , 6 ) ! Fw6(28,i)= fw6(28,i)*fcu(28,6) enddo do i = 5 , 6 do j = 1 , 28 rdat % r06 ( j , i ) = rdat % r06 ( j , i ) + fw6 ( j , 5 ) * work ( i + 9 ) enddo enddo do i = 7 , 8 do j = 1 , 28 rdat % r06 ( j , i ) = rdat % r06 ( j , i ) + fw6 ( j , 6 ) * work ( i + 7 ) enddo enddo do i = 9 , 12 do j = 1 , 28 rdat % r06 ( j , i ) = rdat % r06 ( j , i ) + fw6 ( j , 7 ) * work ( i + 1 ) enddo enddo call frikr7 ( rdat , 1 , 3 , fw7 , rdat % fq7 , 4 , rdat % fq6 , 8 , rdat % fq5 , 13 , rdat % fq4 ) do i = 1 , 2 do j = 1 , 36 rdat % r07 ( j , i ) = rdat % r07 ( j , i ) + fw7 ( j , i ) * fcc ( j , 7 ) end do end do i = 3 fw7 ( 1 , i ) = fw7 ( 1 , i ) * fcu ( 1 , 7 ) fw7 ( 2 , i ) = fw7 ( 2 , i ) * fcu ( 2 , 7 ) ! Fw7( 3,i)= fw7( 3,i)*fcu( 3,7) fw7 ( 4 , i ) = fw7 ( 4 , i ) * fcu ( 4 , 7 ) fw7 ( 5 , i ) = fw7 ( 5 , i ) * fcu ( 5 , 7 ) fw7 ( 6 , i ) = fw7 ( 6 , i ) * fcu ( 6 , 7 ) fw7 ( 7 , i ) = fw7 ( 7 , i ) * fcu ( 7 , 7 ) ! Fw7( 8,i)= fw7( 8,i)*fcu( 8,7) fw7 ( 9 , i ) = fw7 ( 9 , i ) * fcu ( 9 , 7 ) ! Fw7(10,i)= fw7(10,i)*fcu(10,7) fw7 ( 11 , i ) = fw7 ( 11 , i ) * fcu ( 11 , 7 ) fw7 ( 12 , i ) = fw7 ( 12 , i ) * fcu ( 12 , 7 ) fw7 ( 13 , i ) = fw7 ( 13 , i ) * fcu ( 13 , 7 ) fw7 ( 14 , i ) = fw7 ( 14 , i ) * fcu ( 14 , 7 ) fw7 ( 15 , i ) = fw7 ( 15 , i ) * fcu ( 15 , 7 ) fw7 ( 16 , i ) = fw7 ( 16 , i ) * fcu ( 16 , 7 ) ! Fw7(17,i)= fw7(17,i)*fcu(17,7) fw7 ( 18 , i ) = fw7 ( 18 , i ) * fcu ( 18 , 7 ) ! Fw7(19,i)= fw7(19,i)*fcu(19,7) fw7 ( 20 , i ) = fw7 ( 20 , i ) * fcu ( 20 , 7 ) ! Fw7(21,i)= fw7(21,i)*fcu(21,7) fw7 ( 22 , i ) = fw7 ( 22 , i ) * fcu ( 22 , 7 ) fw7 ( 23 , i ) = fw7 ( 23 , i ) * fcu ( 23 , 7 ) fw7 ( 24 , i ) = fw7 ( 24 , i ) * fcu ( 24 , 7 ) fw7 ( 25 , i ) = fw7 ( 25 , i ) * fcu ( 25 , 7 ) fw7 ( 26 , i ) = fw7 ( 26 , i ) * fcu ( 26 , 7 ) fw7 ( 27 , i ) = fw7 ( 27 , i ) * fcu ( 27 , 7 ) fw7 ( 28 , i ) = fw7 ( 28 , i ) * fcu ( 28 , 7 ) fw7 ( 29 , i ) = fw7 ( 29 , i ) * fcu ( 29 , 7 ) ! Fw7(30,i)= fw7(30,i)*fcu(30,7) fw7 ( 31 , i ) = fw7 ( 31 , i ) * fcu ( 31 , 7 ) ! Fw7(32,i)= fw7(32,i)*fcu(32,7) fw7 ( 33 , i ) = fw7 ( 33 , i ) * fcu ( 33 , 7 ) ! Fw7(34,i)= fw7(34,i)*fcu(34,7) fw7 ( 35 , i ) = fw7 ( 35 , i ) * fcu ( 35 , 7 ) ! Fw7(36,i)= fw7(36,i)*fcu(36,7) do i = 3 , 4 do j = 1 , 36 rdat % r07 ( j , i ) = rdat % r07 ( j , i ) + fw7 ( j , 3 ) * work ( i + 11 ) end do end do call frikr8 ( rdat , 1 , 1 , fw8 , rdat % fq8 , 2 , rdat % fq7 , 6 , rdat % fq6 , 10 , rdat % fq5 , 15 , rdat % fq4 ) do j = 1 , 45 rdat % r08 ( j ) = rdat % r08 ( j ) + fw8 ( j ) * fcc ( j , 8 ) enddo end subroutine intk_21 ! > ! >    @brief   psss case ! > ! >    @details integration of a psss case ! > subroutine mcdv_02 ( f , rdat , qx , qz ) implicit none type ( rotaxis_data_t ) :: rdat real ( kind = dp ) :: f ( 3 , 1 , 1 , * ) real ( kind = dp ) :: qx , qz f ( 1 , 1 , 1 , 1 ) = + rdat % r01 ( 1 , 1 ) + rdat % r00 ( 2 , 1 ) * qx f ( 2 , 1 , 1 , 1 ) = + rdat % r01 ( 2 , 1 ) f ( 3 , 1 , 1 , 1 ) = + rdat % r01 ( 3 , 1 ) + rdat % r00 ( 2 , 1 ) * qz end subroutine mcdv_02 ! > ! >    @brief   ppss case ! > ! >    @details integration of a ppss case ! > subroutine mcdv_03 ( f , rdat , qx , qz ) implicit none type ( rotaxis_data_t ) :: rdat real ( kind = dp ) :: f ( 3 , 3 , 1 , * ) real ( kind = dp ) :: qx , qz f ( 1 , 1 , 1 , 1 ) = rdat % r02 ( 1 , 1 ) + rdat % r00 ( 4 , 1 ) + ( rdat % r01 ( 1 , 3 ) + rdat % r01 ( 1 , 4 ) + rdat % r00 ( 5 , 1 ) * qx ) * qx f ( 2 , 1 , 1 , 1 ) = rdat % r02 ( 4 , 1 ) + rdat % r01 ( 2 , 4 ) * qx f ( 3 , 1 , 1 , 1 ) = rdat % r02 ( 5 , 1 ) + rdat % r01 ( 3 , 4 ) * qx + ( rdat % r01 ( 1 , 3 ) + rdat % r00 ( 5 , 1 ) * qx ) * qz f ( 1 , 2 , 1 , 1 ) = rdat % r02 ( 4 , 1 ) + rdat % r01 ( 2 , 3 ) * qx f ( 2 , 2 , 1 , 1 ) = rdat % r02 ( 2 , 1 ) + rdat % r00 ( 4 , 1 ) f ( 3 , 2 , 1 , 1 ) = rdat % r02 ( 6 , 1 ) + rdat % r01 ( 2 , 3 ) * qz f ( 1 , 3 , 1 , 1 ) = rdat % r02 ( 5 , 1 ) + rdat % r01 ( 1 , 4 ) * qz + ( rdat % r01 ( 3 , 3 ) + rdat % r00 ( 5 , 1 ) * qz ) * qx f ( 2 , 3 , 1 , 1 ) = rdat % r02 ( 6 , 1 ) + rdat % r01 ( 2 , 4 ) * qz f ( 3 , 3 , 1 , 1 ) = rdat % r02 ( 3 , 1 ) + rdat % r00 ( 4 , 1 ) + ( rdat % r01 ( 3 , 3 ) + rdat % r01 ( 3 , 4 ) + rdat % r00 ( 5 , 1 ) * qz ) * qz end subroutine mcdv_03 ! > ! >    @brief   psps case ! > ! >    @details integration of a psps case ! > subroutine mcdv_04 ( f , rdat , qx , qz ) implicit none type ( rotaxis_data_t ) :: rdat real ( kind = dp ) :: f ( 3 , 1 , 3 , * ) real ( kind = dp ) :: qx , qz f ( 1 , 1 , 1 , 1 ) = - rdat % r02 ( 1 , 1 ) - rdat % r01 ( 1 , 4 ) * qx f ( 2 , 1 , 1 , 1 ) = - rdat % r02 ( 4 , 1 ) f ( 3 , 1 , 1 , 1 ) = - rdat % r02 ( 5 , 1 ) - rdat % r01 ( 1 , 4 ) * qz f ( 1 , 1 , 2 , 1 ) = - rdat % r02 ( 4 , 1 ) - rdat % r01 ( 2 , 4 ) * qx f ( 2 , 1 , 2 , 1 ) = - rdat % r02 ( 2 , 1 ) f ( 3 , 1 , 2 , 1 ) = - rdat % r02 ( 6 , 1 ) - rdat % r01 ( 2 , 4 ) * qz f ( 1 , 1 , 3 , 1 ) = - rdat % r02 ( 5 , 1 ) - rdat % r01 ( 3 , 4 ) * qx + rdat % r01 ( 1 , 3 ) + rdat % r00 ( 4 , 1 ) * qx f ( 2 , 1 , 3 , 1 ) = - rdat % r02 ( 6 , 1 ) + rdat % r01 ( 2 , 3 ) f ( 3 , 1 , 3 , 1 ) = - rdat % r02 ( 3 , 1 ) - rdat % r01 ( 3 , 4 ) * qz + rdat % r01 ( 3 , 3 ) + rdat % r00 ( 4 , 1 ) * qz end subroutine mcdv_04 ! > ! >    @brief   ppps case ! > ! >    @details integration of a ppps case ! > subroutine mcdv_05 ( f , rdat , qx , qz ) implicit none type ( rotaxis_data_t ) :: rdat real ( kind = dp ) :: f ( 3 , 3 , 3 , * ) real ( kind = dp ) :: qx , qz integer , parameter :: kx = 4 , lx = 1 real ( kind = dp ) :: b1 ( 5 , kx , lx ), b2 ( 4 , 3 , kx , lx ), b3 ( 6 , kx , lx ) integer , parameter :: ind ( 6 , kx , lx ) = reshape (& [ 1 , 2 , 3 , 4 , 5 , 6 , 1 , 2 , 3 , 4 , 5 , 6 , 2 , 4 , 5 , 7 , 8 , 9 , 3 , 5 , 6 , 8 , 9 , 10 ], & shape ( ind )) integer :: i , j , k , l , m do j = 1 , 6 b3 ( j , 2 , 1 ) = - rdat % r03 ( j , 1 ) enddo do j = 1 , 3 m = in6 ( j ) b2 ( 1 , j , 2 , 1 ) = - rdat % r02 ( m , 3 ) b2 ( 2 , j , 2 , 1 ) = - rdat % r02 ( m , 4 ) b2 ( 3 , j , 2 , 1 ) = - rdat % r02 ( m , 5 ) b2 ( 4 , j , 2 , 1 ) = - rdat % r02 ( m , 6 ) enddo j = 1 do i = 1 , 5 b1 ( i , 2 , 1 ) = - rdat % r01 ( j , i + 8 ) enddo do j = 1 , 6 k = ind ( j , 3 , 1 ) b3 ( j , 3 , 1 ) = - rdat % r03 ( k , 1 ) enddo do j = 1 , 3 k = ind ( j , 3 , 1 ) m = in6 ( k ) b2 ( 1 , j , 3 , 1 ) = - rdat % r02 ( m , 3 ) b2 ( 2 , j , 3 , 1 ) = - rdat % r02 ( m , 4 ) b2 ( 3 , j , 3 , 1 ) = - rdat % r02 ( m , 5 ) b2 ( 4 , j , 3 , 1 ) = - rdat % r02 ( m , 6 ) enddo j = 1 k = ind ( j , 3 , 1 ) do i = 1 , 5 b1 ( i , 3 , 1 ) = - rdat % r01 ( k , i + 8 ) enddo do j = 1 , 6 k = ind ( j , 4 , 1 ) m = in6 ( j ) b3 ( j , 4 , 1 ) = - rdat % r03 ( k , 1 ) + rdat % r02 ( m , 2 ) enddo do j = 1 , 3 k = ind ( j , 4 , 1 ) m = in6 ( k ) b2 ( 1 , j , 4 , 1 ) = - rdat % r02 ( m , 3 ) + rdat % r01 ( j , 5 ) b2 ( 2 , j , 4 , 1 ) = - rdat % r02 ( m , 4 ) + rdat % r01 ( j , 6 ) b2 ( 3 , j , 4 , 1 ) = - rdat % r02 ( m , 5 ) + rdat % r01 ( j , 7 ) b2 ( 4 , j , 4 , 1 ) = - rdat % r02 ( m , 6 ) + rdat % r01 ( j , 8 ) enddo j = 1 k = ind ( j , 4 , 1 ) do i = 1 , 5 b1 ( i , 4 , 1 ) = - rdat % r01 ( k , i + 8 ) + rdat % r00 ( i , 2 ) enddo do l = 1 , lx do k = 2 , kx f ( 1 , 1 , k - 1 , l ) = b3 ( 1 , k , l ) + b1 ( 5 , k , l ) + ( b2 ( 3 , 1 , k , l ) + b2 ( 4 , 1 , k , l ) + b1 ( 4 , k , l ) * qx ) * qx f ( 2 , 1 , k - 1 , l ) = b3 ( 2 , k , l ) + b2 ( 4 , 2 , k , l ) * qx f ( 3 , 1 , k - 1 , l ) = b3 ( 3 , k , l ) + b2 ( 4 , 3 , k , l ) * qx + ( b2 ( 3 , 1 , k , l ) + b1 ( 4 , k , l ) * qx ) * qz f ( 1 , 2 , k - 1 , l ) = b3 ( 2 , k , l ) + b2 ( 3 , 2 , k , l ) * qx f ( 2 , 2 , k - 1 , l ) = b3 ( 4 , k , l ) + b1 ( 5 , k , l ) f ( 3 , 2 , k - 1 , l ) = b3 ( 5 , k , l ) + b2 ( 3 , 2 , k , l ) * qz f ( 1 , 3 , k - 1 , l ) = b3 ( 3 , k , l ) + b2 ( 4 , 1 , k , l ) * qz + ( b2 ( 3 , 3 , k , l ) + b1 ( 4 , k , l ) * qz ) * qx f ( 2 , 3 , k - 1 , l ) = b3 ( 5 , k , l ) + b2 ( 4 , 2 , k , l ) * qz f ( 3 , 3 , k - 1 , l ) = b3 ( 6 , k , l ) + b1 ( 5 , k , l ) + ( b2 ( 3 , 3 , k , l ) + b2 ( 4 , 3 , k , l ) + b1 ( 4 , k , l ) * qz ) * qz enddo enddo end subroutine mcdv_05 ! > ! >    @brief   pppp case ! > ! >    @details integration of a pppp case ! > subroutine mcdv_06 ( f , rdat , qx , qz ) implicit none type ( rotaxis_data_t ) :: rdat real ( kind = dp ) :: f ( 3 , 3 , 3 , * ) real ( kind = dp ) :: qx , qz integer , parameter :: kx = 4 , lx = 4 real ( kind = dp ) :: b1 ( 5 , kx , lx ), b2 ( 4 , 3 , kx , lx ), b3 ( 6 , kx , lx ) integer , parameter :: ind ( 6 , kx , lx ) = reshape (& [ 1 , 2 , 3 , 4 , 5 , 6 , 1 , 2 , 3 , 4 , 5 , 6 , 2 , 4 , 5 , 7 , 8 , 9 , 3 , 5 , 6 , & 8 , 9 , 10 , 1 , 2 , 3 , 4 , 5 , 6 , 1 , 2 , 3 , 4 , 5 , 6 , 2 , 4 , 5 , 7 , 8 , 9 , & 3 , 5 , 6 , 8 , 9 , 10 , 2 , 4 , 5 , 7 , 8 , 9 , 2 , 4 , 5 , 7 , 8 , 9 , 4 , 7 , 8 , & 11 , 12 , 13 , 5 , 8 , 9 , 12 , 13 , 14 , 3 , 5 , 6 , 8 , 9 , 10 , 3 , 5 , 6 , 8 , & 9 , 10 , 5 , 8 , 9 , 12 , 13 , 14 , 6 , 9 , 10 , 13 , 14 , 15 ], & shape ( ind )) integer :: i , j , k , l , m do j = 1 , 6 m = in6 ( j ) b3 ( j , 1 , 1 ) = + rdat % r02 ( m , 1 ) enddo do j = 1 , 3 b2 ( 1 , j , 1 , 1 ) = + rdat % r01 ( j , 1 ) b2 ( 2 , j , 1 , 1 ) = + rdat % r01 ( j , 2 ) b2 ( 3 , j , 1 , 1 ) = + rdat % r01 ( j , 3 ) b2 ( 4 , j , 1 , 1 ) = + rdat % r01 ( j , 4 ) enddo do i = 1 , 5 b1 ( i , 1 , 1 ) = + rdat % r00 ( i , 1 ) enddo do j = 1 , 6 b3 ( j , 2 , 1 ) = - rdat % r03 ( j , 2 ) enddo do j = 1 , 3 m = in6 ( j ) b2 ( 1 , j , 2 , 1 ) = - rdat % r02 ( m , 6 ) b2 ( 2 , j , 2 , 1 ) = - rdat % r02 ( m , 7 ) b2 ( 3 , j , 2 , 1 ) = - rdat % r02 ( m , 8 ) b2 ( 4 , j , 2 , 1 ) = - rdat % r02 ( m , 9 ) enddo j = 1 do i = 1 , 5 b1 ( i , 2 , 1 ) = - rdat % r01 ( j , i + 20 ) enddo do j = 1 , 6 k = ind ( j , 3 , 1 ) b3 ( j , 3 , 1 ) = - rdat % r03 ( k , 2 ) enddo do j = 1 , 3 k = ind ( j , 3 , 1 ) m = in6 ( k ) b2 ( 1 , j , 3 , 1 ) = - rdat % r02 ( m , 6 ) b2 ( 2 , j , 3 , 1 ) = - rdat % r02 ( m , 7 ) b2 ( 3 , j , 3 , 1 ) = - rdat % r02 ( m , 8 ) b2 ( 4 , j , 3 , 1 ) = - rdat % r02 ( m , 9 ) enddo j = 1 k = ind ( j , 3 , 1 ) do i = 1 , 5 b1 ( i , 3 , 1 ) = - rdat % r01 ( k , i + 20 ) enddo do j = 1 , 6 k = ind ( j , 4 , 1 ) m = in6 ( j ) b3 ( j , 4 , 1 ) = - rdat % r03 ( k , 2 ) + rdat % r02 ( m , 2 ) enddo do j = 1 , 3 k = ind ( j , 4 , 1 ) m = in6 ( k ) b2 ( 1 , j , 4 , 1 ) = - rdat % r02 ( m , 6 ) + rdat % r01 ( j , 5 ) b2 ( 2 , j , 4 , 1 ) = - rdat % r02 ( m , 7 ) + rdat % r01 ( j , 6 ) b2 ( 3 , j , 4 , 1 ) = - rdat % r02 ( m , 8 ) + rdat % r01 ( j , 7 ) b2 ( 4 , j , 4 , 1 ) = - rdat % r02 ( m , 9 ) + rdat % r01 ( j , 8 ) enddo j = 1 k = ind ( j , 4 , 1 ) do i = 1 , 5 b1 ( i , 4 , 1 ) = - rdat % r01 ( k , i + 20 ) + rdat % r00 ( i , 2 ) enddo do j = 1 , 6 b3 ( j , 1 , 2 ) = - rdat % r03 ( j , 3 ) enddo do j = 1 , 3 m = in6 ( j ) b2 ( 1 , j , 1 , 2 ) = - rdat % r02 ( m , 10 ) b2 ( 2 , j , 1 , 2 ) = - rdat % r02 ( m , 11 ) b2 ( 3 , j , 1 , 2 ) = - rdat % r02 ( m , 12 ) b2 ( 4 , j , 1 , 2 ) = - rdat % r02 ( m , 13 ) enddo j = 1 do i = 1 , 5 b1 ( i , 1 , 2 ) = - rdat % r01 ( j , i + 25 ) enddo do j = 1 , 6 m = in6 ( j ) b3 ( j , 2 , 2 ) = + rdat % r04 ( j , 1 ) + rdat % r02 ( m , 5 ) enddo do j = 1 , 3 b2 ( 1 , j , 2 , 2 ) = + rdat % r03 ( j , 5 ) + rdat % r01 ( j , 17 ) b2 ( 2 , j , 2 , 2 ) = + rdat % r03 ( j , 6 ) + rdat % r01 ( j , 18 ) b2 ( 3 , j , 2 , 2 ) = + rdat % r03 ( j , 7 ) + rdat % r01 ( j , 19 ) b2 ( 4 , j , 2 , 2 ) = + rdat % r03 ( j , 8 ) + rdat % r01 ( j , 20 ) enddo j = 1 do i = 1 , 5 b1 ( i , 2 , 2 ) = + rdat % r02 ( j , i + 21 ) + rdat % r00 ( i , 5 ) enddo do j = 1 , 6 k = ind ( j , 3 , 2 ) b3 ( j , 3 , 2 ) = + rdat % r04 ( k , 1 ) enddo do j = 1 , 3 k = ind ( j , 3 , 2 ) b2 ( 1 , j , 3 , 2 ) = + rdat % r03 ( k , 5 ) b2 ( 2 , j , 3 , 2 ) = + rdat % r03 ( k , 6 ) b2 ( 3 , j , 3 , 2 ) = + rdat % r03 ( k , 7 ) b2 ( 4 , j , 3 , 2 ) = + rdat % r03 ( k , 8 ) enddo j = 1 k = ind ( j , 3 , 2 ) m = in6 ( k ) do i = 1 , 5 b1 ( i , 3 , 2 ) = + rdat % r02 ( m , i + 21 ) enddo do j = 1 , 6 k = ind ( j , 4 , 2 ) b3 ( j , 4 , 2 ) = + rdat % r04 ( k , 1 ) - rdat % r03 ( j , 4 ) enddo do j = 1 , 3 k = ind ( j , 4 , 2 ) m = in6 ( j ) b2 ( 1 , j , 4 , 2 ) = + rdat % r03 ( k , 5 ) - rdat % r02 ( m , 14 ) b2 ( 2 , j , 4 , 2 ) = + rdat % r03 ( k , 6 ) - rdat % r02 ( m , 15 ) b2 ( 3 , j , 4 , 2 ) = + rdat % r03 ( k , 7 ) - rdat % r02 ( m , 16 ) b2 ( 4 , j , 4 , 2 ) = + rdat % r03 ( k , 8 ) - rdat % r02 ( m , 17 ) enddo j = 1 k = ind ( j , 4 , 2 ) m = in6 ( k ) do i = 1 , 5 b1 ( i , 4 , 2 ) = + rdat % r02 ( m , i + 21 ) - rdat % r01 ( j , i + 30 ) enddo do j = 1 , 6 k = ind ( j , 1 , 3 ) b3 ( j , 1 , 3 ) = - rdat % r03 ( k , 3 ) enddo do j = 1 , 3 k = ind ( j , 1 , 3 ) m = in6 ( k ) b2 ( 1 , j , 1 , 3 ) = - rdat % r02 ( m , 10 ) b2 ( 2 , j , 1 , 3 ) = - rdat % r02 ( m , 11 ) b2 ( 3 , j , 1 , 3 ) = - rdat % r02 ( m , 12 ) b2 ( 4 , j , 1 , 3 ) = - rdat % r02 ( m , 13 ) enddo j = 1 k = ind ( j , 1 , 3 ) do i = 1 , 5 b1 ( i , 1 , 3 ) = - rdat % r01 ( k , i + 25 ) enddo do j = 1 , 6 k = ind ( j , 3 , 3 ) m = in6 ( j ) b3 ( j , 3 , 3 ) = + rdat % r04 ( k , 1 ) + rdat % r02 ( m , 5 ) enddo do j = 1 , 3 k = ind ( j , 3 , 3 ) b2 ( 1 , j , 3 , 3 ) = + rdat % r03 ( k , 5 ) + rdat % r01 ( j , 17 ) b2 ( 2 , j , 3 , 3 ) = + rdat % r03 ( k , 6 ) + rdat % r01 ( j , 18 ) b2 ( 3 , j , 3 , 3 ) = + rdat % r03 ( k , 7 ) + rdat % r01 ( j , 19 ) b2 ( 4 , j , 3 , 3 ) = + rdat % r03 ( k , 8 ) + rdat % r01 ( j , 20 ) enddo j = 1 k = ind ( j , 3 , 3 ) m = in6 ( k ) do i = 1 , 5 b1 ( i , 3 , 3 ) = + rdat % r02 ( m , i + 21 ) + rdat % r00 ( i , 5 ) enddo b3 ( 1 , 4 , 3 ) = + rdat % r04 ( 5 , 1 ) - rdat % r03 ( 2 , 4 ) b3 ( 2 , 4 , 3 ) = + rdat % r04 ( 8 , 1 ) - rdat % r03 ( 4 , 4 ) b3 ( 3 , 4 , 3 ) = + rdat % r04 ( 9 , 1 ) - rdat % r03 ( 5 , 4 ) b3 ( 4 , 4 , 3 ) = + rdat % r04 ( 12 , 1 ) - rdat % r03 ( 7 , 4 ) b3 ( 5 , 4 , 3 ) = + rdat % r04 ( 13 , 1 ) - rdat % r03 ( 8 , 4 ) b3 ( 6 , 4 , 3 ) = + rdat % r04 ( 14 , 1 ) - rdat % r03 ( 9 , 4 ) b2 ( 1 , 1 , 4 , 3 ) = + rdat % r03 ( 5 , 5 ) - rdat % r02 ( 4 , 14 ) b2 ( 2 , 1 , 4 , 3 ) = + rdat % r03 ( 5 , 6 ) - rdat % r02 ( 4 , 15 ) b2 ( 3 , 1 , 4 , 3 ) = + rdat % r03 ( 5 , 7 ) - rdat % r02 ( 4 , 16 ) b2 ( 4 , 1 , 4 , 3 ) = + rdat % r03 ( 5 , 8 ) - rdat % r02 ( 4 , 17 ) b2 ( 1 , 2 , 4 , 3 ) = + rdat % r03 ( 8 , 5 ) - rdat % r02 ( 2 , 14 ) b2 ( 2 , 2 , 4 , 3 ) = + rdat % r03 ( 8 , 6 ) - rdat % r02 ( 2 , 15 ) b2 ( 3 , 2 , 4 , 3 ) = + rdat % r03 ( 8 , 7 ) - rdat % r02 ( 2 , 16 ) b2 ( 4 , 2 , 4 , 3 ) = + rdat % r03 ( 8 , 8 ) - rdat % r02 ( 2 , 17 ) b2 ( 1 , 3 , 4 , 3 ) = + rdat % r03 ( 9 , 5 ) - rdat % r02 ( 6 , 14 ) b2 ( 2 , 3 , 4 , 3 ) = + rdat % r03 ( 9 , 6 ) - rdat % r02 ( 6 , 15 ) b2 ( 3 , 3 , 4 , 3 ) = + rdat % r03 ( 9 , 7 ) - rdat % r02 ( 6 , 16 ) b2 ( 4 , 3 , 4 , 3 ) = + rdat % r03 ( 9 , 8 ) - rdat % r02 ( 6 , 17 ) do i = 1 , 5 b1 ( i , 4 , 3 ) = + rdat % r02 ( 6 , i + 21 ) - rdat % r01 ( 2 , i + 30 ) enddo do j = 1 , 6 k = ind ( j , 1 , 4 ) m = in6 ( j ) b3 ( j , 1 , 4 ) = - rdat % r03 ( k , 3 ) + rdat % r02 ( m , 3 ) enddo do j = 1 , 3 k = ind ( j , 1 , 4 ) m = in6 ( k ) b2 ( 1 , j , 1 , 4 ) = - rdat % r02 ( m , 10 ) + rdat % r01 ( j , 9 ) b2 ( 2 , j , 1 , 4 ) = - rdat % r02 ( m , 11 ) + rdat % r01 ( j , 10 ) b2 ( 3 , j , 1 , 4 ) = - rdat % r02 ( m , 12 ) + rdat % r01 ( j , 11 ) b2 ( 4 , j , 1 , 4 ) = - rdat % r02 ( m , 13 ) + rdat % r01 ( j , 12 ) enddo j = 1 k = ind ( j , 1 , 4 ) do i = 1 , 5 b1 ( i , 1 , 4 ) = - rdat % r01 ( k , i + 25 ) + rdat % r00 ( i , 3 ) enddo do j = 1 , 6 k = ind ( j , 2 , 4 ) b3 ( j , 2 , 4 ) = + rdat % r04 ( k , 1 ) - rdat % r03 ( j , 1 ) enddo do j = 1 , 3 k = ind ( j , 2 , 4 ) m = in6 ( j ) b2 ( 1 , j , 2 , 4 ) = + rdat % r03 ( k , 5 ) - rdat % r02 ( m , 18 ) b2 ( 2 , j , 2 , 4 ) = + rdat % r03 ( k , 6 ) - rdat % r02 ( m , 19 ) b2 ( 3 , j , 2 , 4 ) = + rdat % r03 ( k , 7 ) - rdat % r02 ( m , 20 ) b2 ( 4 , j , 2 , 4 ) = + rdat % r03 ( k , 8 ) - rdat % r02 ( m , 21 ) enddo j = 1 k = ind ( j , 2 , 4 ) m = in6 ( k ) do i = 1 , 5 b1 ( i , 2 , 4 ) = + rdat % r02 ( m , i + 21 ) - rdat % r01 ( j , i + 35 ) enddo b3 ( 1 , 3 , 4 ) = + rdat % r04 ( 5 , 1 ) - rdat % r03 ( 2 , 1 ) b3 ( 2 , 3 , 4 ) = + rdat % r04 ( 8 , 1 ) - rdat % r03 ( 4 , 1 ) b3 ( 3 , 3 , 4 ) = + rdat % r04 ( 9 , 1 ) - rdat % r03 ( 5 , 1 ) b3 ( 4 , 3 , 4 ) = + rdat % r04 ( 12 , 1 ) - rdat % r03 ( 7 , 1 ) b3 ( 5 , 3 , 4 ) = + rdat % r04 ( 13 , 1 ) - rdat % r03 ( 8 , 1 ) b3 ( 6 , 3 , 4 ) = + rdat % r04 ( 14 , 1 ) - rdat % r03 ( 9 , 1 ) b2 ( 1 , 1 , 3 , 4 ) = + rdat % r03 ( 5 , 5 ) - rdat % r02 ( 4 , 18 ) b2 ( 2 , 1 , 3 , 4 ) = + rdat % r03 ( 5 , 6 ) - rdat % r02 ( 4 , 19 ) b2 ( 3 , 1 , 3 , 4 ) = + rdat % r03 ( 5 , 7 ) - rdat % r02 ( 4 , 20 ) b2 ( 4 , 1 , 3 , 4 ) = + rdat % r03 ( 5 , 8 ) - rdat % r02 ( 4 , 21 ) b2 ( 1 , 2 , 3 , 4 ) = + rdat % r03 ( 8 , 5 ) - rdat % r02 ( 2 , 18 ) b2 ( 2 , 2 , 3 , 4 ) = + rdat % r03 ( 8 , 6 ) - rdat % r02 ( 2 , 19 ) b2 ( 3 , 2 , 3 , 4 ) = + rdat % r03 ( 8 , 7 ) - rdat % r02 ( 2 , 20 ) b2 ( 4 , 2 , 3 , 4 ) = + rdat % r03 ( 8 , 8 ) - rdat % r02 ( 2 , 21 ) b2 ( 1 , 3 , 3 , 4 ) = + rdat % r03 ( 9 , 5 ) - rdat % r02 ( 6 , 18 ) b2 ( 2 , 3 , 3 , 4 ) = + rdat % r03 ( 9 , 6 ) - rdat % r02 ( 6 , 19 ) b2 ( 3 , 3 , 3 , 4 ) = + rdat % r03 ( 9 , 7 ) - rdat % r02 ( 6 , 20 ) b2 ( 4 , 3 , 3 , 4 ) = + rdat % r03 ( 9 , 8 ) - rdat % r02 ( 6 , 21 ) do i = 1 , 5 b1 ( i , 3 , 4 ) = + rdat % r02 ( 6 , i + 21 ) - rdat % r01 ( 2 , i + 35 ) enddo b3 ( 1 , 4 , 4 ) = rdat % r04 ( 6 , 1 ) - rdat % r03 ( 3 , 1 ) - rdat % r03 ( 3 , 4 ) + rdat % r02 ( 1 , 4 ) & + rdat % r02 ( 1 , 5 ) b3 ( 2 , 4 , 4 ) = rdat % r04 ( 9 , 1 ) - rdat % r03 ( 5 , 1 ) - rdat % r03 ( 5 , 4 ) + rdat % r02 ( 4 , 4 ) & + rdat % r02 ( 4 , 5 ) b3 ( 3 , 4 , 4 ) = rdat % r04 ( 10 , 1 ) - rdat % r03 ( 6 , 1 ) - rdat % r03 ( 6 , 4 ) + rdat % r02 ( 5 , 4 ) & + rdat % r02 ( 5 , 5 ) b3 ( 4 , 4 , 4 ) = rdat % r04 ( 13 , 1 ) - rdat % r03 ( 8 , 1 ) - rdat % r03 ( 8 , 4 ) + rdat % r02 ( 2 , 4 ) & + rdat % r02 ( 2 , 5 ) b3 ( 5 , 4 , 4 ) = rdat % r04 ( 14 , 1 ) - rdat % r03 ( 9 , 1 ) - rdat % r03 ( 9 , 4 ) + rdat % r02 ( 6 , 4 ) & + rdat % r02 ( 6 , 5 ) b3 ( 6 , 4 , 4 ) = rdat % r04 ( 15 , 1 ) - rdat % r03 ( 10 , 1 ) - rdat % r03 ( 10 , 4 ) + rdat % r02 ( 3 , 4 ) & + rdat % r02 ( 3 , 5 ) b2 ( 1 , 1 , 4 , 4 ) = rdat % r03 ( 6 , 5 ) - rdat % r02 ( 5 , 14 ) - rdat % r02 ( 5 , 18 ) + & rdat % r01 ( 1 , 13 ) + rdat % r01 ( 1 , 17 ) b2 ( 2 , 1 , 4 , 4 ) = rdat % r03 ( 6 , 6 ) - rdat % r02 ( 5 , 15 ) - rdat % r02 ( 5 , 19 ) + & rdat % r01 ( 1 , 14 ) + rdat % r01 ( 1 , 18 ) b2 ( 3 , 1 , 4 , 4 ) = rdat % r03 ( 6 , 7 ) - rdat % r02 ( 5 , 16 ) - rdat % r02 ( 5 , 20 ) + & rdat % r01 ( 1 , 15 ) + rdat % r01 ( 1 , 19 ) b2 ( 4 , 1 , 4 , 4 ) = rdat % r03 ( 6 , 8 ) - rdat % r02 ( 5 , 17 ) - rdat % r02 ( 5 , 21 ) + & rdat % r01 ( 1 , 16 ) + rdat % r01 ( 1 , 20 ) b2 ( 1 , 2 , 4 , 4 ) = rdat % r03 ( 9 , 5 ) - rdat % r02 ( 6 , 14 ) - rdat % r02 ( 6 , 18 ) + & rdat % r01 ( 2 , 13 ) + rdat % r01 ( 2 , 17 ) b2 ( 2 , 2 , 4 , 4 ) = rdat % r03 ( 9 , 6 ) - rdat % r02 ( 6 , 15 ) - rdat % r02 ( 6 , 19 ) + & rdat % r01 ( 2 , 14 ) + rdat % r01 ( 2 , 18 ) b2 ( 3 , 2 , 4 , 4 ) = rdat % r03 ( 9 , 7 ) - rdat % r02 ( 6 , 16 ) - rdat % r02 ( 6 , 20 ) + & rdat % r01 ( 2 , 15 ) + rdat % r01 ( 2 , 19 ) b2 ( 4 , 2 , 4 , 4 ) = rdat % r03 ( 9 , 8 ) - rdat % r02 ( 6 , 17 ) - rdat % r02 ( 6 , 21 ) + & rdat % r01 ( 2 , 16 ) + rdat % r01 ( 2 , 20 ) b2 ( 1 , 3 , 4 , 4 ) = rdat % r03 ( 10 , 5 ) - rdat % r02 ( 3 , 14 ) - rdat % r02 ( 3 , 18 ) + & rdat % r01 ( 3 , 13 ) + rdat % r01 ( 3 , 17 ) b2 ( 2 , 3 , 4 , 4 ) = rdat % r03 ( 10 , 6 ) - rdat % r02 ( 3 , 15 ) - rdat % r02 ( 3 , 19 ) + & rdat % r01 ( 3 , 14 ) + rdat % r01 ( 3 , 18 ) b2 ( 3 , 3 , 4 , 4 ) = rdat % r03 ( 10 , 7 ) - rdat % r02 ( 3 , 16 ) - rdat % r02 ( 3 , 20 ) + & rdat % r01 ( 3 , 15 ) + rdat % r01 ( 3 , 19 ) b2 ( 4 , 3 , 4 , 4 ) = rdat % r03 ( 10 , 8 ) - rdat % r02 ( 3 , 17 ) - rdat % r02 ( 3 , 21 ) + & rdat % r01 ( 3 , 16 ) + rdat % r01 ( 3 , 20 ) do i = 1 , 5 b1 ( i , 4 , 4 ) = + rdat % r02 ( 3 , i + 21 ) - rdat % r01 ( 3 , i + 30 ) - & rdat % r01 ( 3 , i + 35 ) + rdat % r00 ( i , 4 ) + rdat % r00 ( i , 5 ) enddo do l = 2 , lx do k = 2 , kx if ( k == 2. and . l == 3 ) cycle f ( 1 , 1 , k - 1 , l - 1 ) = b3 ( 1 , k , l ) + b1 ( 5 , k , l ) + ( b2 ( 3 , 1 , k , l ) + b2 ( 4 , 1 , k , l ) + b1 ( 4 , k , l ) * qx ) * qx f ( 2 , 1 , k - 1 , l - 1 ) = b3 ( 2 , k , l ) + b2 ( 4 , 2 , k , l ) * qx f ( 3 , 1 , k - 1 , l - 1 ) = b3 ( 3 , k , l ) + b2 ( 4 , 3 , k , l ) * qx + ( b2 ( 3 , 1 , k , l ) + b1 ( 4 , k , l ) * qx ) * qz f ( 1 , 2 , k - 1 , l - 1 ) = b3 ( 2 , k , l ) + b2 ( 3 , 2 , k , l ) * qx f ( 2 , 2 , k - 1 , l - 1 ) = b3 ( 4 , k , l ) + b1 ( 5 , k , l ) f ( 3 , 2 , k - 1 , l - 1 ) = b3 ( 5 , k , l ) + b2 ( 3 , 2 , k , l ) * qz f ( 1 , 3 , k - 1 , l - 1 ) = b3 ( 3 , k , l ) + b2 ( 4 , 1 , k , l ) * qz + ( b2 ( 3 , 3 , k , l ) + b1 ( 4 , k , l ) * qz ) * qx f ( 2 , 3 , k - 1 , l - 1 ) = b3 ( 5 , k , l ) + b2 ( 4 , 2 , k , l ) * qz f ( 3 , 3 , k - 1 , l - 1 ) = b3 ( 6 , k , l ) + b1 ( 5 , k , l ) + ( b2 ( 3 , 3 , k , l ) + b2 ( 4 , 3 , k , l ) + b1 ( 4 , k , l ) * qz ) * qz enddo enddo f (:,:, 1 , 2 ) = f (:,:, 2 , 1 ) end subroutine mcdv_06 ! > ! >    @brief   dsss case ! > ! >    @details integration of a dsss case ! >             simplified calculation of f(i,j,k,l) for cases where ! >                 i = 1..6,  j = 1..1,  k = 1..kx,  and  l = 1..lx ! >             using auxiliary arrays c1, c2 and c3. ! > subroutine mcdv_07 ( f , rdat , qx , qz ) implicit none type ( rotaxis_data_t ) :: rdat real ( kind = dp ) :: f ( 6 , 1 , 1 , * ) real ( kind = dp ) :: qx , qz integer , parameter :: kx = 1 , lx = 1 real ( kind = dp ) :: c1 ( 2 , kx , lx ), c2 ( 3 , kx , lx ), c3 ( 6 , kx , lx ) integer :: j , k , l , m ! Auxiliary arrays to simplify the formulation of f(i,j,k,l) ! Where:  i = 1..6,  j = 1..1,  k = 1  and  l = 1 do j = 1 , 6 m = in6 ( j ) c3 ( j , 1 , 1 ) =+ rdat % r02 ( m , 1 ) enddo c2 ( 1 , 1 , 1 ) =+ rdat % r01 ( 1 , 1 ) c2 ( 2 , 1 , 1 ) =+ rdat % r01 ( 2 , 1 ) c2 ( 3 , 1 , 1 ) =+ rdat % r01 ( 3 , 1 ) c1 ( 1 , 1 , 1 ) =+ rdat % r00 ( 1 , 1 ) c1 ( 2 , 1 , 1 ) =+ rdat % r00 ( 2 , 1 ) ! Do l=1,lx ! Do k=1,kx l = 1 k = 1 f ( 1 , 1 , k , l ) =+ c3 ( 1 , k , l ) + c1 ( 1 , k , l ) & & + ( + c2 ( 1 , k , l ) + c2 ( 1 , k , l ) + c1 ( 2 , k , l ) * qx ) * qx f ( 2 , 1 , k , l ) =+ c3 ( 4 , k , l ) + c1 ( 1 , k , l ) f ( 3 , 1 , k , l ) =+ c3 ( 6 , k , l ) + c1 ( 1 , k , l ) & & + ( + c2 ( 3 , k , l ) + c2 ( 3 , k , l ) + c1 ( 2 , k , l ) * qz ) * qz f ( 4 , 1 , k , l ) =+ c3 ( 2 , k , l ) + c2 ( 2 , k , l ) * qx f ( 5 , 1 , k , l ) =+ c3 ( 3 , k , l ) + c2 ( 3 , k , l ) * qx & & + ( + c2 ( 1 , k , l ) + c1 ( 2 , k , l ) * qx ) * qz f ( 6 , 1 , k , l ) =+ c3 ( 5 , k , l ) + c2 ( 2 , k , l ) * qz ! Enddo ! Enddo end subroutine mcdv_07 ! > ! >    @brief   dpss case ! > ! >    @details integration of a dpss case ! > subroutine mcdv_08 ( f , rdat , qx , qz ) implicit none type ( rotaxis_data_t ) :: rdat real ( kind = dp ) :: f ( 6 , 3 , 1 , * ) real ( kind = dp ) :: qx , qz integer , parameter :: kx = 1 , lx = 1 real ( kind = dp ) :: d1 ( 5 , kx , lx ), d2 ( 4 , 3 , kx , lx ), d3 ( 3 , 6 , kx , lx ) real ( kind = dp ) :: d4 ( 10 , kx , lx ) real ( kind = dp ) :: xx , zz , xz , xxx , xxz , xzz , zzz real ( kind = dp ) :: qxd , qzd , xzd integer :: i , j , k , l , m do j = 1 , 10 d4 ( j , 1 , 1 ) =+ rdat % r03 ( j , 1 ) enddo do j = 1 , 6 m = in6 ( j ) d3 ( 1 , j , 1 , 1 ) =+ rdat % r02 ( m , 1 ) d3 ( 2 , j , 1 , 1 ) =+ rdat % r02 ( m , 2 ) d3 ( 3 , j , 1 , 1 ) =+ rdat % r02 ( m , 3 ) enddo do j = 1 , 3 d2 ( 1 , j , 1 , 1 ) =+ rdat % r01 ( j , 1 ) d2 ( 2 , j , 1 , 1 ) =+ rdat % r01 ( j , 2 ) d2 ( 3 , j , 1 , 1 ) =+ rdat % r01 ( j , 3 ) d2 ( 4 , j , 1 , 1 ) =+ rdat % r01 ( j , 4 ) enddo do i = 1 , 5 d1 ( i , 1 , 1 ) =+ rdat % r00 ( i , 1 ) enddo xx = qx * qx zz = qz * qz xz = qx * qz xxx = xx * qx xxz = xx * qz xzz = zz * qx zzz = zz * qz qxd = qx + qx qzd = qz + qz xzd = xz + xz l = 1 k = 1 f ( 1 , 1 , k , l ) = d4 ( 1 , k , l ) + d2 ( 2 , 1 , k , l ) * 3 + ( + d3 ( 2 , 1 , k , l ) * 2 + d3 ( 3 , 1 , k , l ) + d1 ( 3 , k , l ) * 2 + d1 ( 4 , k , l )) * qx + ( + d2 ( 3 , 1 , k , l ) + d2 ( 4 , 1 , k , l ) * 2 ) * xx + d1 ( 5 , k , l ) * xxx f ( 2 , 1 , k , l ) = d4 ( 4 , k , l ) + d2 ( 2 , 1 , k , l ) + ( + d3 ( 3 , 4 , k , l ) + d1 ( 4 , k , l )) * qx f ( 3 , 1 , k , l ) = d4 ( 6 , k , l ) + d2 ( 2 , 1 , k , l ) + ( + d3 ( 3 , 6 , k , l ) + d1 ( 4 , k , l )) * qx + d3 ( 2 , 3 , k , l ) * qzd + d2 ( 4 , 3 , k , l ) * xzd + d2 ( 3 , 1 , k , l ) * zz + d1 ( 5 , k , l ) * xzz f ( 4 , 1 , k , l ) = d4 ( 2 , k , l ) + d2 ( 2 , 2 , k , l ) + ( + d3 ( 2 , 2 , k , l ) + d3 ( 3 , 2 , k , l )) * qx + d2 ( 4 , 2 , k , l ) * xx f ( 5 , 1 , k , l ) = d4 ( 3 , k , l ) + d2 ( 2 , 3 , k , l ) + ( + d3 ( 2 , 3 , k , l ) + d3 ( 3 , 3 , k , l )) * qx + ( + d3 ( 2 , 1 , k , l ) + d1 ( 3 , k , l )) * qz + d2 ( 4 , 3 , k , l ) * xx + ( + d2 ( 3 , 1 , k , l ) + d2 ( 4 , 1 , k , l )) * xz + d1 ( 5 , k , l ) * xxz f ( 6 , 1 , k , l ) = d4 ( 5 , k , l ) + d3 ( 3 , 5 , k , l ) * qx + d3 ( 2 , 2 , k , l ) * qz + d2 ( 4 , 2 , k , l ) * xz f ( 1 , 2 , k , l ) = d4 ( 2 , k , l ) + d2 ( 2 , 2 , k , l ) + d3 ( 2 , 2 , k , l ) * qxd + d2 ( 3 , 2 , k , l ) * xx f ( 2 , 2 , k , l ) = d4 ( 7 , k , l ) + d2 ( 2 , 2 , k , l ) * 3 f ( 3 , 2 , k , l ) = d4 ( 9 , k , l ) + d2 ( 2 , 2 , k , l ) + d3 ( 2 , 5 , k , l ) * qzd + d2 ( 3 , 2 , k , l ) * zz f ( 4 , 2 , k , l ) = d4 ( 4 , k , l ) + d2 ( 2 , 1 , k , l ) + ( + d3 ( 2 , 4 , k , l ) + d1 ( 3 , k , l )) * qx f ( 5 , 2 , k , l ) = d4 ( 5 , k , l ) + d3 ( 2 , 5 , k , l ) * qx + d3 ( 2 , 2 , k , l ) * qz + d2 ( 3 , 2 , k , l ) * xz f ( 6 , 2 , k , l ) = d4 ( 8 , k , l ) + d2 ( 2 , 3 , k , l ) + ( + d3 ( 2 , 4 , k , l ) + d1 ( 3 , k , l )) * qz f ( 1 , 3 , k , l ) = d4 ( 3 , k , l ) + d2 ( 2 , 3 , k , l ) + d3 ( 2 , 3 , k , l ) * qxd + ( + d3 ( 3 , 1 , k , l ) + d1 ( 4 , k , l )) * qz + d2 ( 3 , 3 , k , l ) * xx + d2 ( 4 , 1 , k , l ) * xzd + d1 ( 5 , k , l ) * xxz f ( 2 , 3 , k , l ) = d4 ( 8 , k , l ) + d2 ( 2 , 3 , k , l ) + ( + d3 ( 3 , 4 , k , l ) + d1 ( 4 , k , l )) * qz f ( 3 , 3 , k , l ) = d4 ( 10 , k , l ) + d2 ( 2 , 3 , k , l ) * 3 + ( + d3 ( 2 , 6 , k , l ) * 2 + d3 ( 3 , 6 , k , l ) + d1 ( 3 , k , l ) * 2 + d1 ( 4 , k , l )) * qz + ( + d2 ( 3 , 3 , k , l ) + d2 ( 4 , 3 , k , l ) * 2 ) * zz + d1 ( 5 , k , l ) * zzz f ( 4 , 3 , k , l ) = d4 ( 5 , k , l ) + d3 ( 2 , 5 , k , l ) * qx + d3 ( 3 , 2 , k , l ) * qz + d2 ( 4 , 2 , k , l ) * xz f ( 5 , 3 , k , l ) = d4 ( 6 , k , l ) + d2 ( 2 , 1 , k , l ) + ( + d3 ( 2 , 6 , k , l ) + d1 ( 3 , k , l )) * qx + ( + d3 ( 2 , 3 , k , l ) + d3 ( 3 , 3 , k , l )) * qz + ( + d2 ( 3 , 3 , k , l ) + d2 ( 4 , 3 , k , l )) * xz + d2 ( 4 , 1 , k , l ) * zz + d1 ( 5 , k , l ) * xzz f ( 6 , 3 , k , l ) = d4 ( 9 , k , l ) + d2 ( 2 , 2 , k , l ) + ( + d3 ( 2 , 5 , k , l ) + d3 ( 3 , 5 , k , l )) * qz + d2 ( 4 , 2 , k , l ) * zz end subroutine mcdv_08 ! > ! >    @brief   dsps case ! > ! >    @details integration of a dsps case ! > subroutine mcdv_09 ( f , rdat , qx , qz ) implicit none type ( rotaxis_data_t ) :: rdat real ( kind = dp ) :: f ( 6 , 1 , 3 , * ) real ( kind = dp ) :: qx , qz integer , parameter :: kx = 4 , lx = 1 real ( kind = dp ) :: c1 ( 2 , kx , lx ), c2 ( 3 , kx , lx ), c3 ( 6 , kx , lx ) integer , parameter :: ind ( 6 , kx , lx ) = reshape (& [ 1 , 2 , 3 , 4 , 5 , 6 , 1 , 2 , 3 , 4 , 5 , 6 , 2 , 4 , 5 , 7 , 8 , 9 , 3 , 5 , 6 , 8 , 9 , 10 ] & , shape ( ind )) integer :: j , k , l , m do j = 1 , 6 m = in6 ( j ) c3 ( j , 1 , 1 ) =+ rdat % r02 ( m , 1 ) enddo c2 ( 1 , 1 , 1 ) =+ rdat % r01 ( 1 , 1 ) c2 ( 2 , 1 , 1 ) =+ rdat % r01 ( 2 , 1 ) c2 ( 3 , 1 , 1 ) =+ rdat % r01 ( 3 , 1 ) c1 ( 1 , 1 , 1 ) =+ rdat % r00 ( 1 , 1 ) c1 ( 2 , 1 , 1 ) =+ rdat % r00 ( 2 , 1 ) do j = 1 , 6 c3 ( j , 2 , 1 ) =- rdat % r03 ( j , 1 ) enddo c2 ( 1 , 2 , 1 ) =- rdat % r02 ( 1 , 3 ) c2 ( 2 , 2 , 1 ) =- rdat % r02 ( 4 , 3 ) c2 ( 3 , 2 , 1 ) =- rdat % r02 ( 5 , 3 ) c1 ( 1 , 2 , 1 ) =- rdat % r01 ( 1 , 3 ) c1 ( 2 , 2 , 1 ) =- rdat % r01 ( 1 , 4 ) do j = 1 , 6 k = ind ( j , 3 , 1 ) c3 ( j , 3 , 1 ) =- rdat % r03 ( k , 1 ) enddo c2 ( 1 , 3 , 1 ) =- rdat % r02 ( 4 , 3 ) c2 ( 2 , 3 , 1 ) =- rdat % r02 ( 2 , 3 ) c2 ( 3 , 3 , 1 ) =- rdat % r02 ( 6 , 3 ) c1 ( 1 , 3 , 1 ) =- rdat % r01 ( 2 , 3 ) c1 ( 2 , 3 , 1 ) =- rdat % r01 ( 2 , 4 ) do j = 1 , 6 k = ind ( j , 4 , 1 ) m = in6 ( j ) c3 ( j , 4 , 1 ) =- rdat % r03 ( k , 1 ) + rdat % r02 ( m , 2 ) enddo c2 ( 1 , 4 , 1 ) =- rdat % r02 ( 5 , 3 ) + rdat % r01 ( 1 , 2 ) c2 ( 2 , 4 , 1 ) =- rdat % r02 ( 6 , 3 ) + rdat % r01 ( 2 , 2 ) c2 ( 3 , 4 , 1 ) =- rdat % r02 ( 3 , 3 ) + rdat % r01 ( 3 , 2 ) c1 ( 1 , 4 , 1 ) =- rdat % r01 ( 3 , 3 ) + rdat % r00 ( 3 , 1 ) c1 ( 2 , 4 , 1 ) =- rdat % r01 ( 3 , 4 ) + rdat % r00 ( 4 , 1 ) l = 1 do k = 2 , kx f ( 1 , 1 , k - 1 , l ) = c3 ( 1 , k , l ) + c1 ( 1 , k , l ) + ( c2 ( 1 , k , l ) + c2 ( 1 , k , l ) + c1 ( 2 , k , l ) * qx ) * qx f ( 2 , 1 , k - 1 , l ) = c3 ( 4 , k , l ) + c1 ( 1 , k , l ) f ( 3 , 1 , k - 1 , l ) = c3 ( 6 , k , l ) + c1 ( 1 , k , l ) + ( c2 ( 3 , k , l ) + c2 ( 3 , k , l ) + c1 ( 2 , k , l ) * qz ) * qz f ( 4 , 1 , k - 1 , l ) = c3 ( 2 , k , l ) + c2 ( 2 , k , l ) * qx f ( 5 , 1 , k - 1 , l ) = c3 ( 3 , k , l ) + c2 ( 3 , k , l ) * qx + ( c2 ( 1 , k , l ) + c1 ( 2 , k , l ) * qx ) * qz f ( 6 , 1 , k - 1 , l ) = c3 ( 5 , k , l ) + c2 ( 2 , k , l ) * qz enddo end subroutine mcdv_09 ! > ! >    @brief   ddss case ! > ! >    @details integration of a ddss case ! > subroutine mcdv_10 ( f , rdat , qx , qz ) implicit none type ( rotaxis_data_t ) :: rdat real ( kind = dp ) :: f ( 6 , 6 , 1 , * ) real ( kind = dp ) :: qx , qz !integer, parameter :: kx = 4, lx = 1 integer , parameter :: kx = 1 , lx = 1 real ( kind = dp ) :: e1 ( 5 , kx , lx ), e2 ( 4 , 3 , kx , lx ), e3 ( 4 , 6 , kx , lx ), & e4 ( 2 , 10 , kx , lx ), e5 ( 15 , kx , lx ) integer :: i , j , k , l , m real ( kind = dp ) :: xx , zz , xz , xxx , xxz , xzz , zzz real ( kind = dp ) :: xxxx , xxzz , xxxz , xzzz , zzzz real ( kind = dp ) :: xxxd , xxzd , xzzd , zzzd real ( kind = dp ) :: xzq real ( kind = dp ) :: qxd , qzd , xzd do j = 1 , 15 e5 ( j , 1 , 1 ) =+ rdat % r04 ( j , 1 ) enddo do j = 1 , 10 e4 ( 1 , j , 1 , 1 ) =+ rdat % r03 ( j , 1 ) e4 ( 2 , j , 1 , 1 ) =+ rdat % r03 ( j , 2 ) enddo do j = 1 , 6 m = in6 ( j ) e3 ( 1 , j , 1 , 1 ) =+ rdat % r02 ( m , 1 ) e3 ( 2 , j , 1 , 1 ) =+ rdat % r02 ( m , 2 ) e3 ( 3 , j , 1 , 1 ) =+ rdat % r02 ( m , 3 ) e3 ( 4 , j , 1 , 1 ) =+ rdat % r02 ( m , 4 ) enddo do j = 1 , 3 e2 ( 1 , j , 1 , 1 ) =+ rdat % r01 ( j , 1 ) e2 ( 2 , j , 1 , 1 ) =+ rdat % r01 ( j , 2 ) e2 ( 3 , j , 1 , 1 ) =+ rdat % r01 ( j , 3 ) e2 ( 4 , j , 1 , 1 ) =+ rdat % r01 ( j , 4 ) enddo do i = 1 , 5 e1 ( i , 1 , 1 ) =+ rdat % r00 ( i , 1 ) enddo xx = qx * qx zz = qz * qz xz = qx * qz xxx = xx * qx xxz = xx * qz xzz = zz * qx zzz = zz * qz xxxx = xx * xx xxxz = xx * xz xxzz = xx * zz xzzz = xz * zz zzzz = zz * zz qxd = qx + qx qzd = qz + qz xzd = xz + xz xxxd = xxx + xxx xxzd = xxz + xxz xzzd = xzz + xzz zzzd = zzz + zzz xzq = xz + xz + xz + xz f ( 1 , 1 , 1 , 1 ) = e5 ( 1 , 1 , 1 ) + e3 ( 1 , 1 , 1 , 1 ) * 6 + e1 ( 1 , 1 , 1 ) * 3 + ( + e4 ( 1 , 1 , 1 , 1 ) + e4 ( 2 , 1 , 1 , 1 ) + ( + e2 ( 1 , 1 , 1 , 1 ) + e2 ( 2 , 1 , 1 , 1 )) * 3 ) * qxd + ( + e3 ( 2 , 1 , 1 , 1 ) + e3 ( 3 , 1 , 1 , 1 ) * 4 + e3 ( 4 , 1 , 1 , 1 ) + e1 ( 2 , 1 , 1 ) + e1 ( 3 , 1 , 1 ) * 4 + e1 ( 4 , 1 , 1 )) * xx + ( + e2 ( 3 , 1 , 1 , 1 ) + e2 ( 4 , 1 , 1 , 1 )) * xxxd + e1 ( 5 , 1 , 1 ) * xxxx f ( 2 , 1 , 1 , 1 ) = e5 ( 4 , 1 , 1 ) + e3 ( 1 , 4 , 1 , 1 ) + e3 ( 1 , 1 , 1 , 1 ) + e1 ( 1 , 1 , 1 ) + ( + e4 ( 2 , 4 , 1 , 1 ) + e2 ( 2 , 1 , 1 , 1 )) * qxd + ( + e3 ( 4 , 4 , 1 , 1 ) + e1 ( 4 , 1 , 1 )) * xx f ( 3 , 1 , 1 , 1 ) = e5 ( 6 , 1 , 1 ) + e3 ( 1 , 6 , 1 , 1 ) + e3 ( 1 , 1 , 1 , 1 ) + e1 ( 1 , 1 , 1 ) + ( + e4 ( 2 , 6 , 1 , 1 ) + e2 ( 2 , 1 , 1 , 1 )) * qxd + ( + e4 ( 1 , 3 , 1 , 1 ) + e2 ( 1 , 3 , 1 , 1 )) * qzd + ( + e3 ( 4 , 6 , 1 , 1 ) + e1 ( 4 , 1 , 1 )) * xx + e3 ( 3 , 3 , 1 , 1 ) * xzq + ( + e3 ( 2 , 1 , 1 , 1 ) + e1 ( 2 , 1 , 1 )) * zz + e2 ( 4 , 3 , 1 , 1 ) * xxzd + e2 ( 3 , 1 , 1 , 1 ) * xzzd + e1 ( 5 , 1 , 1 ) * xxzz f ( 4 , 1 , 1 , 1 ) = e5 ( 2 , 1 , 1 ) + e3 ( 1 , 2 , 1 , 1 ) * 3 + ( + e4 ( 1 , 2 , 1 , 1 ) + e4 ( 2 , 2 , 1 , 1 ) * 2 + e2 ( 1 , 2 , 1 , 1 ) + e2 ( 2 , 2 , 1 , 1 ) * 2 ) * qx + ( + e3 ( 3 , 2 , 1 , 1 ) * 2 + e3 ( 4 , 2 , 1 , 1 )) * xx + e2 ( 4 , 2 , 1 , 1 ) * xxx f ( 5 , 1 , 1 , 1 ) = e5 ( 3 , 1 , 1 ) + e3 ( 1 , 3 , 1 , 1 ) * 3 + ( + e4 ( 1 , 3 , 1 , 1 ) + e4 ( 2 , 3 , 1 , 1 ) * 2 + e2 ( 1 , 3 , 1 , 1 ) + e2 ( 2 , 3 , 1 , 1 ) * 2 ) * qx + ( + e4 ( 1 , 1 , 1 , 1 ) + e2 ( 1 , 1 , 1 , 1 ) * 3 ) * qz + ( + e3 ( 3 , 3 , 1 , 1 ) * 2 + e3 ( 4 , 3 , 1 , 1 )) * xx + ( + e3 ( 2 , 1 , 1 , 1 ) + e3 ( 3 , 1 , 1 , 1 ) * 2 + e1 ( 2 , 1 , 1 ) + e1 ( 3 , 1 , 1 ) * 2 ) * xz + e2 ( 4 , 3 , 1 , 1 ) * xxx + ( + e2 ( 3 , 1 , 1 , 1 ) * 2 + e2 ( 4 , 1 , 1 , 1 )) * xxz + e1 ( 5 , 1 , 1 ) * xxxz f ( 6 , 1 , 1 , 1 ) = e5 ( 5 , 1 , 1 ) + e3 ( 1 , 5 , 1 , 1 ) + e4 ( 2 , 5 , 1 , 1 ) * qxd + ( + e4 ( 1 , 2 , 1 , 1 ) + e2 ( 1 , 2 , 1 , 1 )) * qz + e3 ( 4 , 5 , 1 , 1 ) * xx + e3 ( 3 , 2 , 1 , 1 ) * xzd + e2 ( 4 , 2 , 1 , 1 ) * xxz f ( 1 , 2 , 1 , 1 ) = e5 ( 4 , 1 , 1 ) + e3 ( 1 , 4 , 1 , 1 ) + e3 ( 1 , 1 , 1 , 1 ) + e1 ( 1 , 1 , 1 ) + ( + e4 ( 1 , 4 , 1 , 1 ) + e2 ( 1 , 1 , 1 , 1 )) * qxd + ( + e3 ( 2 , 4 , 1 , 1 ) + e1 ( 2 , 1 , 1 )) * xx f ( 2 , 2 , 1 , 1 ) = e5 ( 11 , 1 , 1 ) + e3 ( 1 , 4 , 1 , 1 ) * 6 + e1 ( 1 , 1 , 1 ) * 3 f ( 3 , 2 , 1 , 1 ) = e5 ( 13 , 1 , 1 ) + e3 ( 1 , 6 , 1 , 1 ) + e3 ( 1 , 4 , 1 , 1 ) + e1 ( 1 , 1 , 1 ) + ( + e4 ( 1 , 8 , 1 , 1 ) + e2 ( 1 , 3 , 1 , 1 )) * qzd + ( + e3 ( 2 , 4 , 1 , 1 ) + e1 ( 2 , 1 , 1 )) * zz f ( 4 , 2 , 1 , 1 ) = e5 ( 7 , 1 , 1 ) + e3 ( 1 , 2 , 1 , 1 ) * 3 + ( + e4 ( 1 , 7 , 1 , 1 ) + e2 ( 1 , 2 , 1 , 1 ) * 3 ) * qx f ( 5 , 2 , 1 , 1 ) = e5 ( 8 , 1 , 1 ) + e3 ( 1 , 3 , 1 , 1 ) + ( + e4 ( 1 , 8 , 1 , 1 ) + e2 ( 1 , 3 , 1 , 1 )) * qx + ( + e4 ( 1 , 4 , 1 , 1 ) + e2 ( 1 , 1 , 1 , 1 )) * qz + ( + e3 ( 2 , 4 , 1 , 1 ) + e1 ( 2 , 1 , 1 )) * xz f ( 6 , 2 , 1 , 1 ) = e5 ( 12 , 1 , 1 ) + e3 ( 1 , 5 , 1 , 1 ) * 3 + ( + e4 ( 1 , 7 , 1 , 1 ) + e2 ( 1 , 2 , 1 , 1 ) * 3 ) * qz f ( 1 , 3 , 1 , 1 ) = e5 ( 6 , 1 , 1 ) + e3 ( 1 , 6 , 1 , 1 ) + e3 ( 1 , 1 , 1 , 1 ) + e1 ( 1 , 1 , 1 ) + ( + e4 ( 1 , 6 , 1 , 1 ) + e2 ( 1 , 1 , 1 , 1 )) * qxd + ( + e4 ( 2 , 3 , 1 , 1 ) + e2 ( 2 , 3 , 1 , 1 )) * qzd + ( + e3 ( 2 , 6 , 1 , 1 ) + e1 ( 2 , 1 , 1 )) * xx + e3 ( 3 , 3 , 1 , 1 ) * xzq + ( + e3 ( 4 , 1 , 1 , 1 ) + e1 ( 4 , 1 , 1 )) * zz + e2 ( 3 , 3 , 1 , 1 ) * xxzd + e2 ( 4 , 1 , 1 , 1 ) * xzzd + e1 ( 5 , 1 , 1 ) * xxzz f ( 2 , 3 , 1 , 1 ) = e5 ( 13 , 1 , 1 ) + e3 ( 1 , 6 , 1 , 1 ) + e3 ( 1 , 4 , 1 , 1 ) + e1 ( 1 , 1 , 1 ) + ( + e4 ( 2 , 8 , 1 , 1 ) + e2 ( 2 , 3 , 1 , 1 )) * qzd + ( + e3 ( 4 , 4 , 1 , 1 ) + e1 ( 4 , 1 , 1 )) * zz f ( 3 , 3 , 1 , 1 ) = e5 ( 15 , 1 , 1 ) + e3 ( 1 , 6 , 1 , 1 ) * 6 + e1 ( 1 , 1 , 1 ) * 3 + ( + e4 ( 1 , 10 , 1 , 1 ) + e4 ( 2 , 10 , 1 , 1 ) + ( + e2 ( 1 , 3 , 1 , 1 ) + e2 ( 2 , 3 , 1 , 1 )) * 3 ) * qzd + ( + e3 ( 2 , 6 , 1 , 1 ) + e3 ( 3 , 6 , 1 , 1 ) * 4 + e3 ( 4 , 6 , 1 , 1 ) + e1 ( 2 , 1 , 1 ) + e1 ( 3 , 1 , 1 ) * 4 + e1 ( 4 , 1 , 1 )) * zz + ( + e2 ( 3 , 3 , 1 , 1 ) + e2 ( 4 , 3 , 1 , 1 )) * zzzd + e1 ( 5 , 1 , 1 ) * zzzz f ( 4 , 3 , 1 , 1 ) = e5 ( 9 , 1 , 1 ) + e3 ( 1 , 2 , 1 , 1 ) + ( + e4 ( 1 , 9 , 1 , 1 ) + e2 ( 1 , 2 , 1 , 1 )) * qx + e4 ( 2 , 5 , 1 , 1 ) * qzd + e3 ( 3 , 5 , 1 , 1 ) * xzd + e3 ( 4 , 2 , 1 , 1 ) * zz + e2 ( 4 , 2 , 1 , 1 ) * xzz f ( 5 , 3 , 1 , 1 ) = e5 ( 10 , 1 , 1 ) + e3 ( 1 , 3 , 1 , 1 ) * 3 + ( + e4 ( 1 , 10 , 1 , 1 ) + e2 ( 1 , 3 , 1 , 1 ) * 3 ) * qx + ( + e4 ( 1 , 6 , 1 , 1 ) + e4 ( 2 , 6 , 1 , 1 ) * 2 + e2 ( 1 , 1 , 1 , 1 ) + e2 ( 2 , 1 , 1 , 1 ) * 2 ) * qz + ( + e3 ( 2 , 6 , 1 , 1 ) + e3 ( 3 , 6 , 1 , 1 ) * 2 + e1 ( 2 , 1 , 1 ) + e1 ( 3 , 1 , 1 ) * 2 ) * xz + ( + e3 ( 3 , 3 , 1 , 1 ) * 2 + e3 ( 4 , 3 , 1 , 1 )) * zz + ( + e2 ( 3 , 3 , 1 , 1 ) * 2 + e2 ( 4 , 3 , 1 , 1 )) * xzz + e2 ( 4 , 1 , 1 , 1 ) * zzz + e1 ( 5 , 1 , 1 ) * xzzz f ( 6 , 3 , 1 , 1 ) = e5 ( 14 , 1 , 1 ) + e3 ( 1 , 5 , 1 , 1 ) * 3 + ( + e4 ( 1 , 9 , 1 , 1 ) + e4 ( 2 , 9 , 1 , 1 ) * 2 + e2 ( 1 , 2 , 1 , 1 ) + e2 ( 2 , 2 , 1 , 1 ) * 2 ) * qz + ( + e3 ( 3 , 5 , 1 , 1 ) * 2 + e3 ( 4 , 5 , 1 , 1 )) * zz + e2 ( 4 , 2 , 1 , 1 ) * zzz f ( 1 , 4 , 1 , 1 ) = e5 ( 2 , 1 , 1 ) + e3 ( 1 , 2 , 1 , 1 ) * 3 + ( + e4 ( 1 , 2 , 1 , 1 ) * 2 + e4 ( 2 , 2 , 1 , 1 ) + e2 ( 1 , 2 , 1 , 1 ) * 2 + e2 ( 2 , 2 , 1 , 1 )) * qx + ( + e3 ( 2 , 2 , 1 , 1 ) + e3 ( 3 , 2 , 1 , 1 ) * 2 ) * xx + e2 ( 3 , 2 , 1 , 1 ) * xxx f ( 2 , 4 , 1 , 1 ) = e5 ( 7 , 1 , 1 ) + e3 ( 1 , 2 , 1 , 1 ) * 3 + ( + e4 ( 2 , 7 , 1 , 1 ) + e2 ( 2 , 2 , 1 , 1 ) * 3 ) * qx f ( 3 , 4 , 1 , 1 ) = e5 ( 9 , 1 , 1 ) + e3 ( 1 , 2 , 1 , 1 ) + ( + e4 ( 2 , 9 , 1 , 1 ) + e2 ( 2 , 2 , 1 , 1 )) * qx + e4 ( 1 , 5 , 1 , 1 ) * qzd + e3 ( 3 , 5 , 1 , 1 ) * xzd + e3 ( 2 , 2 , 1 , 1 ) * zz + e2 ( 3 , 2 , 1 , 1 ) * xzz f ( 4 , 4 , 1 , 1 ) = e5 ( 4 , 1 , 1 ) + e3 ( 1 , 4 , 1 , 1 ) + e3 ( 1 , 1 , 1 , 1 ) + e1 ( 1 , 1 , 1 ) + ( + e4 ( 1 , 4 , 1 , 1 ) + e4 ( 2 , 4 , 1 , 1 ) + e2 ( 1 , 1 , 1 , 1 ) + e2 ( 2 , 1 , 1 , 1 )) * qx + ( + e3 ( 3 , 4 , 1 , 1 ) + e1 ( 3 , 1 , 1 )) * xx f ( 5 , 4 , 1 , 1 ) = e5 ( 5 , 1 , 1 ) + e3 ( 1 , 5 , 1 , 1 ) + ( + e4 ( 1 , 5 , 1 , 1 ) + e4 ( 2 , 5 , 1 , 1 )) * qx + ( + e4 ( 1 , 2 , 1 , 1 ) + e2 ( 1 , 2 , 1 , 1 )) * qz + e3 ( 3 , 5 , 1 , 1 ) * xx + ( + e3 ( 2 , 2 , 1 , 1 ) + e3 ( 3 , 2 , 1 , 1 )) * xz + e2 ( 3 , 2 , 1 , 1 ) * xxz f ( 6 , 4 , 1 , 1 ) = e5 ( 8 , 1 , 1 ) + e3 ( 1 , 3 , 1 , 1 ) + ( + e4 ( 2 , 8 , 1 , 1 ) + e2 ( 2 , 3 , 1 , 1 )) * qx + ( + e4 ( 1 , 4 , 1 , 1 ) + e2 ( 1 , 1 , 1 , 1 )) * qz + ( + e3 ( 3 , 4 , 1 , 1 ) + e1 ( 3 , 1 , 1 )) * xz f ( 1 , 5 , 1 , 1 ) = e5 ( 3 , 1 , 1 ) + e3 ( 1 , 3 , 1 , 1 ) * 3 + ( + e4 ( 1 , 3 , 1 , 1 ) * 2 + e4 ( 2 , 3 , 1 , 1 ) + e2 ( 1 , 3 , 1 , 1 ) * 2 + e2 ( 2 , 3 , 1 , 1 )) * qx + ( + e4 ( 2 , 1 , 1 , 1 ) + e2 ( 2 , 1 , 1 , 1 ) * 3 ) * qz + ( + e3 ( 2 , 3 , 1 , 1 ) + e3 ( 3 , 3 , 1 , 1 ) * 2 ) * xx + ( + e3 ( 3 , 1 , 1 , 1 ) * 2 + e3 ( 4 , 1 , 1 , 1 ) + e1 ( 3 , 1 , 1 ) * 2 + e1 ( 4 , 1 , 1 )) * xz + e2 ( 3 , 3 , 1 , 1 ) * xxx + ( + e2 ( 3 , 1 , 1 , 1 ) + e2 ( 4 , 1 , 1 , 1 ) * 2 ) * xxz + e1 ( 5 , 1 , 1 ) * xxxz f ( 2 , 5 , 1 , 1 ) = e5 ( 8 , 1 , 1 ) + e3 ( 1 , 3 , 1 , 1 ) + ( + e4 ( 2 , 8 , 1 , 1 ) + e2 ( 2 , 3 , 1 , 1 )) * qx + ( + e4 ( 2 , 4 , 1 , 1 ) + e2 ( 2 , 1 , 1 , 1 )) * qz + ( + e3 ( 4 , 4 , 1 , 1 ) + e1 ( 4 , 1 , 1 )) * xz f ( 3 , 5 , 1 , 1 ) = e5 ( 10 , 1 , 1 ) + e3 ( 1 , 3 , 1 , 1 ) * 3 + ( + e4 ( 2 , 10 , 1 , 1 ) + e2 ( 2 , 3 , 1 , 1 ) * 3 ) * qx + ( + e4 ( 1 , 6 , 1 , 1 ) * 2 + e4 ( 2 , 6 , 1 , 1 ) + e2 ( 1 , 1 , 1 , 1 ) * 2 + e2 ( 2 , 1 , 1 , 1 )) * qz + ( + e3 ( 3 , 6 , 1 , 1 ) * 2 + e3 ( 4 , 6 , 1 , 1 ) + e1 ( 3 , 1 , 1 ) * 2 + e1 ( 4 , 1 , 1 )) * xz + ( + e3 ( 2 , 3 , 1 , 1 ) + e3 ( 3 , 3 , 1 , 1 ) * 2 ) * zz + ( + e2 ( 3 , 3 , 1 , 1 ) + e2 ( 4 , 3 , 1 , 1 ) * 2 ) * xzz + e2 ( 3 , 1 , 1 , 1 ) * zzz + e1 ( 5 , 1 , 1 ) * xzzz f ( 4 , 5 , 1 , 1 ) = e5 ( 5 , 1 , 1 ) + e3 ( 1 , 5 , 1 , 1 ) + ( + e4 ( 1 , 5 , 1 , 1 ) + e4 ( 2 , 5 , 1 , 1 )) * qx + ( + e4 ( 2 , 2 , 1 , 1 ) + e2 ( 2 , 2 , 1 , 1 )) * qz + e3 ( 3 , 5 , 1 , 1 ) * xx + ( + e3 ( 3 , 2 , 1 , 1 ) + e3 ( 4 , 2 , 1 , 1 )) * xz + e2 ( 4 , 2 , 1 , 1 ) * xxz f ( 5 , 5 , 1 , 1 ) = e5 ( 6 , 1 , 1 ) + e3 ( 1 , 6 , 1 , 1 ) + e3 ( 1 , 1 , 1 , 1 ) + e1 ( 1 , 1 , 1 ) + ( + e4 ( 1 , 6 , 1 , 1 ) + e4 ( 2 , 6 , 1 , 1 ) + e2 ( 1 , 1 , 1 , 1 ) + e2 ( 2 , 1 , 1 , 1 )) * qx + ( + e4 ( 1 , 3 , 1 , 1 ) + e4 ( 2 , 3 , 1 , 1 ) + e2 ( 1 , 3 , 1 , 1 ) + e2 ( 2 , 3 , 1 , 1 )) * qz + ( + e3 ( 3 , 6 , 1 , 1 ) + e1 ( 3 , 1 , 1 )) * xx + ( + e3 ( 2 , 3 , 1 , 1 ) + e3 ( 3 , 3 , 1 , 1 ) * 2 + e3 ( 4 , 3 , 1 , 1 )) * xz + ( + e3 ( 3 , 1 , 1 , 1 ) + e1 ( 3 , 1 , 1 )) * zz + ( + e2 ( 3 , 3 , 1 , 1 ) + e2 ( 4 , 3 , 1 , 1 )) * xxz + ( + e2 ( 3 , 1 , 1 , 1 ) + e2 ( 4 , 1 , 1 , 1 )) * xzz + e1 ( 5 , 1 , 1 ) * xxzz f ( 6 , 5 , 1 , 1 ) = e5 ( 9 , 1 , 1 ) + e3 ( 1 , 2 , 1 , 1 ) + ( + e4 ( 2 , 9 , 1 , 1 ) + e2 ( 2 , 2 , 1 , 1 )) * qx + ( + e4 ( 1 , 5 , 1 , 1 ) + e4 ( 2 , 5 , 1 , 1 )) * qz + ( + e3 ( 3 , 5 , 1 , 1 ) + e3 ( 4 , 5 , 1 , 1 )) * xz + e3 ( 3 , 2 , 1 , 1 ) * zz + e2 ( 4 , 2 , 1 , 1 ) * xzz f ( 1 , 6 , 1 , 1 ) = e5 ( 5 , 1 , 1 ) + e3 ( 1 , 5 , 1 , 1 ) + e4 ( 1 , 5 , 1 , 1 ) * qxd + ( + e4 ( 2 , 2 , 1 , 1 ) + e2 ( 2 , 2 , 1 , 1 )) * qz + e3 ( 2 , 5 , 1 , 1 ) * xx + e3 ( 3 , 2 , 1 , 1 ) * xzd + e2 ( 3 , 2 , 1 , 1 ) * xxz f ( 2 , 6 , 1 , 1 ) = e5 ( 12 , 1 , 1 ) + e3 ( 1 , 5 , 1 , 1 ) * 3 + ( + e4 ( 2 , 7 , 1 , 1 ) + e2 ( 2 , 2 , 1 , 1 ) * 3 ) * qz f ( 3 , 6 , 1 , 1 ) = e5 ( 14 , 1 , 1 ) + e3 ( 1 , 5 , 1 , 1 ) * 3 + ( + e4 ( 1 , 9 , 1 , 1 ) * 2 + e4 ( 2 , 9 , 1 , 1 ) + e2 ( 1 , 2 , 1 , 1 ) * 2 + e2 ( 2 , 2 , 1 , 1 )) * qz + ( + e3 ( 2 , 5 , 1 , 1 ) + e3 ( 3 , 5 , 1 , 1 ) * 2 ) * zz + e2 ( 3 , 2 , 1 , 1 ) * zzz f ( 4 , 6 , 1 , 1 ) = e5 ( 8 , 1 , 1 ) + e3 ( 1 , 3 , 1 , 1 ) + ( + e4 ( 1 , 8 , 1 , 1 ) + e2 ( 1 , 3 , 1 , 1 )) * qx + ( + e4 ( 2 , 4 , 1 , 1 ) + e2 ( 2 , 1 , 1 , 1 )) * qz + ( + e3 ( 3 , 4 , 1 , 1 ) + e1 ( 3 , 1 , 1 )) * xz f ( 5 , 6 , 1 , 1 ) = e5 ( 9 , 1 , 1 ) + e3 ( 1 , 2 , 1 , 1 ) + ( + e4 ( 1 , 9 , 1 , 1 ) + e2 ( 1 , 2 , 1 , 1 )) * qx + ( + e4 ( 1 , 5 , 1 , 1 ) + e4 ( 2 , 5 , 1 , 1 )) * qz + ( + e3 ( 2 , 5 , 1 , 1 ) + e3 ( 3 , 5 , 1 , 1 )) * xz + e3 ( 3 , 2 , 1 , 1 ) * zz + e2 ( 3 , 2 , 1 , 1 ) * xzz f ( 6 , 6 , 1 , 1 ) = e5 ( 13 , 1 , 1 ) + e3 ( 1 , 6 , 1 , 1 ) + e3 ( 1 , 4 , 1 , 1 ) + e1 ( 1 , 1 , 1 ) + ( + e4 ( 1 , 8 , 1 , 1 ) + e4 ( 2 , 8 , 1 , 1 ) + e2 ( 1 , 3 , 1 , 1 ) + e2 ( 2 , 3 , 1 , 1 )) * qz + ( + e3 ( 3 , 4 , 1 , 1 ) + e1 ( 3 , 1 , 1 )) * zz end subroutine mcdv_10 ! > ! >    @brief   dpps case ! > ! >    @details integration of a dpps case ! > subroutine mcdv_11 ( f , rdat , qx , qz ) implicit none type ( rotaxis_data_t ) :: rdat real ( kind = dp ) :: f ( 6 , 3 , 3 , * ) real ( kind = dp ) :: qx , qz integer , parameter :: kx = 4 , lx = 1 real ( kind = dp ) :: d1 ( 5 , kx , lx ), d2 ( 4 , 3 , kx , lx ), d3 ( 3 , 6 , kx , lx ), & d4 ( 10 , kx , lx ) integer , parameter :: ind ( 10 , kx , lx ) = reshape (& [ 1 , 2 , 3 , 4 , 5 , 6 , 7 , 8 , 9 , 10 , 1 , 2 , 3 , 4 , 5 , 6 , 7 , 8 , 9 , 10 , 2 , & 4 , 5 , 7 , 8 , 9 , 11 , 12 , 13 , 14 , 3 , 5 , 6 , 8 , 9 , 10 , 12 , 13 , 14 , 15 ] & , shape ( ind )) real ( kind = dp ) :: xx , zz , xz , xxx , xxz , xzz , zzz real ( kind = dp ) :: qxd , qzd , xzd integer :: i , j , k , l , m do j = 1 , 10 d4 ( j , 1 , 1 ) =+ rdat % r03 ( j , 1 ) enddo do j = 1 , 6 m = in6 ( j ) d3 ( 1 , j , 1 , 1 ) =+ rdat % r02 ( m , 1 ) d3 ( 2 , j , 1 , 1 ) =+ rdat % r02 ( m , 2 ) d3 ( 3 , j , 1 , 1 ) =+ rdat % r02 ( m , 3 ) enddo do j = 1 , 3 d2 ( 1 , j , 1 , 1 ) =+ rdat % r01 ( j , 1 ) d2 ( 2 , j , 1 , 1 ) =+ rdat % r01 ( j , 2 ) d2 ( 3 , j , 1 , 1 ) =+ rdat % r01 ( j , 3 ) d2 ( 4 , j , 1 , 1 ) =+ rdat % r01 ( j , 4 ) enddo do i = 1 , 5 d1 ( i , 1 , 1 ) =+ rdat % r00 ( i , 1 ) enddo do j = 1 , 10 d4 ( j , 2 , 1 ) =- rdat % r04 ( j , 1 ) enddo do j = 1 , 6 d3 ( 1 , j , 2 , 1 ) =- rdat % r03 ( j , 3 ) d3 ( 2 , j , 2 , 1 ) =- rdat % r03 ( j , 4 ) d3 ( 3 , j , 2 , 1 ) =- rdat % r03 ( j , 5 ) enddo do j = 1 , 3 m = in6 ( j ) d2 ( 1 , j , 2 , 1 ) =- rdat % r02 ( m , 7 ) d2 ( 2 , j , 2 , 1 ) =- rdat % r02 ( m , 8 ) d2 ( 3 , j , 2 , 1 ) =- rdat % r02 ( m , 9 ) d2 ( 4 , j , 2 , 1 ) =- rdat % r02 ( m , 10 ) enddo j = 1 do i = 1 , 5 d1 ( i , 2 , 1 ) =- rdat % r01 ( j , i + 8 ) enddo do j = 1 , 10 k = ind ( j , 3 , 1 ) d4 ( j , 3 , 1 ) =- rdat % r04 ( k , 1 ) enddo do j = 1 , 6 k = ind ( j , 3 , 1 ) d3 ( 1 , j , 3 , 1 ) =- rdat % r03 ( k , 3 ) d3 ( 2 , j , 3 , 1 ) =- rdat % r03 ( k , 4 ) d3 ( 3 , j , 3 , 1 ) =- rdat % r03 ( k , 5 ) enddo do j = 1 , 3 k = ind ( j , 3 , 1 ) m = in6 ( k ) d2 ( 1 , j , 3 , 1 ) =- rdat % r02 ( m , 7 ) d2 ( 2 , j , 3 , 1 ) =- rdat % r02 ( m , 8 ) d2 ( 3 , j , 3 , 1 ) =- rdat % r02 ( m , 9 ) d2 ( 4 , j , 3 , 1 ) =- rdat % r02 ( m , 10 ) enddo j = 1 k = ind ( j , 3 , 1 ) do i = 1 , 5 d1 ( i , 3 , 1 ) =- rdat % r01 ( k , i + 8 ) enddo do j = 1 , 10 k = ind ( j , 4 , 1 ) d4 ( j , 4 , 1 ) =- rdat % r04 ( k , 1 ) + rdat % r03 ( j , 2 ) enddo do j = 1 , 6 k = ind ( j , 4 , 1 ) m = in6 ( j ) d3 ( 1 , j , 4 , 1 ) =- rdat % r03 ( k , 3 ) + rdat % r02 ( m , 4 ) d3 ( 2 , j , 4 , 1 ) =- rdat % r03 ( k , 4 ) + rdat % r02 ( m , 5 ) d3 ( 3 , j , 4 , 1 ) =- rdat % r03 ( k , 5 ) + rdat % r02 ( m , 6 ) enddo do j = 1 , 3 k = ind ( j , 4 , 1 ) m = in6 ( k ) d2 ( 1 , j , 4 , 1 ) =- rdat % r02 ( m , 7 ) + rdat % r01 ( j , 5 ) d2 ( 2 , j , 4 , 1 ) =- rdat % r02 ( m , 8 ) + rdat % r01 ( j , 6 ) d2 ( 3 , j , 4 , 1 ) =- rdat % r02 ( m , 9 ) + rdat % r01 ( j , 7 ) d2 ( 4 , j , 4 , 1 ) =- rdat % r02 ( m , 10 ) + rdat % r01 ( j , 8 ) enddo j = 1 k = ind ( j , 4 , 1 ) do i = 1 , 5 d1 ( i , 4 , 1 ) =- rdat % r01 ( k , i + 8 ) + rdat % r00 ( i , 2 ) enddo xx = qx * qx zz = qz * qz xz = qx * qz xxx = xx * qx xxz = xx * qz xzz = zz * qx zzz = zz * qz qxd = qx + qx qzd = qz + qz xzd = xz + xz l = 1 do k = 2 , kx f ( 1 , 1 , k - 1 , l ) = d4 ( 1 , k , l ) + d2 ( 2 , 1 , k , l ) * 3 + ( + d3 ( 2 , 1 , k , l ) * 2 + d3 ( 3 , 1 , k , l ) + d1 ( 3 , k , l ) * 2 + d1 ( 4 , k , l )) * qx + ( + d2 ( 3 , 1 , k , l ) + d2 ( 4 , 1 , k , l ) * 2 ) * xx + d1 ( 5 , k , l ) * xxx f ( 2 , 1 , k - 1 , l ) = d4 ( 4 , k , l ) + d2 ( 2 , 1 , k , l ) + ( + d3 ( 3 , 4 , k , l ) + d1 ( 4 , k , l )) * qx f ( 3 , 1 , k - 1 , l ) = d4 ( 6 , k , l ) + d2 ( 2 , 1 , k , l ) + ( + d3 ( 3 , 6 , k , l ) + d1 ( 4 , k , l )) * qx + d3 ( 2 , 3 , k , l ) * qzd + d2 ( 4 , 3 , k , l ) * xzd + d2 ( 3 , 1 , k , l ) * zz + d1 ( 5 , k , l ) * xzz f ( 4 , 1 , k - 1 , l ) = d4 ( 2 , k , l ) + d2 ( 2 , 2 , k , l ) + ( + d3 ( 2 , 2 , k , l ) + d3 ( 3 , 2 , k , l )) * qx + d2 ( 4 , 2 , k , l ) * xx f ( 5 , 1 , k - 1 , l ) = d4 ( 3 , k , l ) + d2 ( 2 , 3 , k , l ) + ( + d3 ( 2 , 3 , k , l ) + d3 ( 3 , 3 , k , l )) * qx + ( + d3 ( 2 , 1 , k , l ) + d1 ( 3 , k , l )) * qz + d2 ( 4 , 3 , k , l ) * xx + ( + d2 ( 3 , 1 , k , l ) + d2 ( 4 , 1 , k , l )) * xz + d1 ( 5 , k , l ) * xxz f ( 6 , 1 , k - 1 , l ) = d4 ( 5 , k , l ) + d3 ( 3 , 5 , k , l ) * qx + d3 ( 2 , 2 , k , l ) * qz + d2 ( 4 , 2 , k , l ) * xz f ( 1 , 2 , k - 1 , l ) = d4 ( 2 , k , l ) + d2 ( 2 , 2 , k , l ) + d3 ( 2 , 2 , k , l ) * qxd + d2 ( 3 , 2 , k , l ) * xx f ( 2 , 2 , k - 1 , l ) = d4 ( 7 , k , l ) + d2 ( 2 , 2 , k , l ) * 3 f ( 3 , 2 , k - 1 , l ) = d4 ( 9 , k , l ) + d2 ( 2 , 2 , k , l ) + d3 ( 2 , 5 , k , l ) * qzd + d2 ( 3 , 2 , k , l ) * zz f ( 4 , 2 , k - 1 , l ) = d4 ( 4 , k , l ) + d2 ( 2 , 1 , k , l ) + ( + d3 ( 2 , 4 , k , l ) + d1 ( 3 , k , l )) * qx f ( 5 , 2 , k - 1 , l ) = d4 ( 5 , k , l ) + d3 ( 2 , 5 , k , l ) * qx + d3 ( 2 , 2 , k , l ) * qz + d2 ( 3 , 2 , k , l ) * xz f ( 6 , 2 , k - 1 , l ) = d4 ( 8 , k , l ) + d2 ( 2 , 3 , k , l ) + ( + d3 ( 2 , 4 , k , l ) + d1 ( 3 , k , l )) * qz f ( 1 , 3 , k - 1 , l ) = d4 ( 3 , k , l ) + d2 ( 2 , 3 , k , l ) + d3 ( 2 , 3 , k , l ) * qxd + ( + d3 ( 3 , 1 , k , l ) + d1 ( 4 , k , l )) * qz + d2 ( 3 , 3 , k , l ) * xx + d2 ( 4 , 1 , k , l ) * xzd + d1 ( 5 , k , l ) * xxz f ( 2 , 3 , k - 1 , l ) = d4 ( 8 , k , l ) + d2 ( 2 , 3 , k , l ) + ( + d3 ( 3 , 4 , k , l ) + d1 ( 4 , k , l )) * qz f ( 3 , 3 , k - 1 , l ) = d4 ( 10 , k , l ) + d2 ( 2 , 3 , k , l ) * 3 + ( + d3 ( 2 , 6 , k , l ) * 2 + d3 ( 3 , 6 , k , l ) + d1 ( 3 , k , l ) * 2 + d1 ( 4 , k , l )) * qz + ( + d2 ( 3 , 3 , k , l ) + d2 ( 4 , 3 , k , l ) * 2 ) * zz + d1 ( 5 , k , l ) * zzz f ( 4 , 3 , k - 1 , l ) = d4 ( 5 , k , l ) + d3 ( 2 , 5 , k , l ) * qx + d3 ( 3 , 2 , k , l ) * qz + d2 ( 4 , 2 , k , l ) * xz f ( 5 , 3 , k - 1 , l ) = d4 ( 6 , k , l ) + d2 ( 2 , 1 , k , l ) + ( + d3 ( 2 , 6 , k , l ) + d1 ( 3 , k , l )) * qx + ( + d3 ( 2 , 3 , k , l ) + d3 ( 3 , 3 , k , l )) * qz + ( + d2 ( 3 , 3 , k , l ) + d2 ( 4 , 3 , k , l )) * xz + d2 ( 4 , 1 , k , l ) * zz + d1 ( 5 , k , l ) * xzz f ( 6 , 3 , k - 1 , l ) = d4 ( 9 , k , l ) + d2 ( 2 , 2 , k , l ) + ( + d3 ( 2 , 5 , k , l ) + d3 ( 3 , 5 , k , l )) * qz + d2 ( 4 , 2 , k , l ) * zz enddo end subroutine mcdv_11 ! > ! >    @brief   dsds case ! > ! >    @details integration of a dsds case ! > subroutine mcdv_12 ( f , rdat , qx , qz ) implicit none type ( rotaxis_data_t ) :: rdat real ( kind = dp ) :: f ( 6 , 1 , 6 , * ) real ( kind = dp ) :: qx , qz integer , parameter :: kx = 6 , lx = 1 real ( kind = dp ) :: c1 ( 2 , kx , lx ), c2 ( 3 , kx , lx ), c3 ( 6 , kx , lx ) integer , parameter :: ind ( 6 , kx , lx ) = reshape (& [ 1 , 2 , 3 , 4 , 5 , 6 , 4 , 7 , 8 , 11 , 12 , 13 , 6 , 9 , 10 , 13 , 14 , 15 , 2 , & 4 , 5 , 7 , 8 , 9 , 3 , 5 , 6 , 8 , 9 , 10 , 5 , 8 , 9 , 12 , 13 , 14 ] & , shape ( ind )) integer :: j , k , l , m do j = 1 , 6 m = in6 ( j ) c3 ( j , 1 , 1 ) =+ rdat % r04 ( j , 1 ) + rdat % r02 ( m , 1 ) enddo c2 ( 1 , 1 , 1 ) =+ rdat % r03 ( 1 , 2 ) + rdat % r01 ( 1 , 1 ) c2 ( 2 , 1 , 1 ) =+ rdat % r03 ( 2 , 2 ) + rdat % r01 ( 2 , 1 ) c2 ( 3 , 1 , 1 ) =+ rdat % r03 ( 3 , 2 ) + rdat % r01 ( 3 , 1 ) c1 ( 1 , 1 , 1 ) =+ rdat % r02 ( 1 , 4 ) + rdat % r00 ( 1 , 1 ) c1 ( 2 , 1 , 1 ) =+ rdat % r02 ( 1 , 5 ) + rdat % r00 ( 2 , 1 ) do j = 1 , 6 k = ind ( j , 2 , 1 ) m = in6 ( j ) c3 ( j , 2 , 1 ) =+ rdat % r04 ( k , 1 ) + rdat % r02 ( m , 1 ) enddo c2 ( 1 , 2 , 1 ) =+ rdat % r03 ( 4 , 2 ) + rdat % r01 ( 1 , 1 ) c2 ( 2 , 2 , 1 ) =+ rdat % r03 ( 7 , 2 ) + rdat % r01 ( 2 , 1 ) c2 ( 3 , 2 , 1 ) =+ rdat % r03 ( 8 , 2 ) + rdat % r01 ( 3 , 1 ) c1 ( 1 , 2 , 1 ) =+ rdat % r02 ( 2 , 4 ) + rdat % r00 ( 1 , 1 ) c1 ( 2 , 2 , 1 ) =+ rdat % r02 ( 2 , 5 ) + rdat % r00 ( 2 , 1 ) c3 ( 1 , 3 , 1 ) =+ rdat % r04 ( 6 , 1 ) - rdat % r03 ( 3 , 1 ) * 2 + rdat % r02 ( 1 , 1 ) + rdat % r02 ( 1 , 2 ) c3 ( 2 , 3 , 1 ) =+ rdat % r04 ( 9 , 1 ) - rdat % r03 ( 5 , 1 ) * 2 + rdat % r02 ( 4 , 1 ) + rdat % r02 ( 4 , 2 ) c3 ( 3 , 3 , 1 ) =+ rdat % r04 ( 10 , 1 ) - rdat % r03 ( 6 , 1 ) * 2 + rdat % r02 ( 5 , 1 ) + rdat % r02 ( 5 , 2 ) c3 ( 4 , 3 , 1 ) =+ rdat % r04 ( 13 , 1 ) - rdat % r03 ( 8 , 1 ) * 2 + rdat % r02 ( 2 , 1 ) + rdat % r02 ( 2 , 2 ) c3 ( 5 , 3 , 1 ) =+ rdat % r04 ( 14 , 1 ) - rdat % r03 ( 9 , 1 ) * 2 + rdat % r02 ( 6 , 1 ) + rdat % r02 ( 6 , 2 ) c3 ( 6 , 3 , 1 ) =+ rdat % r04 ( 15 , 1 ) - rdat % r03 ( 10 , 1 ) * 2 + rdat % r02 ( 3 , 1 ) + rdat % r02 ( 3 , 2 ) c2 ( 1 , 3 , 1 ) =+ rdat % r03 ( 6 , 2 ) - rdat % r02 ( 5 , 3 ) * 2 + rdat % r01 ( 1 , 1 ) + rdat % r01 ( 1 , 2 ) c2 ( 2 , 3 , 1 ) =+ rdat % r03 ( 9 , 2 ) - rdat % r02 ( 6 , 3 ) * 2 + rdat % r01 ( 2 , 1 ) + rdat % r01 ( 2 , 2 ) c2 ( 3 , 3 , 1 ) =+ rdat % r03 ( 10 , 2 ) - rdat % r02 ( 3 , 3 ) * 2 + rdat % r01 ( 3 , 1 ) + rdat % r01 ( 3 , 2 ) c1 ( 1 , 3 , 1 ) =+ rdat % r02 ( 3 , 4 ) - rdat % r01 ( 3 , 3 ) * 2 + rdat % r00 ( 1 , 1 ) + rdat % r00 ( 3 , 1 ) c1 ( 2 , 3 , 1 ) =+ rdat % r02 ( 3 , 5 ) - rdat % r01 ( 3 , 4 ) * 2 + rdat % r00 ( 2 , 1 ) + rdat % r00 ( 4 , 1 ) do j = 1 , 6 k = ind ( j , 4 , 1 ) c3 ( j , 4 , 1 ) =+ rdat % r04 ( k , 1 ) enddo c2 ( 1 , 4 , 1 ) =+ rdat % r03 ( 2 , 2 ) c2 ( 2 , 4 , 1 ) =+ rdat % r03 ( 4 , 2 ) c2 ( 3 , 4 , 1 ) =+ rdat % r03 ( 5 , 2 ) c1 ( 1 , 4 , 1 ) =+ rdat % r02 ( 4 , 4 ) c1 ( 2 , 4 , 1 ) =+ rdat % r02 ( 4 , 5 ) do j = 1 , 6 k = ind ( j , 5 , 1 ) c3 ( j , 5 , 1 ) =+ rdat % r04 ( k , 1 ) - rdat % r03 ( j , 1 ) enddo c2 ( 1 , 5 , 1 ) =+ rdat % r03 ( 3 , 2 ) - rdat % r02 ( 1 , 3 ) c2 ( 2 , 5 , 1 ) =+ rdat % r03 ( 5 , 2 ) - rdat % r02 ( 4 , 3 ) c2 ( 3 , 5 , 1 ) =+ rdat % r03 ( 6 , 2 ) - rdat % r02 ( 5 , 3 ) c1 ( 1 , 5 , 1 ) =+ rdat % r02 ( 5 , 4 ) - rdat % r01 ( 1 , 3 ) c1 ( 2 , 5 , 1 ) =+ rdat % r02 ( 5 , 5 ) - rdat % r01 ( 1 , 4 ) c3 ( 1 , 6 , 1 ) =+ rdat % r04 ( 5 , 1 ) - rdat % r03 ( 2 , 1 ) c3 ( 2 , 6 , 1 ) =+ rdat % r04 ( 8 , 1 ) - rdat % r03 ( 4 , 1 ) c3 ( 3 , 6 , 1 ) =+ rdat % r04 ( 9 , 1 ) - rdat % r03 ( 5 , 1 ) c3 ( 4 , 6 , 1 ) =+ rdat % r04 ( 12 , 1 ) - rdat % r03 ( 7 , 1 ) c3 ( 5 , 6 , 1 ) =+ rdat % r04 ( 13 , 1 ) - rdat % r03 ( 8 , 1 ) c3 ( 6 , 6 , 1 ) =+ rdat % r04 ( 14 , 1 ) - rdat % r03 ( 9 , 1 ) c2 ( 1 , 6 , 1 ) =+ rdat % r03 ( 5 , 2 ) - rdat % r02 ( 4 , 3 ) c2 ( 2 , 6 , 1 ) =+ rdat % r03 ( 8 , 2 ) - rdat % r02 ( 2 , 3 ) c2 ( 3 , 6 , 1 ) =+ rdat % r03 ( 9 , 2 ) - rdat % r02 ( 6 , 3 ) c1 ( 1 , 6 , 1 ) =+ rdat % r02 ( 6 , 4 ) - rdat % r01 ( 2 , 3 ) c1 ( 2 , 6 , 1 ) =+ rdat % r02 ( 6 , 5 ) - rdat % r01 ( 2 , 4 ) do l = 1 , lx do k = 1 , kx f ( 1 , 1 , k , l ) =+ c3 ( 1 , k , l ) + c1 ( 1 , k , l ) & & + ( + c2 ( 1 , k , l ) + c2 ( 1 , k , l ) + c1 ( 2 , k , l ) * qx ) * qx f ( 2 , 1 , k , l ) =+ c3 ( 4 , k , l ) + c1 ( 1 , k , l ) f ( 3 , 1 , k , l ) =+ c3 ( 6 , k , l ) + c1 ( 1 , k , l ) & & + ( + c2 ( 3 , k , l ) + c2 ( 3 , k , l ) + c1 ( 2 , k , l ) * qz ) * qz f ( 4 , 1 , k , l ) =+ c3 ( 2 , k , l ) + c2 ( 2 , k , l ) * qx f ( 5 , 1 , k , l ) =+ c3 ( 3 , k , l ) + c2 ( 3 , k , l ) * qx & & + ( + c2 ( 1 , k , l ) + c1 ( 2 , k , l ) * qx ) * qz f ( 6 , 1 , k , l ) =+ c3 ( 5 , k , l ) + c2 ( 2 , k , l ) * qz enddo enddo end subroutine mcdv_12 ! > ! >    @brief   dspp case ! > ! >    @details integration of a dspp case ! > subroutine mcdv_13 ( f , rdat , qx , qz ) implicit none type ( rotaxis_data_t ) :: rdat real ( kind = dp ) :: f ( 6 , 1 , 3 , * ) real ( kind = dp ) :: qx , qz logical :: lsym13 integer , parameter :: kx = 4 , lx = 4 real ( kind = dp ) :: c1 ( 2 , kx , lx ), c2 ( 3 , kx , lx ), c3 ( 6 , kx , lx ) integer , parameter :: ind ( 6 , kx , lx ) = reshape (& [ 1 , 2 , 3 , 4 , 5 , 6 , 1 , 2 , 3 , 4 , 5 , 6 , 2 , 4 , 5 , 7 , 8 , 9 , 3 , 5 , 6 , 8 , & 9 , 10 , 1 , 2 , 3 , 4 , 5 , 6 , 1 , 2 , 3 , 4 , 5 , 6 , 2 , 4 , 5 , 7 , 8 , 9 , 3 , 5 , & 6 , 8 , 9 , 10 , 2 , 4 , 5 , 7 , 8 , 9 , 2 , 4 , 5 , 7 , 8 , 9 , 4 , 7 , 8 , 11 , 12 , & 13 , 5 , 8 , 9 , 12 , 13 , 14 , 3 , 5 , 6 , 8 , 9 , 10 , 3 , 5 , 6 , 8 , 9 , 10 , 5 , & 8 , 9 , 12 , 13 , 14 , 6 , 9 , 10 , 13 , 14 , 15 ] & , shape ( ind )) integer :: i , j , k , l , m do j = 1 , 6 m = in6 ( j ) c3 ( j , 1 , 1 ) =+ rdat % r02 ( m , 1 ) enddo c2 ( 1 , 1 , 1 ) =+ rdat % r01 ( 1 , 1 ) c2 ( 2 , 1 , 1 ) =+ rdat % r01 ( 2 , 1 ) c2 ( 3 , 1 , 1 ) =+ rdat % r01 ( 3 , 1 ) c1 ( 1 , 1 , 1 ) =+ rdat % r00 ( 1 , 1 ) c1 ( 2 , 1 , 1 ) =+ rdat % r00 ( 1 , 2 ) do j = 1 , 6 c3 ( j , 2 , 1 ) =- rdat % r03 ( j , 2 ) enddo c2 ( 1 , 2 , 1 ) =- rdat % r02 ( 1 , 6 ) c2 ( 2 , 2 , 1 ) =- rdat % r02 ( 4 , 6 ) c2 ( 3 , 2 , 1 ) =- rdat % r02 ( 5 , 6 ) c1 ( 1 , 2 , 1 ) =- rdat % r01 ( 1 , 6 ) c1 ( 2 , 2 , 1 ) =- rdat % r01 ( 1 , 7 ) do j = 1 , 6 k = ind ( j , 3 , 1 ) c3 ( j , 3 , 1 ) =- rdat % r03 ( k , 2 ) enddo c2 ( 1 , 3 , 1 ) =- rdat % r02 ( 4 , 6 ) c2 ( 2 , 3 , 1 ) =- rdat % r02 ( 2 , 6 ) c2 ( 3 , 3 , 1 ) =- rdat % r02 ( 6 , 6 ) c1 ( 1 , 3 , 1 ) =- rdat % r01 ( 2 , 6 ) c1 ( 2 , 3 , 1 ) =- rdat % r01 ( 2 , 7 ) do j = 1 , 6 k = ind ( j , 4 , 1 ) m = in6 ( j ) c3 ( j , 4 , 1 ) =- rdat % r03 ( k , 2 ) + rdat % r02 ( m , 2 ) enddo c2 ( 1 , 4 , 1 ) =- rdat % r02 ( 5 , 6 ) + rdat % r01 ( 1 , 2 ) c2 ( 2 , 4 , 1 ) =- rdat % r02 ( 6 , 6 ) + rdat % r01 ( 2 , 2 ) c2 ( 3 , 4 , 1 ) =- rdat % r02 ( 3 , 6 ) + rdat % r01 ( 3 , 2 ) c1 ( 1 , 4 , 1 ) =- rdat % r01 ( 3 , 6 ) + rdat % r00 ( 2 , 1 ) c1 ( 2 , 4 , 1 ) =- rdat % r01 ( 3 , 7 ) + rdat % r00 ( 2 , 2 ) do j = 1 , 6 c3 ( j , 1 , 2 ) =- rdat % r03 ( j , 3 ) enddo c2 ( 1 , 1 , 2 ) =- rdat % r02 ( 1 , 7 ) c2 ( 2 , 1 , 2 ) =- rdat % r02 ( 4 , 7 ) c2 ( 3 , 1 , 2 ) =- rdat % r02 ( 5 , 7 ) c1 ( 1 , 1 , 2 ) =- rdat % r01 ( 1 , 8 ) c1 ( 2 , 1 , 2 ) =- rdat % r01 ( 1 , 9 ) do j = 1 , 6 m = in6 ( j ) c3 ( j , 2 , 2 ) =+ rdat % r04 ( j , 1 ) + rdat % r02 ( m , 5 ) enddo c2 ( 1 , 2 , 2 ) =+ rdat % r03 ( 1 , 5 ) + rdat % r01 ( 1 , 5 ) c2 ( 2 , 2 , 2 ) =+ rdat % r03 ( 2 , 5 ) + rdat % r01 ( 2 , 5 ) c2 ( 3 , 2 , 2 ) =+ rdat % r03 ( 3 , 5 ) + rdat % r01 ( 3 , 5 ) c1 ( 1 , 2 , 2 ) =+ rdat % r02 ( 1 , 10 ) + rdat % r00 ( 5 , 1 ) c1 ( 2 , 2 , 2 ) =+ rdat % r02 ( 1 , 11 ) + rdat % r00 ( 5 , 2 ) do j = 1 , 6 k = ind ( j , 3 , 2 ) c3 ( j , 3 , 2 ) =+ rdat % r04 ( k , 1 ) enddo c2 ( 1 , 3 , 2 ) =+ rdat % r03 ( 2 , 5 ) c2 ( 2 , 3 , 2 ) =+ rdat % r03 ( 4 , 5 ) c2 ( 3 , 3 , 2 ) =+ rdat % r03 ( 5 , 5 ) c1 ( 1 , 3 , 2 ) =+ rdat % r02 ( 4 , 10 ) c1 ( 2 , 3 , 2 ) =+ rdat % r02 ( 4 , 11 ) do j = 1 , 6 k = ind ( j , 4 , 2 ) m = in6 ( j ) c3 ( j , 4 , 2 ) =+ rdat % r04 ( k , 1 ) - rdat % r03 ( j , 4 ) enddo c2 ( 1 , 4 , 2 ) =+ rdat % r03 ( 3 , 5 ) - rdat % r02 ( 1 , 8 ) c2 ( 2 , 4 , 2 ) =+ rdat % r03 ( 5 , 5 ) - rdat % r02 ( 4 , 8 ) c2 ( 3 , 4 , 2 ) =+ rdat % r03 ( 6 , 5 ) - rdat % r02 ( 5 , 8 ) c1 ( 1 , 4 , 2 ) =+ rdat % r02 ( 5 , 10 ) - rdat % r01 ( 1 , 10 ) c1 ( 2 , 4 , 2 ) =+ rdat % r02 ( 5 , 11 ) - rdat % r01 ( 1 , 11 ) do j = 1 , 6 k = ind ( j , 1 , 3 ) c3 ( j , 1 , 3 ) =- rdat % r03 ( k , 3 ) enddo c2 ( 1 , 1 , 3 ) =- rdat % r02 ( 4 , 7 ) c2 ( 2 , 1 , 3 ) =- rdat % r02 ( 2 , 7 ) c2 ( 3 , 1 , 3 ) =- rdat % r02 ( 6 , 7 ) c1 ( 1 , 1 , 3 ) =- rdat % r01 ( 2 , 8 ) c1 ( 2 , 1 , 3 ) =- rdat % r01 ( 2 , 9 ) do j = 1 , 6 k = ind ( j , 3 , 3 ) m = in6 ( j ) c3 ( j , 3 , 3 ) =+ rdat % r04 ( k , 1 ) + rdat % r02 ( m , 5 ) enddo c2 ( 1 , 3 , 3 ) =+ rdat % r03 ( 4 , 5 ) + rdat % r01 ( 1 , 5 ) c2 ( 2 , 3 , 3 ) =+ rdat % r03 ( 7 , 5 ) + rdat % r01 ( 2 , 5 ) c2 ( 3 , 3 , 3 ) =+ rdat % r03 ( 8 , 5 ) + rdat % r01 ( 3 , 5 ) c1 ( 1 , 3 , 3 ) =+ rdat % r02 ( 2 , 10 ) + rdat % r00 ( 5 , 1 ) c1 ( 2 , 3 , 3 ) =+ rdat % r02 ( 2 , 11 ) + rdat % r00 ( 5 , 2 ) c3 ( 1 , 4 , 3 ) =+ rdat % r04 ( 5 , 1 ) - rdat % r03 ( 2 , 4 ) c3 ( 2 , 4 , 3 ) =+ rdat % r04 ( 8 , 1 ) - rdat % r03 ( 4 , 4 ) c3 ( 3 , 4 , 3 ) =+ rdat % r04 ( 9 , 1 ) - rdat % r03 ( 5 , 4 ) c3 ( 4 , 4 , 3 ) =+ rdat % r04 ( 12 , 1 ) - rdat % r03 ( 7 , 4 ) c3 ( 5 , 4 , 3 ) =+ rdat % r04 ( 13 , 1 ) - rdat % r03 ( 8 , 4 ) c3 ( 6 , 4 , 3 ) =+ rdat % r04 ( 14 , 1 ) - rdat % r03 ( 9 , 4 ) c2 ( 1 , 4 , 3 ) =+ rdat % r03 ( 5 , 5 ) - rdat % r02 ( 4 , 8 ) c2 ( 2 , 4 , 3 ) =+ rdat % r03 ( 8 , 5 ) - rdat % r02 ( 2 , 8 ) c2 ( 3 , 4 , 3 ) =+ rdat % r03 ( 9 , 5 ) - rdat % r02 ( 6 , 8 ) c1 ( 1 , 4 , 3 ) =+ rdat % r02 ( 6 , 10 ) - rdat % r01 ( 2 , 10 ) c1 ( 2 , 4 , 3 ) =+ rdat % r02 ( 6 , 11 ) - rdat % r01 ( 2 , 11 ) do j = 1 , 6 k = ind ( j , 1 , 4 ) m = in6 ( j ) c3 ( j , 1 , 4 ) =- rdat % r03 ( k , 3 ) + rdat % r02 ( m , 3 ) enddo c2 ( 1 , 1 , 4 ) =- rdat % r02 ( 5 , 7 ) + rdat % r01 ( 1 , 3 ) c2 ( 2 , 1 , 4 ) =- rdat % r02 ( 6 , 7 ) + rdat % r01 ( 2 , 3 ) c2 ( 3 , 1 , 4 ) =- rdat % r02 ( 3 , 7 ) + rdat % r01 ( 3 , 3 ) c1 ( 1 , 1 , 4 ) =- rdat % r01 ( 3 , 8 ) + rdat % r00 ( 3 , 1 ) c1 ( 2 , 1 , 4 ) =- rdat % r01 ( 3 , 9 ) + rdat % r00 ( 3 , 2 ) do j = 1 , 6 k = ind ( j , 2 , 4 ) c3 ( j , 2 , 4 ) =+ rdat % r04 ( k , 1 ) - rdat % r03 ( j , 1 ) enddo c2 ( 1 , 2 , 4 ) =+ rdat % r03 ( 3 , 5 ) - rdat % r02 ( 1 , 9 ) c2 ( 2 , 2 , 4 ) =+ rdat % r03 ( 5 , 5 ) - rdat % r02 ( 4 , 9 ) c2 ( 3 , 2 , 4 ) =+ rdat % r03 ( 6 , 5 ) - rdat % r02 ( 5 , 9 ) c1 ( 1 , 2 , 4 ) =+ rdat % r02 ( 5 , 10 ) - rdat % r01 ( 1 , 12 ) c1 ( 2 , 2 , 4 ) =+ rdat % r02 ( 5 , 11 ) - rdat % r01 ( 1 , 13 ) c3 ( 1 , 3 , 4 ) =+ rdat % r04 ( 5 , 1 ) - rdat % r03 ( 2 , 1 ) c3 ( 2 , 3 , 4 ) =+ rdat % r04 ( 8 , 1 ) - rdat % r03 ( 4 , 1 ) c3 ( 3 , 3 , 4 ) =+ rdat % r04 ( 9 , 1 ) - rdat % r03 ( 5 , 1 ) c3 ( 4 , 3 , 4 ) =+ rdat % r04 ( 12 , 1 ) - rdat % r03 ( 7 , 1 ) c3 ( 5 , 3 , 4 ) =+ rdat % r04 ( 13 , 1 ) - rdat % r03 ( 8 , 1 ) c3 ( 6 , 3 , 4 ) =+ rdat % r04 ( 14 , 1 ) - rdat % r03 ( 9 , 1 ) c2 ( 1 , 3 , 4 ) =+ rdat % r03 ( 5 , 5 ) - rdat % r02 ( 4 , 9 ) c2 ( 2 , 3 , 4 ) =+ rdat % r03 ( 8 , 5 ) - rdat % r02 ( 2 , 9 ) c2 ( 3 , 3 , 4 ) =+ rdat % r03 ( 9 , 5 ) - rdat % r02 ( 6 , 9 ) c1 ( 1 , 3 , 4 ) =+ rdat % r02 ( 6 , 10 ) - rdat % r01 ( 2 , 12 ) c1 ( 2 , 3 , 4 ) =+ rdat % r02 ( 6 , 11 ) - rdat % r01 ( 2 , 13 ) c3 ( 1 , 4 , 4 ) =+ rdat % r04 ( 6 , 1 ) - rdat % r03 ( 3 , 1 ) - rdat % r03 ( 3 , 4 ) + rdat % r02 ( 1 , 4 ) + rdat % r02 ( 1 , 5 ) c3 ( 2 , 4 , 4 ) =+ rdat % r04 ( 9 , 1 ) - rdat % r03 ( 5 , 1 ) - rdat % r03 ( 5 , 4 ) + rdat % r02 ( 4 , 4 ) + rdat % r02 ( 4 , 5 ) c3 ( 3 , 4 , 4 ) =+ rdat % r04 ( 10 , 1 ) - rdat % r03 ( 6 , 1 ) - rdat % r03 ( 6 , 4 ) + rdat % r02 ( 5 , 4 ) + rdat % r02 ( 5 , 5 ) c3 ( 4 , 4 , 4 ) =+ rdat % r04 ( 13 , 1 ) - rdat % r03 ( 8 , 1 ) - rdat % r03 ( 8 , 4 ) + rdat % r02 ( 2 , 4 ) + rdat % r02 ( 2 , 5 ) c3 ( 5 , 4 , 4 ) =+ rdat % r04 ( 14 , 1 ) - rdat % r03 ( 9 , 1 ) - rdat % r03 ( 9 , 4 ) + rdat % r02 ( 6 , 4 ) + rdat % r02 ( 6 , 5 ) c3 ( 6 , 4 , 4 ) =+ rdat % r04 ( 15 , 1 ) - rdat % r03 ( 10 , 1 ) - rdat % r03 ( 10 , 4 ) + rdat % r02 ( 3 , 4 ) + rdat % r02 ( 3 , 5 ) c2 ( 1 , 4 , 4 ) =+ rdat % r03 ( 6 , 5 ) - rdat % r02 ( 5 , 8 ) - rdat % r02 ( 5 , 9 ) + rdat % r01 ( 1 , 4 ) + rdat % r01 ( 1 , 5 ) c2 ( 2 , 4 , 4 ) =+ rdat % r03 ( 9 , 5 ) - rdat % r02 ( 6 , 8 ) - rdat % r02 ( 6 , 9 ) + rdat % r01 ( 2 , 4 ) + rdat % r01 ( 2 , 5 ) c2 ( 3 , 4 , 4 ) =+ rdat % r03 ( 10 , 5 ) - rdat % r02 ( 3 , 8 ) - rdat % r02 ( 3 , 9 ) + rdat % r01 ( 3 , 4 ) + rdat % r01 ( 3 , 5 ) c1 ( 1 , 4 , 4 ) =+ rdat % r02 ( 3 , 10 ) - rdat % r01 ( 3 , 10 ) - rdat % r01 ( 3 , 12 ) + rdat % r00 ( 4 , 1 ) + rdat % r00 ( 5 , 1 ) c1 ( 2 , 4 , 4 ) =+ rdat % r02 ( 3 , 11 ) - rdat % r01 ( 3 , 11 ) - rdat % r01 ( 3 , 13 ) + rdat % r00 ( 4 , 2 ) + rdat % r00 ( 5 , 2 ) do l = 2 , lx do k = 2 , kx if ( k == 2 . and . l == 3 ) cycle f ( 1 , 1 , k - 1 , l - 1 ) =+ c3 ( 1 , k , l ) + c1 ( 1 , k , l ) + ( + c2 ( 1 , k , l ) + c2 ( 1 , k , l ) + c1 ( 2 , k , l ) * qx ) * qx f ( 2 , 1 , k - 1 , l - 1 ) =+ c3 ( 4 , k , l ) + c1 ( 1 , k , l ) f ( 3 , 1 , k - 1 , l - 1 ) =+ c3 ( 6 , k , l ) + c1 ( 1 , k , l ) + ( + c2 ( 3 , k , l ) + c2 ( 3 , k , l ) + c1 ( 2 , k , l ) * qz ) * qz f ( 4 , 1 , k - 1 , l - 1 ) =+ c3 ( 2 , k , l ) + c2 ( 2 , k , l ) * qx f ( 5 , 1 , k - 1 , l - 1 ) =+ c3 ( 3 , k , l ) + c2 ( 3 , k , l ) * qx + ( + c2 ( 1 , k , l ) + c1 ( 2 , k , l ) * qx ) * qz f ( 6 , 1 , k - 1 , l - 1 ) =+ c3 ( 5 , k , l ) + c2 ( 2 , k , l ) * qz enddo enddo do i = 1 , 6 f ( i , 1 , 1 , 2 ) = f ( i , 1 , 2 , 1 ) enddo end subroutine mcdv_13 ! > ! >    @brief   ddps case ! > ! >    @details integration of a ddps case ! > subroutine mcdv_14 ( f , rdat , qx , qz ) implicit none type ( rotaxis_data_t ) :: rdat real ( kind = dp ) :: f ( 6 , 6 , 3 , * ) real ( kind = dp ) :: qx , qz integer , parameter :: kx = 4 , lx = 1 real ( kind = dp ) :: e1 ( 5 , kx , lx ), e2 ( 4 , 3 , kx , lx ), e3 ( 4 , 6 , kx , lx ), & e4 ( 2 , 10 , kx , lx ), e5 ( 15 , kx , lx ) integer , parameter :: ind ( 15 , kx , lx ) = reshape (& [ 1 , 2 , 3 , 4 , 5 , 6 , 7 , 8 , 9 , 10 , 11 , 12 , 13 , 14 , 15 , 1 , 2 , 3 , 4 , 5 , & 6 , 7 , 8 , 9 , 10 , 11 , 12 , 13 , 14 , 15 , 2 , 4 , 5 , 7 , 8 , 9 , 11 , 12 , 13 , & 14 , 16 , 17 , 18 , 19 , 20 , 3 , 5 , 6 , 8 , 9 , 10 , 12 , 13 , 14 , 15 , 17 , 18 , & 19 , 20 , 21 ] & , shape ( ind )) integer :: i , j , k , l , m real ( kind = dp ) :: xx , zz , xz , xxx , xxz , xzz , zzz real ( kind = dp ) :: xxxx , xxzz , xxxz , xzzz , zzzz real ( kind = dp ) :: xxxd , xxzd , xzzd , zzzd real ( kind = dp ) :: xzq real ( kind = dp ) :: qxd , qzd , xzd do j = 1 , 15 e5 ( j , 1 , 1 ) =+ rdat % r04 ( j , 1 ) enddo do j = 1 , 10 e4 ( 1 , j , 1 , 1 ) =+ rdat % r03 ( j , 1 ) e4 ( 2 , j , 1 , 1 ) =+ rdat % r03 ( j , 2 ) enddo do j = 1 , 6 m = in6 ( j ) e3 ( 1 , j , 1 , 1 ) =+ rdat % r02 ( m , 1 ) e3 ( 2 , j , 1 , 1 ) =+ rdat % r02 ( m , 2 ) e3 ( 3 , j , 1 , 1 ) =+ rdat % r02 ( m , 3 ) e3 ( 4 , j , 1 , 1 ) =+ rdat % r02 ( m , 4 ) enddo do j = 1 , 3 e2 ( 1 , j , 1 , 1 ) =+ rdat % r01 ( j , 1 ) e2 ( 2 , j , 1 , 1 ) =+ rdat % r01 ( j , 2 ) e2 ( 3 , j , 1 , 1 ) =+ rdat % r01 ( j , 3 ) e2 ( 4 , j , 1 , 1 ) =+ rdat % r01 ( j , 4 ) enddo do i = 1 , 5 e1 ( i , 1 , 1 ) =+ rdat % r00 ( i , 1 ) enddo do j = 1 , 15 e5 ( j , 2 , 1 ) =- rdat % r05 ( j , 1 ) enddo do j = 1 , 10 e4 ( 1 , j , 2 , 1 ) =- rdat % r04 ( j , 3 ) e4 ( 2 , j , 2 , 1 ) =- rdat % r04 ( j , 4 ) enddo do j = 1 , 6 e3 ( 1 , j , 2 , 1 ) =- rdat % r03 ( j , 5 ) e3 ( 2 , j , 2 , 1 ) =- rdat % r03 ( j , 6 ) e3 ( 3 , j , 2 , 1 ) =- rdat % r03 ( j , 7 ) e3 ( 4 , j , 2 , 1 ) =- rdat % r03 ( j , 8 ) enddo do j = 1 , 3 m = in6 ( j ) e2 ( 1 , j , 2 , 1 ) =- rdat % r02 ( m , 9 ) e2 ( 2 , j , 2 , 1 ) =- rdat % r02 ( m , 10 ) e2 ( 3 , j , 2 , 1 ) =- rdat % r02 ( m , 11 ) e2 ( 4 , j , 2 , 1 ) =- rdat % r02 ( m , 12 ) enddo j = 1 do i = 1 , 5 e1 ( i , 2 , 1 ) =- rdat % r01 ( j , i + 8 ) enddo do j = 1 , 15 k = ind ( j , 3 , 1 ) e5 ( j , 3 , 1 ) =- rdat % r05 ( k , 1 ) enddo do j = 1 , 10 k = ind ( j , 3 , 1 ) e4 ( 1 , j , 3 , 1 ) =- rdat % r04 ( k , 3 ) e4 ( 2 , j , 3 , 1 ) =- rdat % r04 ( k , 4 ) enddo do j = 1 , 6 k = ind ( j , 3 , 1 ) e3 ( 1 , j , 3 , 1 ) =- rdat % r03 ( k , 5 ) e3 ( 2 , j , 3 , 1 ) =- rdat % r03 ( k , 6 ) e3 ( 3 , j , 3 , 1 ) =- rdat % r03 ( k , 7 ) e3 ( 4 , j , 3 , 1 ) =- rdat % r03 ( k , 8 ) enddo do j = 1 , 3 k = ind ( j , 3 , 1 ) m = in6 ( k ) e2 ( 1 , j , 3 , 1 ) =- rdat % r02 ( m , 9 ) e2 ( 2 , j , 3 , 1 ) =- rdat % r02 ( m , 10 ) e2 ( 3 , j , 3 , 1 ) =- rdat % r02 ( m , 11 ) e2 ( 4 , j , 3 , 1 ) =- rdat % r02 ( m , 12 ) enddo j = 1 k = ind ( j , 3 , 1 ) do i = 1 , 5 e1 ( i , 3 , 1 ) =- rdat % r01 ( k , i + 8 ) enddo do j = 1 , 15 k = ind ( j , 4 , 1 ) e5 ( j , 4 , 1 ) =- rdat % r05 ( k , 1 ) + rdat % r04 ( j , 2 ) enddo do j = 1 , 10 k = ind ( j , 4 , 1 ) e4 ( 1 , j , 4 , 1 ) =- rdat % r04 ( k , 3 ) + rdat % r03 ( j , 3 ) e4 ( 2 , j , 4 , 1 ) =- rdat % r04 ( k , 4 ) + rdat % r03 ( j , 4 ) enddo do j = 1 , 6 k = ind ( j , 4 , 1 ) m = in6 ( j ) e3 ( 1 , j , 4 , 1 ) =- rdat % r03 ( k , 5 ) + rdat % r02 ( m , 5 ) e3 ( 2 , j , 4 , 1 ) =- rdat % r03 ( k , 6 ) + rdat % r02 ( m , 6 ) e3 ( 3 , j , 4 , 1 ) =- rdat % r03 ( k , 7 ) + rdat % r02 ( m , 7 ) e3 ( 4 , j , 4 , 1 ) =- rdat % r03 ( k , 8 ) + rdat % r02 ( m , 8 ) enddo do j = 1 , 3 k = ind ( j , 4 , 1 ) m = in6 ( k ) e2 ( 1 , j , 4 , 1 ) =- rdat % r02 ( m , 9 ) + rdat % r01 ( j , 5 ) e2 ( 2 , j , 4 , 1 ) =- rdat % r02 ( m , 10 ) + rdat % r01 ( j , 6 ) e2 ( 3 , j , 4 , 1 ) =- rdat % r02 ( m , 11 ) + rdat % r01 ( j , 7 ) e2 ( 4 , j , 4 , 1 ) =- rdat % r02 ( m , 12 ) + rdat % r01 ( j , 8 ) enddo j = 1 k = ind ( j , 4 , 1 ) do i = 1 , 5 e1 ( i , 4 , 1 ) =- rdat % r01 ( k , i + 8 ) + rdat % r00 ( i , 2 ) enddo xx = qx * qx zz = qz * qz xz = qx * qz xxx = xx * qx xxz = xx * qz xzz = zz * qx zzz = zz * qz xxxx = xx * xx xxxz = xx * xz xxzz = xx * zz xzzz = xz * zz zzzz = zz * zz qxd = qx + qx qzd = qz + qz xzd = xz + xz xxxd = xxx + xxx xxzd = xxz + xxz xzzd = xzz + xzz zzzd = zzz + zzz xzq = xz + xz + xz + xz do k = 2 , kx f ( 1 , 1 , k - 1 , 1 ) = e5 ( 1 , k , 1 ) + e3 ( 1 , 1 , k , 1 ) * 6 + e1 ( 1 , k , 1 ) * 3 + ( + e4 ( 1 , 1 , k , 1 ) + e4 ( 2 , 1 , k , 1 ) + ( + e2 ( 1 , 1 , k , 1 ) + e2 ( 2 , 1 , k , 1 )) * 3 ) * qxd + ( + e3 ( 2 , 1 , k , 1 ) + e3 ( 3 , 1 , k , 1 ) * 4 + e3 ( 4 , 1 , k , 1 ) + e1 ( 2 , k , 1 ) + e1 ( 3 , k , 1 ) * 4 + e1 ( 4 , k , 1 )) * xx + ( + e2 ( 3 , 1 , k , 1 ) + e2 ( 4 , 1 , k , 1 )) * xxxd + e1 ( 5 , k , 1 ) * xxxx f ( 2 , 1 , k - 1 , 1 ) = e5 ( 4 , k , 1 ) + e3 ( 1 , 4 , k , 1 ) + e3 ( 1 , 1 , k , 1 ) + e1 ( 1 , k , 1 ) + ( + e4 ( 2 , 4 , k , 1 ) + e2 ( 2 , 1 , k , 1 )) * qxd + ( + e3 ( 4 , 4 , k , 1 ) + e1 ( 4 , k , 1 )) * xx f ( 3 , 1 , k - 1 , 1 ) = e5 ( 6 , k , 1 ) + e3 ( 1 , 6 , k , 1 ) + e3 ( 1 , 1 , k , 1 ) + e1 ( 1 , k , 1 ) + ( + e4 ( 2 , 6 , k , 1 ) + e2 ( 2 , 1 , k , 1 )) * qxd + ( + e4 ( 1 , 3 , k , 1 ) + e2 ( 1 , 3 , k , 1 )) * qzd + ( + e3 ( 4 , 6 , k , 1 ) + e1 ( 4 , k , 1 )) * xx + e3 ( 3 , 3 , k , 1 ) * xzq + ( + e3 ( 2 , 1 , k , 1 ) + e1 ( 2 , k , 1 )) * zz + e2 ( 4 , 3 , k , 1 ) * xxzd + e2 ( 3 , 1 , k , 1 ) * xzzd + e1 ( 5 , k , 1 ) * xxzz f ( 4 , 1 , k - 1 , 1 ) = e5 ( 2 , k , 1 ) + e3 ( 1 , 2 , k , 1 ) * 3 + ( + e4 ( 1 , 2 , k , 1 ) + e4 ( 2 , 2 , k , 1 ) * 2 + e2 ( 1 , 2 , k , 1 ) + e2 ( 2 , 2 , k , 1 ) * 2 ) * qx + ( + e3 ( 3 , 2 , k , 1 ) * 2 + e3 ( 4 , 2 , k , 1 )) * xx + e2 ( 4 , 2 , k , 1 ) * xxx f ( 5 , 1 , k - 1 , 1 ) = e5 ( 3 , k , 1 ) + e3 ( 1 , 3 , k , 1 ) * 3 + ( + e4 ( 1 , 3 , k , 1 ) + e4 ( 2 , 3 , k , 1 ) * 2 + e2 ( 1 , 3 , k , 1 ) + e2 ( 2 , 3 , k , 1 ) * 2 ) * qx + ( + e4 ( 1 , 1 , k , 1 ) + e2 ( 1 , 1 , k , 1 ) * 3 ) * qz + ( + e3 ( 3 , 3 , k , 1 ) * 2 + e3 ( 4 , 3 , k , 1 )) * xx + ( + e3 ( 2 , 1 , k , 1 ) + e3 ( 3 , 1 , k , 1 ) * 2 + e1 ( 2 , k , 1 ) + e1 ( 3 , k , 1 ) * 2 ) * xz + e2 ( 4 , 3 , k , 1 ) * xxx + ( + e2 ( 3 , 1 , k , 1 ) * 2 + e2 ( 4 , 1 , k , 1 )) * xxz + e1 ( 5 , k , 1 ) * xxxz f ( 6 , 1 , k - 1 , 1 ) = e5 ( 5 , k , 1 ) + e3 ( 1 , 5 , k , 1 ) + e4 ( 2 , 5 , k , 1 ) * qxd + ( + e4 ( 1 , 2 , k , 1 ) + e2 ( 1 , 2 , k , 1 )) * qz + e3 ( 4 , 5 , k , 1 ) * xx + e3 ( 3 , 2 , k , 1 ) * xzd + e2 ( 4 , 2 , k , 1 ) * xxz f ( 1 , 2 , k - 1 , 1 ) = e5 ( 4 , k , 1 ) + e3 ( 1 , 4 , k , 1 ) + e3 ( 1 , 1 , k , 1 ) + e1 ( 1 , k , 1 ) + ( + e4 ( 1 , 4 , k , 1 ) + e2 ( 1 , 1 , k , 1 )) * qxd + ( + e3 ( 2 , 4 , k , 1 ) + e1 ( 2 , k , 1 )) * xx f ( 2 , 2 , k - 1 , 1 ) = e5 ( 11 , k , 1 ) + e3 ( 1 , 4 , k , 1 ) * 6 + e1 ( 1 , k , 1 ) * 3 f ( 3 , 2 , k - 1 , 1 ) = e5 ( 13 , k , 1 ) + e3 ( 1 , 6 , k , 1 ) + e3 ( 1 , 4 , k , 1 ) + e1 ( 1 , k , 1 ) + ( + e4 ( 1 , 8 , k , 1 ) + e2 ( 1 , 3 , k , 1 )) * qzd + ( + e3 ( 2 , 4 , k , 1 ) + e1 ( 2 , k , 1 )) * zz f ( 4 , 2 , k - 1 , 1 ) = e5 ( 7 , k , 1 ) + e3 ( 1 , 2 , k , 1 ) * 3 + ( + e4 ( 1 , 7 , k , 1 ) + e2 ( 1 , 2 , k , 1 ) * 3 ) * qx f ( 5 , 2 , k - 1 , 1 ) = e5 ( 8 , k , 1 ) + e3 ( 1 , 3 , k , 1 ) + ( + e4 ( 1 , 8 , k , 1 ) + e2 ( 1 , 3 , k , 1 )) * qx + ( + e4 ( 1 , 4 , k , 1 ) + e2 ( 1 , 1 , k , 1 )) * qz + ( + e3 ( 2 , 4 , k , 1 ) + e1 ( 2 , k , 1 )) * xz f ( 6 , 2 , k - 1 , 1 ) = e5 ( 12 , k , 1 ) + e3 ( 1 , 5 , k , 1 ) * 3 + ( + e4 ( 1 , 7 , k , 1 ) + e2 ( 1 , 2 , k , 1 ) * 3 ) * qz f ( 1 , 3 , k - 1 , 1 ) = e5 ( 6 , k , 1 ) + e3 ( 1 , 6 , k , 1 ) + e3 ( 1 , 1 , k , 1 ) + e1 ( 1 , k , 1 ) + ( + e4 ( 1 , 6 , k , 1 ) + e2 ( 1 , 1 , k , 1 )) * qxd + ( + e4 ( 2 , 3 , k , 1 ) + e2 ( 2 , 3 , k , 1 )) * qzd + ( + e3 ( 2 , 6 , k , 1 ) + e1 ( 2 , k , 1 )) * xx + e3 ( 3 , 3 , k , 1 ) * xzq + ( + e3 ( 4 , 1 , k , 1 ) + e1 ( 4 , k , 1 )) * zz + e2 ( 3 , 3 , k , 1 ) * xxzd + e2 ( 4 , 1 , k , 1 ) * xzzd + e1 ( 5 , k , 1 ) * xxzz f ( 2 , 3 , k - 1 , 1 ) = e5 ( 13 , k , 1 ) + e3 ( 1 , 6 , k , 1 ) + e3 ( 1 , 4 , k , 1 ) + e1 ( 1 , k , 1 ) + ( + e4 ( 2 , 8 , k , 1 ) + e2 ( 2 , 3 , k , 1 )) * qzd + ( + e3 ( 4 , 4 , k , 1 ) + e1 ( 4 , k , 1 )) * zz f ( 3 , 3 , k - 1 , 1 ) = e5 ( 15 , k , 1 ) + e3 ( 1 , 6 , k , 1 ) * 6 + e1 ( 1 , k , 1 ) * 3 + ( + e4 ( 1 , 10 , k , 1 ) + e4 ( 2 , 10 , k , 1 ) + ( + e2 ( 1 , 3 , k , 1 ) + e2 ( 2 , 3 , k , 1 )) * 3 ) * qzd + ( + e3 ( 2 , 6 , k , 1 ) + e3 ( 3 , 6 , k , 1 ) * 4 + e3 ( 4 , 6 , k , 1 ) + e1 ( 2 , k , 1 ) + e1 ( 3 , k , 1 ) * 4 + e1 ( 4 , k , 1 )) * zz + ( + e2 ( 3 , 3 , k , 1 ) + e2 ( 4 , 3 , k , 1 )) * zzzd + e1 ( 5 , k , 1 ) * zzzz f ( 4 , 3 , k - 1 , 1 ) = e5 ( 9 , k , 1 ) + e3 ( 1 , 2 , k , 1 ) + ( + e4 ( 1 , 9 , k , 1 ) + e2 ( 1 , 2 , k , 1 )) * qx + e4 ( 2 , 5 , k , 1 ) * qzd + e3 ( 3 , 5 , k , 1 ) * xzd + e3 ( 4 , 2 , k , 1 ) * zz + e2 ( 4 , 2 , k , 1 ) * xzz f ( 5 , 3 , k - 1 , 1 ) = e5 ( 10 , k , 1 ) + e3 ( 1 , 3 , k , 1 ) * 3 + ( + e4 ( 1 , 10 , k , 1 ) + e2 ( 1 , 3 , k , 1 ) * 3 ) * qx + ( + e4 ( 1 , 6 , k , 1 ) + e4 ( 2 , 6 , k , 1 ) * 2 + e2 ( 1 , 1 , k , 1 ) + e2 ( 2 , 1 , k , 1 ) * 2 ) * qz + ( + e3 ( 2 , 6 , k , 1 ) + e3 ( 3 , 6 , k , 1 ) * 2 + e1 ( 2 , k , 1 ) + e1 ( 3 , k , 1 ) * 2 ) * xz + ( + e3 ( 3 , 3 , k , 1 ) * 2 + e3 ( 4 , 3 , k , 1 )) * zz + ( + e2 ( 3 , 3 , k , 1 ) * 2 + e2 ( 4 , 3 , k , 1 )) * xzz + e2 ( 4 , 1 , k , 1 ) * zzz + e1 ( 5 , k , 1 ) * xzzz f ( 6 , 3 , k - 1 , 1 ) = e5 ( 14 , k , 1 ) + e3 ( 1 , 5 , k , 1 ) * 3 + ( + e4 ( 1 , 9 , k , 1 ) + e4 ( 2 , 9 , k , 1 ) * 2 + e2 ( 1 , 2 , k , 1 ) + e2 ( 2 , 2 , k , 1 ) * 2 ) * qz + ( + e3 ( 3 , 5 , k , 1 ) * 2 + e3 ( 4 , 5 , k , 1 )) * zz + e2 ( 4 , 2 , k , 1 ) * zzz f ( 1 , 4 , k - 1 , 1 ) = e5 ( 2 , k , 1 ) + e3 ( 1 , 2 , k , 1 ) * 3 + ( + e4 ( 1 , 2 , k , 1 ) * 2 + e4 ( 2 , 2 , k , 1 ) + e2 ( 1 , 2 , k , 1 ) * 2 + e2 ( 2 , 2 , k , 1 )) * qx + ( + e3 ( 2 , 2 , k , 1 ) + e3 ( 3 , 2 , k , 1 ) * 2 ) * xx + e2 ( 3 , 2 , k , 1 ) * xxx f ( 2 , 4 , k - 1 , 1 ) = e5 ( 7 , k , 1 ) + e3 ( 1 , 2 , k , 1 ) * 3 + ( + e4 ( 2 , 7 , k , 1 ) + e2 ( 2 , 2 , k , 1 ) * 3 ) * qx f ( 3 , 4 , k - 1 , 1 ) = e5 ( 9 , k , 1 ) + e3 ( 1 , 2 , k , 1 ) + ( + e4 ( 2 , 9 , k , 1 ) + e2 ( 2 , 2 , k , 1 )) * qx + e4 ( 1 , 5 , k , 1 ) * qzd + e3 ( 3 , 5 , k , 1 ) * xzd + e3 ( 2 , 2 , k , 1 ) * zz + e2 ( 3 , 2 , k , 1 ) * xzz f ( 4 , 4 , k - 1 , 1 ) = e5 ( 4 , k , 1 ) + e3 ( 1 , 4 , k , 1 ) + e3 ( 1 , 1 , k , 1 ) + e1 ( 1 , k , 1 ) + ( + e4 ( 1 , 4 , k , 1 ) + e4 ( 2 , 4 , k , 1 ) + e2 ( 1 , 1 , k , 1 ) + e2 ( 2 , 1 , k , 1 )) * qx + ( + e3 ( 3 , 4 , k , 1 ) + e1 ( 3 , k , 1 )) * xx f ( 5 , 4 , k - 1 , 1 ) = e5 ( 5 , k , 1 ) + e3 ( 1 , 5 , k , 1 ) + ( + e4 ( 1 , 5 , k , 1 ) + e4 ( 2 , 5 , k , 1 )) * qx + ( + e4 ( 1 , 2 , k , 1 ) + e2 ( 1 , 2 , k , 1 )) * qz + e3 ( 3 , 5 , k , 1 ) * xx + ( + e3 ( 2 , 2 , k , 1 ) + e3 ( 3 , 2 , k , 1 )) * xz + e2 ( 3 , 2 , k , 1 ) * xxz f ( 6 , 4 , k - 1 , 1 ) = e5 ( 8 , k , 1 ) + e3 ( 1 , 3 , k , 1 ) + ( + e4 ( 2 , 8 , k , 1 ) + e2 ( 2 , 3 , k , 1 )) * qx + ( + e4 ( 1 , 4 , k , 1 ) + e2 ( 1 , 1 , k , 1 )) * qz + ( + e3 ( 3 , 4 , k , 1 ) + e1 ( 3 , k , 1 )) * xz f ( 1 , 5 , k - 1 , 1 ) = e5 ( 3 , k , 1 ) + e3 ( 1 , 3 , k , 1 ) * 3 + ( + e4 ( 1 , 3 , k , 1 ) * 2 + e4 ( 2 , 3 , k , 1 ) + e2 ( 1 , 3 , k , 1 ) * 2 + e2 ( 2 , 3 , k , 1 )) * qx + ( + e4 ( 2 , 1 , k , 1 ) + e2 ( 2 , 1 , k , 1 ) * 3 ) * qz + ( + e3 ( 2 , 3 , k , 1 ) + e3 ( 3 , 3 , k , 1 ) * 2 ) * xx + ( + e3 ( 3 , 1 , k , 1 ) * 2 + e3 ( 4 , 1 , k , 1 ) + e1 ( 3 , k , 1 ) * 2 + e1 ( 4 , k , 1 )) * xz + e2 ( 3 , 3 , k , 1 ) * xxx + ( + e2 ( 3 , 1 , k , 1 ) + e2 ( 4 , 1 , k , 1 ) * 2 ) * xxz + e1 ( 5 , k , 1 ) * xxxz f ( 2 , 5 , k - 1 , 1 ) = e5 ( 8 , k , 1 ) + e3 ( 1 , 3 , k , 1 ) + ( + e4 ( 2 , 8 , k , 1 ) + e2 ( 2 , 3 , k , 1 )) * qx + ( + e4 ( 2 , 4 , k , 1 ) + e2 ( 2 , 1 , k , 1 )) * qz + ( + e3 ( 4 , 4 , k , 1 ) + e1 ( 4 , k , 1 )) * xz f ( 3 , 5 , k - 1 , 1 ) = e5 ( 10 , k , 1 ) + e3 ( 1 , 3 , k , 1 ) * 3 + ( + e4 ( 2 , 10 , k , 1 ) + e2 ( 2 , 3 , k , 1 ) * 3 ) * qx + ( + e4 ( 1 , 6 , k , 1 ) * 2 + e4 ( 2 , 6 , k , 1 ) + e2 ( 1 , 1 , k , 1 ) * 2 + e2 ( 2 , 1 , k , 1 )) * qz + ( + e3 ( 3 , 6 , k , 1 ) * 2 + e3 ( 4 , 6 , k , 1 ) + e1 ( 3 , k , 1 ) * 2 + e1 ( 4 , k , 1 )) * xz + ( + e3 ( 2 , 3 , k , 1 ) + e3 ( 3 , 3 , k , 1 ) * 2 ) * zz + ( + e2 ( 3 , 3 , k , 1 ) + e2 ( 4 , 3 , k , 1 ) * 2 ) * xzz + e2 ( 3 , 1 , k , 1 ) * zzz + e1 ( 5 , k , 1 ) * xzzz f ( 4 , 5 , k - 1 , 1 ) = e5 ( 5 , k , 1 ) + e3 ( 1 , 5 , k , 1 ) + ( + e4 ( 1 , 5 , k , 1 ) + e4 ( 2 , 5 , k , 1 )) * qx + ( + e4 ( 2 , 2 , k , 1 ) + e2 ( 2 , 2 , k , 1 )) * qz + e3 ( 3 , 5 , k , 1 ) * xx + ( + e3 ( 3 , 2 , k , 1 ) + e3 ( 4 , 2 , k , 1 )) * xz + e2 ( 4 , 2 , k , 1 ) * xxz f ( 5 , 5 , k - 1 , 1 ) = e5 ( 6 , k , 1 ) + e3 ( 1 , 6 , k , 1 ) + e3 ( 1 , 1 , k , 1 ) + e1 ( 1 , k , 1 ) + ( + e4 ( 1 , 6 , k , 1 ) + e4 ( 2 , 6 , k , 1 ) + e2 ( 1 , 1 , k , 1 ) + e2 ( 2 , 1 , k , 1 )) * qx + ( + e4 ( 1 , 3 , k , 1 ) + e4 ( 2 , 3 , k , 1 ) + e2 ( 1 , 3 , k , 1 ) + e2 ( 2 , 3 , k , 1 )) * qz + ( + e3 ( 3 , 6 , k , 1 ) + e1 ( 3 , k , 1 )) * xx + ( + e3 ( 2 , 3 , k , 1 ) + e3 ( 3 , 3 , k , 1 ) * 2 + e3 ( 4 , 3 , k , 1 )) * xz + ( + e3 ( 3 , 1 , k , 1 ) + e1 ( 3 , k , 1 )) * zz + ( + e2 ( 3 , 3 , k , 1 ) + e2 ( 4 , 3 , k , 1 )) * xxz + ( + e2 ( 3 , 1 , k , 1 ) + e2 ( 4 , 1 , k , 1 )) * xzz + e1 ( 5 , k , 1 ) * xxzz f ( 6 , 5 , k - 1 , 1 ) = e5 ( 9 , k , 1 ) + e3 ( 1 , 2 , k , 1 ) + ( + e4 ( 2 , 9 , k , 1 ) + e2 ( 2 , 2 , k , 1 )) * qx + ( + e4 ( 1 , 5 , k , 1 ) + e4 ( 2 , 5 , k , 1 )) * qz + ( + e3 ( 3 , 5 , k , 1 ) + e3 ( 4 , 5 , k , 1 )) * xz + e3 ( 3 , 2 , k , 1 ) * zz + e2 ( 4 , 2 , k , 1 ) * xzz f ( 1 , 6 , k - 1 , 1 ) = e5 ( 5 , k , 1 ) + e3 ( 1 , 5 , k , 1 ) + e4 ( 1 , 5 , k , 1 ) * qxd + ( + e4 ( 2 , 2 , k , 1 ) + e2 ( 2 , 2 , k , 1 )) * qz + e3 ( 2 , 5 , k , 1 ) * xx + e3 ( 3 , 2 , k , 1 ) * xzd + e2 ( 3 , 2 , k , 1 ) * xxz f ( 2 , 6 , k - 1 , 1 ) = e5 ( 12 , k , 1 ) + e3 ( 1 , 5 , k , 1 ) * 3 + ( + e4 ( 2 , 7 , k , 1 ) + e2 ( 2 , 2 , k , 1 ) * 3 ) * qz f ( 3 , 6 , k - 1 , 1 ) = e5 ( 14 , k , 1 ) + e3 ( 1 , 5 , k , 1 ) * 3 + ( + e4 ( 1 , 9 , k , 1 ) * 2 + e4 ( 2 , 9 , k , 1 ) + e2 ( 1 , 2 , k , 1 ) * 2 + e2 ( 2 , 2 , k , 1 )) * qz + ( + e3 ( 2 , 5 , k , 1 ) + e3 ( 3 , 5 , k , 1 ) * 2 ) * zz + e2 ( 3 , 2 , k , 1 ) * zzz f ( 4 , 6 , k - 1 , 1 ) = e5 ( 8 , k , 1 ) + e3 ( 1 , 3 , k , 1 ) + ( + e4 ( 1 , 8 , k , 1 ) + e2 ( 1 , 3 , k , 1 )) * qx + ( + e4 ( 2 , 4 , k , 1 ) + e2 ( 2 , 1 , k , 1 )) * qz + ( + e3 ( 3 , 4 , k , 1 ) + e1 ( 3 , k , 1 )) * xz f ( 5 , 6 , k - 1 , 1 ) = e5 ( 9 , k , 1 ) + e3 ( 1 , 2 , k , 1 ) + ( + e4 ( 1 , 9 , k , 1 ) + e2 ( 1 , 2 , k , 1 )) * qx + ( + e4 ( 1 , 5 , k , 1 ) + e4 ( 2 , 5 , k , 1 )) * qz + ( + e3 ( 2 , 5 , k , 1 ) + e3 ( 3 , 5 , k , 1 )) * xz + e3 ( 3 , 2 , k , 1 ) * zz + e2 ( 3 , 2 , k , 1 ) * xzz f ( 6 , 6 , k - 1 , 1 ) = e5 ( 13 , k , 1 ) + e3 ( 1 , 6 , k , 1 ) + e3 ( 1 , 4 , k , 1 ) + e1 ( 1 , k , 1 ) + ( + e4 ( 1 , 8 , k , 1 ) + e4 ( 2 , 8 , k , 1 ) + e2 ( 1 , 3 , k , 1 ) + e2 ( 2 , 3 , k , 1 )) * qz + ( + e3 ( 3 , 4 , k , 1 ) + e1 ( 3 , k , 1 )) * zz enddo end subroutine mcdv_14 ! > ! >    @brief   dpds case ! > ! >    @details integration of a dpds case ! > subroutine mcdv_15 ( f , rdat , qx , qz ) implicit none type ( rotaxis_data_t ) :: rdat real ( kind = dp ) :: f ( 6 , 3 , 6 , * ) real ( kind = dp ) :: qx , qz integer , parameter :: kx = 6 , lx = 1 real ( kind = dp ) :: d1 ( 5 , kx , lx ), d2 ( 4 , 3 , kx , lx ), d3 ( 3 , 6 , kx , lx ), & d4 ( 10 , kx , lx ) integer , parameter :: ind ( 10 , kx , lx ) = reshape (& [ 1 , 2 , 3 , 4 , 5 , 6 , 7 , 8 , 9 , 10 , 4 , 7 , 8 , 11 , 12 , 13 , 16 , 17 , 18 , & 19 , 6 , 9 , 10 , 13 , 14 , 15 , 18 , 19 , 20 , 21 , 2 , 4 , 5 , 7 , 8 , 9 , 11 , & 12 , 13 , 14 , 3 , 5 , 6 , 8 , 9 , 10 , 12 , 13 , 14 , 15 , 5 , 8 , 9 , 12 , 13 , & 14 , 17 , 18 , 19 , 20 ] & , shape ( ind )) integer :: i , j , k , l , m logical :: lsym16 , lsym19 real ( kind = dp ) :: xx , zz , xz , xxx , xxz , xzz , zzz real ( kind = dp ) :: qxd , qzd , xzd do j = 1 , 10 d4 ( j , 1 , 1 ) =+ rdat % r05 ( j , 1 ) + rdat % r03 ( j , 1 ) enddo do j = 1 , 6 m = in6 ( j ) d3 ( 1 , j , 1 , 1 ) =+ rdat % r04 ( j , 2 ) + rdat % r02 ( m , 1 ) d3 ( 2 , j , 1 , 1 ) =+ rdat % r04 ( j , 3 ) + rdat % r02 ( m , 2 ) d3 ( 3 , j , 1 , 1 ) =+ rdat % r04 ( j , 4 ) + rdat % r02 ( m , 3 ) enddo do j = 1 , 3 d2 ( 1 , j , 1 , 1 ) =+ rdat % r03 ( j , 6 ) + rdat % r01 ( j , 1 ) d2 ( 2 , j , 1 , 1 ) =+ rdat % r03 ( j , 7 ) + rdat % r01 ( j , 2 ) d2 ( 3 , j , 1 , 1 ) =+ rdat % r03 ( j , 8 ) + rdat % r01 ( j , 3 ) d2 ( 4 , j , 1 , 1 ) =+ rdat % r03 ( j , 9 ) + rdat % r01 ( j , 4 ) enddo j = 1 do i = 1 , 5 d1 ( i , 1 , 1 ) =+ rdat % r02 ( j , i + 10 ) + rdat % r00 ( i , 1 ) enddo do j = 1 , 10 k = ind ( j , 2 , 1 ) d4 ( j , 2 , 1 ) =+ rdat % r05 ( k , 1 ) + rdat % r03 ( j , 1 ) enddo do j = 1 , 6 k = ind ( j , 2 , 1 ) m = in6 ( j ) d3 ( 1 , j , 2 , 1 ) =+ rdat % r04 ( k , 2 ) + rdat % r02 ( m , 1 ) d3 ( 2 , j , 2 , 1 ) =+ rdat % r04 ( k , 3 ) + rdat % r02 ( m , 2 ) d3 ( 3 , j , 2 , 1 ) =+ rdat % r04 ( k , 4 ) + rdat % r02 ( m , 3 ) enddo do j = 1 , 3 k = ind ( j , 2 , 1 ) d2 ( 1 , j , 2 , 1 ) =+ rdat % r03 ( k , 6 ) + rdat % r01 ( j , 1 ) d2 ( 2 , j , 2 , 1 ) =+ rdat % r03 ( k , 7 ) + rdat % r01 ( j , 2 ) d2 ( 3 , j , 2 , 1 ) =+ rdat % r03 ( k , 8 ) + rdat % r01 ( j , 3 ) d2 ( 4 , j , 2 , 1 ) =+ rdat % r03 ( k , 9 ) + rdat % r01 ( j , 4 ) enddo j = 1 k = ind ( j , 2 , 1 ) m = in6 ( k ) do i = 1 , 5 d1 ( i , 2 , 1 ) =+ rdat % r02 ( m , i + 10 ) + rdat % r00 ( i , 1 ) enddo d4 ( 1 , 3 , 1 ) =+ rdat % r05 ( 6 , 1 ) - rdat % r04 ( 3 , 1 ) * 2 + rdat % r03 ( 1 , 1 ) + rdat % r03 ( 1 , 2 ) d4 ( 2 , 3 , 1 ) =+ rdat % r05 ( 9 , 1 ) - rdat % r04 ( 5 , 1 ) * 2 + rdat % r03 ( 2 , 1 ) + rdat % r03 ( 2 , 2 ) d4 ( 3 , 3 , 1 ) =+ rdat % r05 ( 10 , 1 ) - rdat % r04 ( 6 , 1 ) * 2 + rdat % r03 ( 3 , 1 ) + rdat % r03 ( 3 , 2 ) d4 ( 4 , 3 , 1 ) =+ rdat % r05 ( 13 , 1 ) - rdat % r04 ( 8 , 1 ) * 2 + rdat % r03 ( 4 , 1 ) + rdat % r03 ( 4 , 2 ) d4 ( 5 , 3 , 1 ) =+ rdat % r05 ( 14 , 1 ) - rdat % r04 ( 9 , 1 ) * 2 + rdat % r03 ( 5 , 1 ) + rdat % r03 ( 5 , 2 ) d4 ( 6 , 3 , 1 ) =+ rdat % r05 ( 15 , 1 ) - rdat % r04 ( 10 , 1 ) * 2 + rdat % r03 ( 6 , 1 ) + rdat % r03 ( 6 , 2 ) d4 ( 7 , 3 , 1 ) =+ rdat % r05 ( 18 , 1 ) - rdat % r04 ( 12 , 1 ) * 2 + rdat % r03 ( 7 , 1 ) + rdat % r03 ( 7 , 2 ) d4 ( 8 , 3 , 1 ) =+ rdat % r05 ( 19 , 1 ) - rdat % r04 ( 13 , 1 ) * 2 + rdat % r03 ( 8 , 1 ) + rdat % r03 ( 8 , 2 ) d4 ( 9 , 3 , 1 ) =+ rdat % r05 ( 20 , 1 ) - rdat % r04 ( 14 , 1 ) * 2 + rdat % r03 ( 9 , 1 ) + rdat % r03 ( 9 , 2 ) d4 ( 10 , 3 , 1 ) =+ rdat % r05 ( 21 , 1 ) - rdat % r04 ( 15 , 1 ) * 2 + rdat % r03 ( 10 , 1 ) + rdat % r03 ( 10 , 2 ) d3 ( 1 , 1 , 3 , 1 ) =+ rdat % r04 ( 6 , 2 ) - rdat % r03 ( 3 , 3 ) * 2 + rdat % r02 ( 1 , 1 ) + rdat % r02 ( 1 , 4 ) d3 ( 2 , 1 , 3 , 1 ) =+ rdat % r04 ( 6 , 3 ) - rdat % r03 ( 3 , 4 ) * 2 + rdat % r02 ( 1 , 2 ) + rdat % r02 ( 1 , 5 ) d3 ( 3 , 1 , 3 , 1 ) =+ rdat % r04 ( 6 , 4 ) - rdat % r03 ( 3 , 5 ) * 2 + rdat % r02 ( 1 , 3 ) + rdat % r02 ( 1 , 6 ) d3 ( 1 , 2 , 3 , 1 ) =+ rdat % r04 ( 9 , 2 ) - rdat % r03 ( 5 , 3 ) * 2 + rdat % r02 ( 4 , 1 ) + rdat % r02 ( 4 , 4 ) d3 ( 2 , 2 , 3 , 1 ) =+ rdat % r04 ( 9 , 3 ) - rdat % r03 ( 5 , 4 ) * 2 + rdat % r02 ( 4 , 2 ) + rdat % r02 ( 4 , 5 ) d3 ( 3 , 2 , 3 , 1 ) =+ rdat % r04 ( 9 , 4 ) - rdat % r03 ( 5 , 5 ) * 2 + rdat % r02 ( 4 , 3 ) + rdat % r02 ( 4 , 6 ) d3 ( 1 , 3 , 3 , 1 ) =+ rdat % r04 ( 10 , 2 ) - rdat % r03 ( 6 , 3 ) * 2 + rdat % r02 ( 5 , 1 ) + rdat % r02 ( 5 , 4 ) d3 ( 2 , 3 , 3 , 1 ) =+ rdat % r04 ( 10 , 3 ) - rdat % r03 ( 6 , 4 ) * 2 + rdat % r02 ( 5 , 2 ) + rdat % r02 ( 5 , 5 ) d3 ( 3 , 3 , 3 , 1 ) =+ rdat % r04 ( 10 , 4 ) - rdat % r03 ( 6 , 5 ) * 2 + rdat % r02 ( 5 , 3 ) + rdat % r02 ( 5 , 6 ) d3 ( 1 , 4 , 3 , 1 ) =+ rdat % r04 ( 13 , 2 ) - rdat % r03 ( 8 , 3 ) * 2 + rdat % r02 ( 2 , 1 ) + rdat % r02 ( 2 , 4 ) d3 ( 2 , 4 , 3 , 1 ) =+ rdat % r04 ( 13 , 3 ) - rdat % r03 ( 8 , 4 ) * 2 + rdat % r02 ( 2 , 2 ) + rdat % r02 ( 2 , 5 ) d3 ( 3 , 4 , 3 , 1 ) =+ rdat % r04 ( 13 , 4 ) - rdat % r03 ( 8 , 5 ) * 2 + rdat % r02 ( 2 , 3 ) + rdat % r02 ( 2 , 6 ) d3 ( 1 , 5 , 3 , 1 ) =+ rdat % r04 ( 14 , 2 ) - rdat % r03 ( 9 , 3 ) * 2 + rdat % r02 ( 6 , 1 ) + rdat % r02 ( 6 , 4 ) d3 ( 2 , 5 , 3 , 1 ) =+ rdat % r04 ( 14 , 3 ) - rdat % r03 ( 9 , 4 ) * 2 + rdat % r02 ( 6 , 2 ) + rdat % r02 ( 6 , 5 ) d3 ( 3 , 5 , 3 , 1 ) =+ rdat % r04 ( 14 , 4 ) - rdat % r03 ( 9 , 5 ) * 2 + rdat % r02 ( 6 , 3 ) + rdat % r02 ( 6 , 6 ) d3 ( 1 , 6 , 3 , 1 ) =+ rdat % r04 ( 15 , 2 ) - rdat % r03 ( 10 , 3 ) * 2 + rdat % r02 ( 3 , 1 ) + rdat % r02 ( 3 , 4 ) d3 ( 2 , 6 , 3 , 1 ) =+ rdat % r04 ( 15 , 3 ) - rdat % r03 ( 10 , 4 ) * 2 + rdat % r02 ( 3 , 2 ) + rdat % r02 ( 3 , 5 ) d3 ( 3 , 6 , 3 , 1 ) =+ rdat % r04 ( 15 , 4 ) - rdat % r03 ( 10 , 5 ) * 2 + rdat % r02 ( 3 , 3 ) + rdat % r02 ( 3 , 6 ) d2 ( 1 , 1 , 3 , 1 ) =+ rdat % r03 ( 6 , 6 ) - rdat % r02 ( 5 , 7 ) * 2 + rdat % r01 ( 1 , 1 ) + rdat % r01 ( 1 , 5 ) d2 ( 2 , 1 , 3 , 1 ) =+ rdat % r03 ( 6 , 7 ) - rdat % r02 ( 5 , 8 ) * 2 + rdat % r01 ( 1 , 2 ) + rdat % r01 ( 1 , 6 ) d2 ( 3 , 1 , 3 , 1 ) =+ rdat % r03 ( 6 , 8 ) - rdat % r02 ( 5 , 9 ) * 2 + rdat % r01 ( 1 , 3 ) + rdat % r01 ( 1 , 7 ) d2 ( 4 , 1 , 3 , 1 ) =+ rdat % r03 ( 6 , 9 ) - rdat % r02 ( 5 , 10 ) * 2 + rdat % r01 ( 1 , 4 ) + rdat % r01 ( 1 , 8 ) d2 ( 1 , 2 , 3 , 1 ) =+ rdat % r03 ( 9 , 6 ) - rdat % r02 ( 6 , 7 ) * 2 + rdat % r01 ( 2 , 1 ) + rdat % r01 ( 2 , 5 ) d2 ( 2 , 2 , 3 , 1 ) =+ rdat % r03 ( 9 , 7 ) - rdat % r02 ( 6 , 8 ) * 2 + rdat % r01 ( 2 , 2 ) + rdat % r01 ( 2 , 6 ) d2 ( 3 , 2 , 3 , 1 ) =+ rdat % r03 ( 9 , 8 ) - rdat % r02 ( 6 , 9 ) * 2 + rdat % r01 ( 2 , 3 ) + rdat % r01 ( 2 , 7 ) d2 ( 4 , 2 , 3 , 1 ) =+ rdat % r03 ( 9 , 9 ) - rdat % r02 ( 6 , 10 ) * 2 + rdat % r01 ( 2 , 4 ) + rdat % r01 ( 2 , 8 ) d2 ( 1 , 3 , 3 , 1 ) =+ rdat % r03 ( 10 , 6 ) - rdat % r02 ( 3 , 7 ) * 2 + rdat % r01 ( 3 , 1 ) + rdat % r01 ( 3 , 5 ) d2 ( 2 , 3 , 3 , 1 ) =+ rdat % r03 ( 10 , 7 ) - rdat % r02 ( 3 , 8 ) * 2 + rdat % r01 ( 3 , 2 ) + rdat % r01 ( 3 , 6 ) d2 ( 3 , 3 , 3 , 1 ) =+ rdat % r03 ( 10 , 8 ) - rdat % r02 ( 3 , 9 ) * 2 + rdat % r01 ( 3 , 3 ) + rdat % r01 ( 3 , 7 ) d2 ( 4 , 3 , 3 , 1 ) =+ rdat % r03 ( 10 , 9 ) - rdat % r02 ( 3 , 10 ) * 2 + rdat % r01 ( 3 , 4 ) + rdat % r01 ( 3 , 8 ) do i = 1 , 5 d1 ( i , 3 , 1 ) =+ rdat % r02 ( 3 , i + 10 ) - rdat % r01 ( 3 , i + 8 ) * 2 + rdat % r00 ( i , 1 ) + rdat % r00 ( i , 2 ) enddo do j = 1 , 10 k = ind ( j , 4 , 1 ) d4 ( j , 4 , 1 ) =+ rdat % r05 ( k , 1 ) enddo do j = 1 , 6 k = ind ( j , 4 , 1 ) d3 ( 1 , j , 4 , 1 ) =+ rdat % r04 ( k , 2 ) d3 ( 2 , j , 4 , 1 ) =+ rdat % r04 ( k , 3 ) d3 ( 3 , j , 4 , 1 ) =+ rdat % r04 ( k , 4 ) enddo do j = 1 , 3 k = ind ( j , 4 , 1 ) d2 ( 1 , j , 4 , 1 ) =+ rdat % r03 ( k , 6 ) d2 ( 2 , j , 4 , 1 ) =+ rdat % r03 ( k , 7 ) d2 ( 3 , j , 4 , 1 ) =+ rdat % r03 ( k , 8 ) d2 ( 4 , j , 4 , 1 ) =+ rdat % r03 ( k , 9 ) enddo j = 1 k = ind ( j , 4 , 1 ) m = in6 ( k ) do i = 1 , 5 d1 ( i , 4 , 1 ) =+ rdat % r02 ( m , i + 10 ) enddo do j = 1 , 10 k = ind ( j , 5 , 1 ) d4 ( j , 5 , 1 ) =+ rdat % r05 ( k , 1 ) - rdat % r04 ( j , 1 ) enddo do j = 1 , 6 k = ind ( j , 5 , 1 ) d3 ( 1 , j , 5 , 1 ) =+ rdat % r04 ( k , 2 ) - rdat % r03 ( j , 3 ) d3 ( 2 , j , 5 , 1 ) =+ rdat % r04 ( k , 3 ) - rdat % r03 ( j , 4 ) d3 ( 3 , j , 5 , 1 ) =+ rdat % r04 ( k , 4 ) - rdat % r03 ( j , 5 ) enddo do j = 1 , 3 k = ind ( j , 5 , 1 ) m = in6 ( j ) d2 ( 1 , j , 5 , 1 ) =+ rdat % r03 ( k , 6 ) - rdat % r02 ( m , 7 ) d2 ( 2 , j , 5 , 1 ) =+ rdat % r03 ( k , 7 ) - rdat % r02 ( m , 8 ) d2 ( 3 , j , 5 , 1 ) =+ rdat % r03 ( k , 8 ) - rdat % r02 ( m , 9 ) d2 ( 4 , j , 5 , 1 ) =+ rdat % r03 ( k , 9 ) - rdat % r02 ( m , 10 ) enddo j = 1 k = ind ( j , 5 , 1 ) m = in6 ( k ) do i = 1 , 5 d1 ( i , 5 , 1 ) =+ rdat % r02 ( m , i + 10 ) - rdat % r01 ( j , i + 8 ) enddo d4 ( 1 , 6 , 1 ) =+ rdat % r05 ( 5 , 1 ) - rdat % r04 ( 2 , 1 ) d4 ( 2 , 6 , 1 ) =+ rdat % r05 ( 8 , 1 ) - rdat % r04 ( 4 , 1 ) d4 ( 3 , 6 , 1 ) =+ rdat % r05 ( 9 , 1 ) - rdat % r04 ( 5 , 1 ) d4 ( 4 , 6 , 1 ) =+ rdat % r05 ( 12 , 1 ) - rdat % r04 ( 7 , 1 ) d4 ( 5 , 6 , 1 ) =+ rdat % r05 ( 13 , 1 ) - rdat % r04 ( 8 , 1 ) d4 ( 6 , 6 , 1 ) =+ rdat % r05 ( 14 , 1 ) - rdat % r04 ( 9 , 1 ) d4 ( 7 , 6 , 1 ) =+ rdat % r05 ( 17 , 1 ) - rdat % r04 ( 11 , 1 ) d4 ( 8 , 6 , 1 ) =+ rdat % r05 ( 18 , 1 ) - rdat % r04 ( 12 , 1 ) d4 ( 9 , 6 , 1 ) =+ rdat % r05 ( 19 , 1 ) - rdat % r04 ( 13 , 1 ) d4 ( 10 , 6 , 1 ) =+ rdat % r05 ( 20 , 1 ) - rdat % r04 ( 14 , 1 ) d3 ( 1 , 1 , 6 , 1 ) =+ rdat % r04 ( 5 , 2 ) - rdat % r03 ( 2 , 3 ) d3 ( 2 , 1 , 6 , 1 ) =+ rdat % r04 ( 5 , 3 ) - rdat % r03 ( 2 , 4 ) d3 ( 3 , 1 , 6 , 1 ) =+ rdat % r04 ( 5 , 4 ) - rdat % r03 ( 2 , 5 ) d3 ( 1 , 2 , 6 , 1 ) =+ rdat % r04 ( 8 , 2 ) - rdat % r03 ( 4 , 3 ) d3 ( 2 , 2 , 6 , 1 ) =+ rdat % r04 ( 8 , 3 ) - rdat % r03 ( 4 , 4 ) d3 ( 3 , 2 , 6 , 1 ) =+ rdat % r04 ( 8 , 4 ) - rdat % r03 ( 4 , 5 ) d3 ( 1 , 3 , 6 , 1 ) =+ rdat % r04 ( 9 , 2 ) - rdat % r03 ( 5 , 3 ) d3 ( 2 , 3 , 6 , 1 ) =+ rdat % r04 ( 9 , 3 ) - rdat % r03 ( 5 , 4 ) d3 ( 3 , 3 , 6 , 1 ) =+ rdat % r04 ( 9 , 4 ) - rdat % r03 ( 5 , 5 ) d3 ( 1 , 4 , 6 , 1 ) =+ rdat % r04 ( 12 , 2 ) - rdat % r03 ( 7 , 3 ) d3 ( 2 , 4 , 6 , 1 ) =+ rdat % r04 ( 12 , 3 ) - rdat % r03 ( 7 , 4 ) d3 ( 3 , 4 , 6 , 1 ) =+ rdat % r04 ( 12 , 4 ) - rdat % r03 ( 7 , 5 ) d3 ( 1 , 5 , 6 , 1 ) =+ rdat % r04 ( 13 , 2 ) - rdat % r03 ( 8 , 3 ) d3 ( 2 , 5 , 6 , 1 ) =+ rdat % r04 ( 13 , 3 ) - rdat % r03 ( 8 , 4 ) d3 ( 3 , 5 , 6 , 1 ) =+ rdat % r04 ( 13 , 4 ) - rdat % r03 ( 8 , 5 ) d3 ( 1 , 6 , 6 , 1 ) =+ rdat % r04 ( 14 , 2 ) - rdat % r03 ( 9 , 3 ) d3 ( 2 , 6 , 6 , 1 ) =+ rdat % r04 ( 14 , 3 ) - rdat % r03 ( 9 , 4 ) d3 ( 3 , 6 , 6 , 1 ) =+ rdat % r04 ( 14 , 4 ) - rdat % r03 ( 9 , 5 ) d2 ( 1 , 1 , 6 , 1 ) =+ rdat % r03 ( 5 , 6 ) - rdat % r02 ( 4 , 7 ) d2 ( 2 , 1 , 6 , 1 ) =+ rdat % r03 ( 5 , 7 ) - rdat % r02 ( 4 , 8 ) d2 ( 3 , 1 , 6 , 1 ) =+ rdat % r03 ( 5 , 8 ) - rdat % r02 ( 4 , 9 ) d2 ( 4 , 1 , 6 , 1 ) =+ rdat % r03 ( 5 , 9 ) - rdat % r02 ( 4 , 10 ) d2 ( 1 , 2 , 6 , 1 ) =+ rdat % r03 ( 8 , 6 ) - rdat % r02 ( 2 , 7 ) d2 ( 2 , 2 , 6 , 1 ) =+ rdat % r03 ( 8 , 7 ) - rdat % r02 ( 2 , 8 ) d2 ( 3 , 2 , 6 , 1 ) =+ rdat % r03 ( 8 , 8 ) - rdat % r02 ( 2 , 9 ) d2 ( 4 , 2 , 6 , 1 ) =+ rdat % r03 ( 8 , 9 ) - rdat % r02 ( 2 , 10 ) d2 ( 1 , 3 , 6 , 1 ) =+ rdat % r03 ( 9 , 6 ) - rdat % r02 ( 6 , 7 ) d2 ( 2 , 3 , 6 , 1 ) =+ rdat % r03 ( 9 , 7 ) - rdat % r02 ( 6 , 8 ) d2 ( 3 , 3 , 6 , 1 ) =+ rdat % r03 ( 9 , 8 ) - rdat % r02 ( 6 , 9 ) d2 ( 4 , 3 , 6 , 1 ) =+ rdat % r03 ( 9 , 9 ) - rdat % r02 ( 6 , 10 ) do i = 1 , 5 d1 ( i , 6 , 1 ) =+ rdat % r02 ( 6 , i + 10 ) - rdat % r01 ( 2 , i + 8 ) enddo xx = qx * qx zz = qz * qz xz = qx * qz xxx = xx * qx xxz = xx * qz xzz = zz * qx zzz = zz * qz qxd = qx + qx qzd = qz + qz xzd = xz + xz l = 1 do k = 1 , kx f ( 1 , 1 , k , l ) = d4 ( 1 , k , l ) + d2 ( 2 , 1 , k , l ) * 3 + ( + d3 ( 2 , 1 , k , l ) * 2 + d3 ( 3 , 1 , k , l ) + d1 ( 3 , k , l ) * 2 + d1 ( 4 , k , l )) * qx + ( + d2 ( 3 , 1 , k , l ) + d2 ( 4 , 1 , k , l ) * 2 ) * xx + d1 ( 5 , k , l ) * xxx f ( 2 , 1 , k , l ) = d4 ( 4 , k , l ) + d2 ( 2 , 1 , k , l ) + ( + d3 ( 3 , 4 , k , l ) + d1 ( 4 , k , l )) * qx f ( 3 , 1 , k , l ) = d4 ( 6 , k , l ) + d2 ( 2 , 1 , k , l ) + ( + d3 ( 3 , 6 , k , l ) + d1 ( 4 , k , l )) * qx + d3 ( 2 , 3 , k , l ) * qzd + d2 ( 4 , 3 , k , l ) * xzd + d2 ( 3 , 1 , k , l ) * zz + d1 ( 5 , k , l ) * xzz f ( 4 , 1 , k , l ) = d4 ( 2 , k , l ) + d2 ( 2 , 2 , k , l ) + ( + d3 ( 2 , 2 , k , l ) + d3 ( 3 , 2 , k , l )) * qx + d2 ( 4 , 2 , k , l ) * xx f ( 5 , 1 , k , l ) = d4 ( 3 , k , l ) + d2 ( 2 , 3 , k , l ) + ( + d3 ( 2 , 3 , k , l ) + d3 ( 3 , 3 , k , l )) * qx + ( + d3 ( 2 , 1 , k , l ) + d1 ( 3 , k , l )) * qz + d2 ( 4 , 3 , k , l ) * xx + ( + d2 ( 3 , 1 , k , l ) + d2 ( 4 , 1 , k , l )) * xz + d1 ( 5 , k , l ) * xxz f ( 6 , 1 , k , l ) = d4 ( 5 , k , l ) + d3 ( 3 , 5 , k , l ) * qx + d3 ( 2 , 2 , k , l ) * qz + d2 ( 4 , 2 , k , l ) * xz f ( 1 , 2 , k , l ) = d4 ( 2 , k , l ) + d2 ( 2 , 2 , k , l ) + d3 ( 2 , 2 , k , l ) * qxd + d2 ( 3 , 2 , k , l ) * xx f ( 2 , 2 , k , l ) = d4 ( 7 , k , l ) + d2 ( 2 , 2 , k , l ) * 3 f ( 3 , 2 , k , l ) = d4 ( 9 , k , l ) + d2 ( 2 , 2 , k , l ) + d3 ( 2 , 5 , k , l ) * qzd + d2 ( 3 , 2 , k , l ) * zz f ( 4 , 2 , k , l ) = d4 ( 4 , k , l ) + d2 ( 2 , 1 , k , l ) + ( + d3 ( 2 , 4 , k , l ) + d1 ( 3 , k , l )) * qx f ( 5 , 2 , k , l ) = d4 ( 5 , k , l ) + d3 ( 2 , 5 , k , l ) * qx + d3 ( 2 , 2 , k , l ) * qz + d2 ( 3 , 2 , k , l ) * xz f ( 6 , 2 , k , l ) = d4 ( 8 , k , l ) + d2 ( 2 , 3 , k , l ) + ( + d3 ( 2 , 4 , k , l ) + d1 ( 3 , k , l )) * qz f ( 1 , 3 , k , l ) = d4 ( 3 , k , l ) + d2 ( 2 , 3 , k , l ) + d3 ( 2 , 3 , k , l ) * qxd + ( + d3 ( 3 , 1 , k , l ) + d1 ( 4 , k , l )) * qz + d2 ( 3 , 3 , k , l ) * xx + d2 ( 4 , 1 , k , l ) * xzd + d1 ( 5 , k , l ) * xxz f ( 2 , 3 , k , l ) = d4 ( 8 , k , l ) + d2 ( 2 , 3 , k , l ) + ( + d3 ( 3 , 4 , k , l ) + d1 ( 4 , k , l )) * qz f ( 3 , 3 , k , l ) = d4 ( 10 , k , l ) + d2 ( 2 , 3 , k , l ) * 3 + ( + d3 ( 2 , 6 , k , l ) * 2 + d3 ( 3 , 6 , k , l ) + d1 ( 3 , k , l ) * 2 + d1 ( 4 , k , l )) * qz + ( + d2 ( 3 , 3 , k , l ) + d2 ( 4 , 3 , k , l ) * 2 ) * zz + d1 ( 5 , k , l ) * zzz f ( 4 , 3 , k , l ) = d4 ( 5 , k , l ) + d3 ( 2 , 5 , k , l ) * qx + d3 ( 3 , 2 , k , l ) * qz + d2 ( 4 , 2 , k , l ) * xz f ( 5 , 3 , k , l ) = d4 ( 6 , k , l ) + d2 ( 2 , 1 , k , l ) + ( + d3 ( 2 , 6 , k , l ) + d1 ( 3 , k , l )) * qx + ( + d3 ( 2 , 3 , k , l ) + d3 ( 3 , 3 , k , l )) * qz + ( + d2 ( 3 , 3 , k , l ) + d2 ( 4 , 3 , k , l )) * xz + d2 ( 4 , 1 , k , l ) * zz + d1 ( 5 , k , l ) * xzz f ( 6 , 3 , k , l ) = d4 ( 9 , k , l ) + d2 ( 2 , 2 , k , l ) + ( + d3 ( 2 , 5 , k , l ) + d3 ( 3 , 5 , k , l )) * qz + d2 ( 4 , 2 , k , l ) * zz enddo end subroutine mcdv_15 ! > ! >    @brief   dppp case ! > ! >    @details integration of a dppp case ! > subroutine mcdv_16 ( f , rdat , qx , qz ) implicit none type ( rotaxis_data_t ) :: rdat real ( kind = dp ) :: f ( 6 , 3 , 3 , * ) real ( kind = dp ) :: qx , qz integer , parameter :: kx = 4 , lx = 4 real ( kind = dp ) :: d1 ( 5 , kx , lx ), d2 ( 4 , 3 , kx , lx ), d3 ( 3 , 6 , kx , lx ), & d4 ( 10 , kx , lx ) integer , parameter :: ind ( 10 , kx , lx ) = reshape (& [ 1 , 2 , 3 , 4 , 5 , 6 , 7 , 8 , 9 , 10 , 1 , 2 , 3 , 4 , 5 , 6 , 7 , 8 , 9 , 10 , 2 , & 4 , 5 , 7 , 8 , 9 , 11 , 12 , 13 , 14 , 3 , 5 , 6 , 8 , 9 , 10 , 12 , 13 , 14 , & 15 , 1 , 2 , 3 , 4 , 5 , 6 , 7 , 8 , 9 , 10 , 1 , 2 , 3 , 4 , 5 , 6 , 7 , 8 , 9 , & 10 , 2 , 4 , 5 , 7 , 8 , 9 , 11 , 12 , 13 , 14 , 3 , 5 , 6 , 8 , 9 , 10 , 12 , 13 , & 14 , 15 , 2 , 4 , 5 , 7 , 8 , 9 , 11 , 12 , 13 , 14 , 2 , 4 , 5 , 7 , 8 , 9 , 11 , & 12 , 13 , 14 , 4 , 7 , 8 , 11 , 12 , 13 , 16 , 17 , 18 , 19 , 5 , 8 , 9 , 12 , & 13 , 14 , 17 , 18 , 19 , 20 , 3 , 5 , 6 , 8 , 9 , 10 , 12 , 13 , 14 , 15 , 3 , 5 , & 6 , 8 , 9 , 10 , 12 , 13 , 14 , 15 , 5 , 8 , 9 , 12 , 13 , 14 , 17 , 18 , 19 , & 20 , 6 , 9 , 10 , 13 , 14 , 15 , 18 , 19 , 20 , 21 ] & , shape ( ind )) integer :: i , j , k , l , m logical :: lsym16 , lsym19 real ( kind = dp ) :: xx , zz , xz , xxx , xxz , xzz , zzz real ( kind = dp ) :: qxd , qzd , xzd do j = 1 , 10 d4 ( j , 1 , 1 ) =+ rdat % r03 ( j , 1 ) enddo do j = 1 , 6 m = in6 ( j ) d3 ( 1 , j , 1 , 1 ) =+ rdat % r02 ( m , 1 ) d3 ( 2 , j , 1 , 1 ) =+ rdat % r02 ( m , 2 ) d3 ( 3 , j , 1 , 1 ) =+ rdat % r02 ( m , 3 ) enddo do j = 1 , 3 d2 ( 1 , j , 1 , 1 ) =+ rdat % r01 ( j , 1 ) d2 ( 2 , j , 1 , 1 ) =+ rdat % r01 ( j , 2 ) d2 ( 3 , j , 1 , 1 ) =+ rdat % r01 ( j , 3 ) d2 ( 4 , j , 1 , 1 ) =+ rdat % r01 ( j , 4 ) enddo do i = 1 , 5 d1 ( i , 1 , 1 ) =+ rdat % r00 ( i , 1 ) enddo do j = 1 , 10 d4 ( j , 2 , 1 ) =- rdat % r04 ( j , 2 ) enddo do j = 1 , 6 d3 ( 1 , j , 2 , 1 ) =- rdat % r03 ( j , 9 ) d3 ( 2 , j , 2 , 1 ) =- rdat % r03 ( j , 10 ) d3 ( 3 , j , 2 , 1 ) =- rdat % r03 ( j , 11 ) enddo do j = 1 , 3 m = in6 ( j ) d2 ( 1 , j , 2 , 1 ) =- rdat % r02 ( m , 16 ) d2 ( 2 , j , 2 , 1 ) =- rdat % r02 ( m , 17 ) d2 ( 3 , j , 2 , 1 ) =- rdat % r02 ( m , 18 ) d2 ( 4 , j , 2 , 1 ) =- rdat % r02 ( m , 19 ) enddo j = 1 do i = 1 , 5 d1 ( i , 2 , 1 ) =- rdat % r01 ( j , i + 20 ) enddo do j = 1 , 10 k = ind ( j , 3 , 1 ) d4 ( j , 3 , 1 ) =- rdat % r04 ( k , 2 ) enddo do j = 1 , 6 k = ind ( j , 3 , 1 ) d3 ( 1 , j , 3 , 1 ) =- rdat % r03 ( k , 9 ) d3 ( 2 , j , 3 , 1 ) =- rdat % r03 ( k , 10 ) d3 ( 3 , j , 3 , 1 ) =- rdat % r03 ( k , 11 ) enddo do j = 1 , 3 k = ind ( j , 3 , 1 ) m = in6 ( k ) d2 ( 1 , j , 3 , 1 ) =- rdat % r02 ( m , 16 ) d2 ( 2 , j , 3 , 1 ) =- rdat % r02 ( m , 17 ) d2 ( 3 , j , 3 , 1 ) =- rdat % r02 ( m , 18 ) d2 ( 4 , j , 3 , 1 ) =- rdat % r02 ( m , 19 ) enddo j = 1 k = ind ( j , 3 , 1 ) do i = 1 , 5 d1 ( i , 3 , 1 ) =- rdat % r01 ( k , i + 20 ) enddo do j = 1 , 10 k = ind ( j , 4 , 1 ) d4 ( j , 4 , 1 ) =- rdat % r04 ( k , 2 ) + rdat % r03 ( j , 2 ) enddo do j = 1 , 6 k = ind ( j , 4 , 1 ) m = in6 ( j ) d3 ( 1 , j , 4 , 1 ) =- rdat % r03 ( k , 9 ) + rdat % r02 ( m , 4 ) d3 ( 2 , j , 4 , 1 ) =- rdat % r03 ( k , 10 ) + rdat % r02 ( m , 5 ) d3 ( 3 , j , 4 , 1 ) =- rdat % r03 ( k , 11 ) + rdat % r02 ( m , 6 ) enddo do j = 1 , 3 k = ind ( j , 4 , 1 ) m = in6 ( k ) d2 ( 1 , j , 4 , 1 ) =- rdat % r02 ( m , 16 ) + rdat % r01 ( j , 5 ) d2 ( 2 , j , 4 , 1 ) =- rdat % r02 ( m , 17 ) + rdat % r01 ( j , 6 ) d2 ( 3 , j , 4 , 1 ) =- rdat % r02 ( m , 18 ) + rdat % r01 ( j , 7 ) d2 ( 4 , j , 4 , 1 ) =- rdat % r02 ( m , 19 ) + rdat % r01 ( j , 8 ) enddo j = 1 k = ind ( j , 4 , 1 ) do i = 1 , 5 d1 ( i , 4 , 1 ) =- rdat % r01 ( k , i + 20 ) + rdat % r00 ( i , 2 ) enddo do j = 1 , 10 d4 ( j , 1 , 2 ) =- rdat % r04 ( j , 3 ) enddo do j = 1 , 6 d3 ( 1 , j , 1 , 2 ) =- rdat % r03 ( j , 12 ) d3 ( 2 , j , 1 , 2 ) =- rdat % r03 ( j , 13 ) d3 ( 3 , j , 1 , 2 ) =- rdat % r03 ( j , 14 ) enddo do j = 1 , 3 m = in6 ( j ) d2 ( 1 , j , 1 , 2 ) =- rdat % r02 ( m , 20 ) d2 ( 2 , j , 1 , 2 ) =- rdat % r02 ( m , 21 ) d2 ( 3 , j , 1 , 2 ) =- rdat % r02 ( m , 22 ) d2 ( 4 , j , 1 , 2 ) =- rdat % r02 ( m , 23 ) enddo j = 1 do i = 1 , 5 d1 ( i , 1 , 2 ) =- rdat % r01 ( j , i + 25 ) enddo do j = 1 , 10 d4 ( j , 2 , 2 ) =+ rdat % r05 ( j , 1 ) + rdat % r03 ( j , 5 ) enddo do j = 1 , 6 m = in6 ( j ) d3 ( 1 , j , 2 , 2 ) =+ rdat % r04 ( j , 5 ) + rdat % r02 ( m , 13 ) d3 ( 2 , j , 2 , 2 ) =+ rdat % r04 ( j , 6 ) + rdat % r02 ( m , 14 ) d3 ( 3 , j , 2 , 2 ) =+ rdat % r04 ( j , 7 ) + rdat % r02 ( m , 15 ) enddo do j = 1 , 3 d2 ( 1 , j , 2 , 2 ) =+ rdat % r03 ( j , 18 ) + rdat % r01 ( j , 17 ) d2 ( 2 , j , 2 , 2 ) =+ rdat % r03 ( j , 19 ) + rdat % r01 ( j , 18 ) d2 ( 3 , j , 2 , 2 ) =+ rdat % r03 ( j , 20 ) + rdat % r01 ( j , 19 ) d2 ( 4 , j , 2 , 2 ) =+ rdat % r03 ( j , 21 ) + rdat % r01 ( j , 20 ) enddo j = 1 do i = 1 , 5 d1 ( i , 2 , 2 ) =+ rdat % r02 ( j , i + 31 ) + rdat % r00 ( i , 5 ) enddo do j = 1 , 10 k = ind ( j , 3 , 2 ) d4 ( j , 3 , 2 ) =+ rdat % r05 ( k , 1 ) enddo do j = 1 , 6 k = ind ( j , 3 , 2 ) d3 ( 1 , j , 3 , 2 ) =+ rdat % r04 ( k , 5 ) d3 ( 2 , j , 3 , 2 ) =+ rdat % r04 ( k , 6 ) d3 ( 3 , j , 3 , 2 ) =+ rdat % r04 ( k , 7 ) enddo do j = 1 , 3 k = ind ( j , 3 , 2 ) d2 ( 1 , j , 3 , 2 ) =+ rdat % r03 ( k , 18 ) d2 ( 2 , j , 3 , 2 ) =+ rdat % r03 ( k , 19 ) d2 ( 3 , j , 3 , 2 ) =+ rdat % r03 ( k , 20 ) d2 ( 4 , j , 3 , 2 ) =+ rdat % r03 ( k , 21 ) enddo j = 1 k = ind ( j , 3 , 2 ) m = in6 ( k ) do i = 1 , 5 d1 ( i , 3 , 2 ) =+ rdat % r02 ( m , i + 31 ) enddo do j = 1 , 10 k = ind ( j , 4 , 2 ) d4 ( j , 4 , 2 ) =+ rdat % r05 ( k , 1 ) - rdat % r04 ( j , 4 ) enddo do j = 1 , 6 k = ind ( j , 4 , 2 ) d3 ( 1 , j , 4 , 2 ) =+ rdat % r04 ( k , 5 ) - rdat % r03 ( j , 15 ) d3 ( 2 , j , 4 , 2 ) =+ rdat % r04 ( k , 6 ) - rdat % r03 ( j , 16 ) d3 ( 3 , j , 4 , 2 ) =+ rdat % r04 ( k , 7 ) - rdat % r03 ( j , 17 ) enddo do j = 1 , 3 k = ind ( j , 4 , 2 ) m = in6 ( j ) d2 ( 1 , j , 4 , 2 ) =+ rdat % r03 ( k , 18 ) - rdat % r02 ( m , 24 ) d2 ( 2 , j , 4 , 2 ) =+ rdat % r03 ( k , 19 ) - rdat % r02 ( m , 25 ) d2 ( 3 , j , 4 , 2 ) =+ rdat % r03 ( k , 20 ) - rdat % r02 ( m , 26 ) d2 ( 4 , j , 4 , 2 ) =+ rdat % r03 ( k , 21 ) - rdat % r02 ( m , 27 ) enddo j = 1 k = ind ( j , 4 , 2 ) m = in6 ( k ) do i = 1 , 5 d1 ( i , 4 , 2 ) =+ rdat % r02 ( m , i + 31 ) - rdat % r01 ( j , i + 30 ) enddo do j = 1 , 10 k = ind ( j , 1 , 3 ) d4 ( j , 1 , 3 ) =- rdat % r04 ( k , 3 ) enddo do j = 1 , 6 k = ind ( j , 1 , 3 ) d3 ( 1 , j , 1 , 3 ) =- rdat % r03 ( k , 12 ) d3 ( 2 , j , 1 , 3 ) =- rdat % r03 ( k , 13 ) d3 ( 3 , j , 1 , 3 ) =- rdat % r03 ( k , 14 ) enddo do j = 1 , 3 k = ind ( j , 1 , 3 ) m = in6 ( k ) d2 ( 1 , j , 1 , 3 ) =- rdat % r02 ( m , 20 ) d2 ( 2 , j , 1 , 3 ) =- rdat % r02 ( m , 21 ) d2 ( 3 , j , 1 , 3 ) =- rdat % r02 ( m , 22 ) d2 ( 4 , j , 1 , 3 ) =- rdat % r02 ( m , 23 ) enddo j = 1 k = ind ( j , 1 , 3 ) do i = 1 , 5 d1 ( i , 1 , 3 ) =- rdat % r01 ( k , i + 25 ) enddo do j = 1 , 10 k = ind ( j , 3 , 3 ) d4 ( j , 3 , 3 ) =+ rdat % r05 ( k , 1 ) + rdat % r03 ( j , 5 ) enddo do j = 1 , 6 k = ind ( j , 3 , 3 ) m = in6 ( j ) d3 ( 1 , j , 3 , 3 ) =+ rdat % r04 ( k , 5 ) + rdat % r02 ( m , 13 ) d3 ( 2 , j , 3 , 3 ) =+ rdat % r04 ( k , 6 ) + rdat % r02 ( m , 14 ) d3 ( 3 , j , 3 , 3 ) =+ rdat % r04 ( k , 7 ) + rdat % r02 ( m , 15 ) enddo do j = 1 , 3 k = ind ( j , 3 , 3 ) d2 ( 1 , j , 3 , 3 ) =+ rdat % r03 ( k , 18 ) + rdat % r01 ( j , 17 ) d2 ( 2 , j , 3 , 3 ) =+ rdat % r03 ( k , 19 ) + rdat % r01 ( j , 18 ) d2 ( 3 , j , 3 , 3 ) =+ rdat % r03 ( k , 20 ) + rdat % r01 ( j , 19 ) d2 ( 4 , j , 3 , 3 ) =+ rdat % r03 ( k , 21 ) + rdat % r01 ( j , 20 ) enddo j = 1 k = ind ( j , 3 , 3 ) m = in6 ( k ) do i = 1 , 5 d1 ( i , 3 , 3 ) =+ rdat % r02 ( m , i + 31 ) + rdat % r00 ( i , 5 ) enddo d4 ( 1 , 4 , 3 ) =+ rdat % r05 ( 5 , 1 ) - rdat % r04 ( 2 , 4 ) d4 ( 2 , 4 , 3 ) =+ rdat % r05 ( 8 , 1 ) - rdat % r04 ( 4 , 4 ) d4 ( 3 , 4 , 3 ) =+ rdat % r05 ( 9 , 1 ) - rdat % r04 ( 5 , 4 ) d4 ( 4 , 4 , 3 ) =+ rdat % r05 ( 12 , 1 ) - rdat % r04 ( 7 , 4 ) d4 ( 5 , 4 , 3 ) =+ rdat % r05 ( 13 , 1 ) - rdat % r04 ( 8 , 4 ) d4 ( 6 , 4 , 3 ) =+ rdat % r05 ( 14 , 1 ) - rdat % r04 ( 9 , 4 ) d4 ( 7 , 4 , 3 ) =+ rdat % r05 ( 17 , 1 ) - rdat % r04 ( 11 , 4 ) d4 ( 8 , 4 , 3 ) =+ rdat % r05 ( 18 , 1 ) - rdat % r04 ( 12 , 4 ) d4 ( 9 , 4 , 3 ) =+ rdat % r05 ( 19 , 1 ) - rdat % r04 ( 13 , 4 ) d4 ( 10 , 4 , 3 ) =+ rdat % r05 ( 20 , 1 ) - rdat % r04 ( 14 , 4 ) d3 ( 1 , 1 , 4 , 3 ) =+ rdat % r04 ( 5 , 5 ) - rdat % r03 ( 2 , 15 ) d3 ( 2 , 1 , 4 , 3 ) =+ rdat % r04 ( 5 , 6 ) - rdat % r03 ( 2 , 16 ) d3 ( 3 , 1 , 4 , 3 ) =+ rdat % r04 ( 5 , 7 ) - rdat % r03 ( 2 , 17 ) d3 ( 1 , 2 , 4 , 3 ) =+ rdat % r04 ( 8 , 5 ) - rdat % r03 ( 4 , 15 ) d3 ( 2 , 2 , 4 , 3 ) =+ rdat % r04 ( 8 , 6 ) - rdat % r03 ( 4 , 16 ) d3 ( 3 , 2 , 4 , 3 ) =+ rdat % r04 ( 8 , 7 ) - rdat % r03 ( 4 , 17 ) d3 ( 1 , 3 , 4 , 3 ) =+ rdat % r04 ( 9 , 5 ) - rdat % r03 ( 5 , 15 ) d3 ( 2 , 3 , 4 , 3 ) =+ rdat % r04 ( 9 , 6 ) - rdat % r03 ( 5 , 16 ) d3 ( 3 , 3 , 4 , 3 ) =+ rdat % r04 ( 9 , 7 ) - rdat % r03 ( 5 , 17 ) d3 ( 1 , 4 , 4 , 3 ) =+ rdat % r04 ( 12 , 5 ) - rdat % r03 ( 7 , 15 ) d3 ( 2 , 4 , 4 , 3 ) =+ rdat % r04 ( 12 , 6 ) - rdat % r03 ( 7 , 16 ) d3 ( 3 , 4 , 4 , 3 ) =+ rdat % r04 ( 12 , 7 ) - rdat % r03 ( 7 , 17 ) d3 ( 1 , 5 , 4 , 3 ) =+ rdat % r04 ( 13 , 5 ) - rdat % r03 ( 8 , 15 ) d3 ( 2 , 5 , 4 , 3 ) =+ rdat % r04 ( 13 , 6 ) - rdat % r03 ( 8 , 16 ) d3 ( 3 , 5 , 4 , 3 ) =+ rdat % r04 ( 13 , 7 ) - rdat % r03 ( 8 , 17 ) d3 ( 1 , 6 , 4 , 3 ) =+ rdat % r04 ( 14 , 5 ) - rdat % r03 ( 9 , 15 ) d3 ( 2 , 6 , 4 , 3 ) =+ rdat % r04 ( 14 , 6 ) - rdat % r03 ( 9 , 16 ) d3 ( 3 , 6 , 4 , 3 ) =+ rdat % r04 ( 14 , 7 ) - rdat % r03 ( 9 , 17 ) d2 ( 1 , 1 , 4 , 3 ) =+ rdat % r03 ( 5 , 18 ) - rdat % r02 ( 4 , 24 ) d2 ( 2 , 1 , 4 , 3 ) =+ rdat % r03 ( 5 , 19 ) - rdat % r02 ( 4 , 25 ) d2 ( 3 , 1 , 4 , 3 ) =+ rdat % r03 ( 5 , 20 ) - rdat % r02 ( 4 , 26 ) d2 ( 4 , 1 , 4 , 3 ) =+ rdat % r03 ( 5 , 21 ) - rdat % r02 ( 4 , 27 ) d2 ( 1 , 2 , 4 , 3 ) =+ rdat % r03 ( 8 , 18 ) - rdat % r02 ( 2 , 24 ) d2 ( 2 , 2 , 4 , 3 ) =+ rdat % r03 ( 8 , 19 ) - rdat % r02 ( 2 , 25 ) d2 ( 3 , 2 , 4 , 3 ) =+ rdat % r03 ( 8 , 20 ) - rdat % r02 ( 2 , 26 ) d2 ( 4 , 2 , 4 , 3 ) =+ rdat % r03 ( 8 , 21 ) - rdat % r02 ( 2 , 27 ) d2 ( 1 , 3 , 4 , 3 ) =+ rdat % r03 ( 9 , 18 ) - rdat % r02 ( 6 , 24 ) d2 ( 2 , 3 , 4 , 3 ) =+ rdat % r03 ( 9 , 19 ) - rdat % r02 ( 6 , 25 ) d2 ( 3 , 3 , 4 , 3 ) =+ rdat % r03 ( 9 , 20 ) - rdat % r02 ( 6 , 26 ) d2 ( 4 , 3 , 4 , 3 ) =+ rdat % r03 ( 9 , 21 ) - rdat % r02 ( 6 , 27 ) do i = 1 , 5 d1 ( i , 4 , 3 ) =+ rdat % r02 ( 6 , i + 31 ) - rdat % r01 ( 2 , i + 30 ) enddo do j = 1 , 10 k = ind ( j , 1 , 4 ) d4 ( j , 1 , 4 ) =- rdat % r04 ( k , 3 ) + rdat % r03 ( j , 3 ) enddo do j = 1 , 6 k = ind ( j , 1 , 4 ) m = in6 ( j ) d3 ( 1 , j , 1 , 4 ) =- rdat % r03 ( k , 12 ) + rdat % r02 ( m , 7 ) d3 ( 2 , j , 1 , 4 ) =- rdat % r03 ( k , 13 ) + rdat % r02 ( m , 8 ) d3 ( 3 , j , 1 , 4 ) =- rdat % r03 ( k , 14 ) + rdat % r02 ( m , 9 ) enddo do j = 1 , 3 k = ind ( j , 1 , 4 ) m = in6 ( k ) d2 ( 1 , j , 1 , 4 ) =- rdat % r02 ( m , 20 ) + rdat % r01 ( j , 9 ) d2 ( 2 , j , 1 , 4 ) =- rdat % r02 ( m , 21 ) + rdat % r01 ( j , 10 ) d2 ( 3 , j , 1 , 4 ) =- rdat % r02 ( m , 22 ) + rdat % r01 ( j , 11 ) d2 ( 4 , j , 1 , 4 ) =- rdat % r02 ( m , 23 ) + rdat % r01 ( j , 12 ) enddo j = 1 k = ind ( j , 1 , 4 ) do i = 1 , 5 d1 ( i , 1 , 4 ) =- rdat % r01 ( k , i + 25 ) + rdat % r00 ( i , 3 ) enddo do j = 1 , 10 k = ind ( j , 2 , 4 ) d4 ( j , 2 , 4 ) =+ rdat % r05 ( k , 1 ) - rdat % r04 ( j , 1 ) enddo do j = 1 , 6 k = ind ( j , 2 , 4 ) d3 ( 1 , j , 2 , 4 ) =+ rdat % r04 ( k , 5 ) - rdat % r03 ( j , 6 ) d3 ( 2 , j , 2 , 4 ) =+ rdat % r04 ( k , 6 ) - rdat % r03 ( j , 7 ) d3 ( 3 , j , 2 , 4 ) =+ rdat % r04 ( k , 7 ) - rdat % r03 ( j , 8 ) enddo do j = 1 , 3 k = ind ( j , 2 , 4 ) m = in6 ( j ) d2 ( 1 , j , 2 , 4 ) =+ rdat % r03 ( k , 18 ) - rdat % r02 ( m , 28 ) d2 ( 2 , j , 2 , 4 ) =+ rdat % r03 ( k , 19 ) - rdat % r02 ( m , 29 ) d2 ( 3 , j , 2 , 4 ) =+ rdat % r03 ( k , 20 ) - rdat % r02 ( m , 30 ) d2 ( 4 , j , 2 , 4 ) =+ rdat % r03 ( k , 21 ) - rdat % r02 ( m , 31 ) enddo j = 1 k = ind ( j , 2 , 4 ) m = in6 ( k ) do i = 1 , 5 d1 ( i , 2 , 4 ) =+ rdat % r02 ( m , i + 31 ) - rdat % r01 ( j , i + 35 ) enddo d4 ( 1 , 3 , 4 ) =+ rdat % r05 ( 5 , 1 ) - rdat % r04 ( 2 , 1 ) d4 ( 2 , 3 , 4 ) =+ rdat % r05 ( 8 , 1 ) - rdat % r04 ( 4 , 1 ) d4 ( 3 , 3 , 4 ) =+ rdat % r05 ( 9 , 1 ) - rdat % r04 ( 5 , 1 ) d4 ( 4 , 3 , 4 ) =+ rdat % r05 ( 12 , 1 ) - rdat % r04 ( 7 , 1 ) d4 ( 5 , 3 , 4 ) =+ rdat % r05 ( 13 , 1 ) - rdat % r04 ( 8 , 1 ) d4 ( 6 , 3 , 4 ) =+ rdat % r05 ( 14 , 1 ) - rdat % r04 ( 9 , 1 ) d4 ( 7 , 3 , 4 ) =+ rdat % r05 ( 17 , 1 ) - rdat % r04 ( 11 , 1 ) d4 ( 8 , 3 , 4 ) =+ rdat % r05 ( 18 , 1 ) - rdat % r04 ( 12 , 1 ) d4 ( 9 , 3 , 4 ) =+ rdat % r05 ( 19 , 1 ) - rdat % r04 ( 13 , 1 ) d4 ( 10 , 3 , 4 ) =+ rdat % r05 ( 20 , 1 ) - rdat % r04 ( 14 , 1 ) d3 ( 1 , 1 , 3 , 4 ) =+ rdat % r04 ( 5 , 5 ) - rdat % r03 ( 2 , 6 ) d3 ( 2 , 1 , 3 , 4 ) =+ rdat % r04 ( 5 , 6 ) - rdat % r03 ( 2 , 7 ) d3 ( 3 , 1 , 3 , 4 ) =+ rdat % r04 ( 5 , 7 ) - rdat % r03 ( 2 , 8 ) d3 ( 1 , 2 , 3 , 4 ) =+ rdat % r04 ( 8 , 5 ) - rdat % r03 ( 4 , 6 ) d3 ( 2 , 2 , 3 , 4 ) =+ rdat % r04 ( 8 , 6 ) - rdat % r03 ( 4 , 7 ) d3 ( 3 , 2 , 3 , 4 ) =+ rdat % r04 ( 8 , 7 ) - rdat % r03 ( 4 , 8 ) d3 ( 1 , 3 , 3 , 4 ) =+ rdat % r04 ( 9 , 5 ) - rdat % r03 ( 5 , 6 ) d3 ( 2 , 3 , 3 , 4 ) =+ rdat % r04 ( 9 , 6 ) - rdat % r03 ( 5 , 7 ) d3 ( 3 , 3 , 3 , 4 ) =+ rdat % r04 ( 9 , 7 ) - rdat % r03 ( 5 , 8 ) d3 ( 1 , 4 , 3 , 4 ) =+ rdat % r04 ( 12 , 5 ) - rdat % r03 ( 7 , 6 ) d3 ( 2 , 4 , 3 , 4 ) =+ rdat % r04 ( 12 , 6 ) - rdat % r03 ( 7 , 7 ) d3 ( 3 , 4 , 3 , 4 ) =+ rdat % r04 ( 12 , 7 ) - rdat % r03 ( 7 , 8 ) d3 ( 1 , 5 , 3 , 4 ) =+ rdat % r04 ( 13 , 5 ) - rdat % r03 ( 8 , 6 ) d3 ( 2 , 5 , 3 , 4 ) =+ rdat % r04 ( 13 , 6 ) - rdat % r03 ( 8 , 7 ) d3 ( 3 , 5 , 3 , 4 ) =+ rdat % r04 ( 13 , 7 ) - rdat % r03 ( 8 , 8 ) d3 ( 1 , 6 , 3 , 4 ) =+ rdat % r04 ( 14 , 5 ) - rdat % r03 ( 9 , 6 ) d3 ( 2 , 6 , 3 , 4 ) =+ rdat % r04 ( 14 , 6 ) - rdat % r03 ( 9 , 7 ) d3 ( 3 , 6 , 3 , 4 ) =+ rdat % r04 ( 14 , 7 ) - rdat % r03 ( 9 , 8 ) d2 ( 1 , 1 , 3 , 4 ) =+ rdat % r03 ( 5 , 18 ) - rdat % r02 ( 4 , 28 ) d2 ( 2 , 1 , 3 , 4 ) =+ rdat % r03 ( 5 , 19 ) - rdat % r02 ( 4 , 29 ) d2 ( 3 , 1 , 3 , 4 ) =+ rdat % r03 ( 5 , 20 ) - rdat % r02 ( 4 , 30 ) d2 ( 4 , 1 , 3 , 4 ) =+ rdat % r03 ( 5 , 21 ) - rdat % r02 ( 4 , 31 ) d2 ( 1 , 2 , 3 , 4 ) =+ rdat % r03 ( 8 , 18 ) - rdat % r02 ( 2 , 28 ) d2 ( 2 , 2 , 3 , 4 ) =+ rdat % r03 ( 8 , 19 ) - rdat % r02 ( 2 , 29 ) d2 ( 3 , 2 , 3 , 4 ) =+ rdat % r03 ( 8 , 20 ) - rdat % r02 ( 2 , 30 ) d2 ( 4 , 2 , 3 , 4 ) =+ rdat % r03 ( 8 , 21 ) - rdat % r02 ( 2 , 31 ) d2 ( 1 , 3 , 3 , 4 ) =+ rdat % r03 ( 9 , 18 ) - rdat % r02 ( 6 , 28 ) d2 ( 2 , 3 , 3 , 4 ) =+ rdat % r03 ( 9 , 19 ) - rdat % r02 ( 6 , 29 ) d2 ( 3 , 3 , 3 , 4 ) =+ rdat % r03 ( 9 , 20 ) - rdat % r02 ( 6 , 30 ) d2 ( 4 , 3 , 3 , 4 ) =+ rdat % r03 ( 9 , 21 ) - rdat % r02 ( 6 , 31 ) do i = 1 , 5 d1 ( i , 3 , 4 ) =+ rdat % r02 ( 6 , i + 31 ) - rdat % r01 ( 2 , i + 35 ) enddo d4 ( 1 , 4 , 4 ) =+ rdat % r05 ( 6 , 1 ) - rdat % r04 ( 3 , 1 ) - rdat % r04 ( 3 , 4 ) + rdat % r03 ( 1 , 4 ) + rdat % r03 ( 1 , 5 ) d4 ( 2 , 4 , 4 ) =+ rdat % r05 ( 9 , 1 ) - rdat % r04 ( 5 , 1 ) - rdat % r04 ( 5 , 4 ) + rdat % r03 ( 2 , 4 ) + rdat % r03 ( 2 , 5 ) d4 ( 3 , 4 , 4 ) =+ rdat % r05 ( 10 , 1 ) - rdat % r04 ( 6 , 1 ) - rdat % r04 ( 6 , 4 ) + rdat % r03 ( 3 , 4 ) + rdat % r03 ( 3 , 5 ) d4 ( 4 , 4 , 4 ) =+ rdat % r05 ( 13 , 1 ) - rdat % r04 ( 8 , 1 ) - rdat % r04 ( 8 , 4 ) + rdat % r03 ( 4 , 4 ) + rdat % r03 ( 4 , 5 ) d4 ( 5 , 4 , 4 ) =+ rdat % r05 ( 14 , 1 ) - rdat % r04 ( 9 , 1 ) - rdat % r04 ( 9 , 4 ) + rdat % r03 ( 5 , 4 ) + rdat % r03 ( 5 , 5 ) d4 ( 6 , 4 , 4 ) =+ rdat % r05 ( 15 , 1 ) - rdat % r04 ( 10 , 1 ) - rdat % r04 ( 10 , 4 ) + rdat % r03 ( 6 , 4 ) + rdat % r03 ( 6 , 5 ) d4 ( 7 , 4 , 4 ) =+ rdat % r05 ( 18 , 1 ) - rdat % r04 ( 12 , 1 ) - rdat % r04 ( 12 , 4 ) + rdat % r03 ( 7 , 4 ) + rdat % r03 ( 7 , 5 ) d4 ( 8 , 4 , 4 ) =+ rdat % r05 ( 19 , 1 ) - rdat % r04 ( 13 , 1 ) - rdat % r04 ( 13 , 4 ) + rdat % r03 ( 8 , 4 ) + rdat % r03 ( 8 , 5 ) d4 ( 9 , 4 , 4 ) =+ rdat % r05 ( 20 , 1 ) - rdat % r04 ( 14 , 1 ) - rdat % r04 ( 14 , 4 ) + rdat % r03 ( 9 , 4 ) + rdat % r03 ( 9 , 5 ) d4 ( 10 , 4 , 4 ) =+ rdat % r05 ( 21 , 1 ) - rdat % r04 ( 15 , 1 ) - rdat % r04 ( 15 , 4 ) + rdat % r03 ( 10 , 4 ) + rdat % r03 ( 10 , 5 ) d3 ( 1 , 1 , 4 , 4 ) =+ rdat % r04 ( 6 , 5 ) - rdat % r03 ( 3 , 6 ) - rdat % r03 ( 3 , 15 ) + rdat % r02 ( 1 , 10 ) + rdat % r02 ( 1 , 13 ) d3 ( 2 , 1 , 4 , 4 ) =+ rdat % r04 ( 6 , 6 ) - rdat % r03 ( 3 , 7 ) - rdat % r03 ( 3 , 16 ) + rdat % r02 ( 1 , 11 ) + rdat % r02 ( 1 , 14 ) d3 ( 3 , 1 , 4 , 4 ) =+ rdat % r04 ( 6 , 7 ) - rdat % r03 ( 3 , 8 ) - rdat % r03 ( 3 , 17 ) + rdat % r02 ( 1 , 12 ) + rdat % r02 ( 1 , 15 ) d3 ( 1 , 2 , 4 , 4 ) =+ rdat % r04 ( 9 , 5 ) - rdat % r03 ( 5 , 6 ) - rdat % r03 ( 5 , 15 ) + rdat % r02 ( 4 , 10 ) + rdat % r02 ( 4 , 13 ) d3 ( 2 , 2 , 4 , 4 ) =+ rdat % r04 ( 9 , 6 ) - rdat % r03 ( 5 , 7 ) - rdat % r03 ( 5 , 16 ) + rdat % r02 ( 4 , 11 ) + rdat % r02 ( 4 , 14 ) d3 ( 3 , 2 , 4 , 4 ) =+ rdat % r04 ( 9 , 7 ) - rdat % r03 ( 5 , 8 ) - rdat % r03 ( 5 , 17 ) + rdat % r02 ( 4 , 12 ) + rdat % r02 ( 4 , 15 ) d3 ( 1 , 3 , 4 , 4 ) =+ rdat % r04 ( 10 , 5 ) - rdat % r03 ( 6 , 6 ) - rdat % r03 ( 6 , 15 ) + rdat % r02 ( 5 , 10 ) + rdat % r02 ( 5 , 13 ) d3 ( 2 , 3 , 4 , 4 ) =+ rdat % r04 ( 10 , 6 ) - rdat % r03 ( 6 , 7 ) - rdat % r03 ( 6 , 16 ) + rdat % r02 ( 5 , 11 ) + rdat % r02 ( 5 , 14 ) d3 ( 3 , 3 , 4 , 4 ) =+ rdat % r04 ( 10 , 7 ) - rdat % r03 ( 6 , 8 ) - rdat % r03 ( 6 , 17 ) + rdat % r02 ( 5 , 12 ) + rdat % r02 ( 5 , 15 ) d3 ( 1 , 4 , 4 , 4 ) =+ rdat % r04 ( 13 , 5 ) - rdat % r03 ( 8 , 6 ) - rdat % r03 ( 8 , 15 ) + rdat % r02 ( 2 , 10 ) + rdat % r02 ( 2 , 13 ) d3 ( 2 , 4 , 4 , 4 ) =+ rdat % r04 ( 13 , 6 ) - rdat % r03 ( 8 , 7 ) - rdat % r03 ( 8 , 16 ) + rdat % r02 ( 2 , 11 ) + rdat % r02 ( 2 , 14 ) d3 ( 3 , 4 , 4 , 4 ) =+ rdat % r04 ( 13 , 7 ) - rdat % r03 ( 8 , 8 ) - rdat % r03 ( 8 , 17 ) + rdat % r02 ( 2 , 12 ) + rdat % r02 ( 2 , 15 ) d3 ( 1 , 5 , 4 , 4 ) =+ rdat % r04 ( 14 , 5 ) - rdat % r03 ( 9 , 6 ) - rdat % r03 ( 9 , 15 ) + rdat % r02 ( 6 , 10 ) + rdat % r02 ( 6 , 13 ) d3 ( 2 , 5 , 4 , 4 ) =+ rdat % r04 ( 14 , 6 ) - rdat % r03 ( 9 , 7 ) - rdat % r03 ( 9 , 16 ) + rdat % r02 ( 6 , 11 ) + rdat % r02 ( 6 , 14 ) d3 ( 3 , 5 , 4 , 4 ) =+ rdat % r04 ( 14 , 7 ) - rdat % r03 ( 9 , 8 ) - rdat % r03 ( 9 , 17 ) + rdat % r02 ( 6 , 12 ) + rdat % r02 ( 6 , 15 ) d3 ( 1 , 6 , 4 , 4 ) =+ rdat % r04 ( 15 , 5 ) - rdat % r03 ( 10 , 6 ) - rdat % r03 ( 10 , 15 ) + rdat % r02 ( 3 , 10 ) + rdat % r02 ( 3 , 13 ) d3 ( 2 , 6 , 4 , 4 ) =+ rdat % r04 ( 15 , 6 ) - rdat % r03 ( 10 , 7 ) - rdat % r03 ( 10 , 16 ) + rdat % r02 ( 3 , 11 ) + rdat % r02 ( 3 , 14 ) d3 ( 3 , 6 , 4 , 4 ) =+ rdat % r04 ( 15 , 7 ) - rdat % r03 ( 10 , 8 ) - rdat % r03 ( 10 , 17 ) + rdat % r02 ( 3 , 12 ) + rdat % r02 ( 3 , 15 ) d2 ( 1 , 1 , 4 , 4 ) =+ rdat % r03 ( 6 , 18 ) - rdat % r02 ( 5 , 24 ) - rdat % r02 ( 5 , 28 ) + rdat % r01 ( 1 , 13 ) + rdat % r01 ( 1 , 17 ) d2 ( 2 , 1 , 4 , 4 ) =+ rdat % r03 ( 6 , 19 ) - rdat % r02 ( 5 , 25 ) - rdat % r02 ( 5 , 29 ) + rdat % r01 ( 1 , 14 ) + rdat % r01 ( 1 , 18 ) d2 ( 3 , 1 , 4 , 4 ) =+ rdat % r03 ( 6 , 20 ) - rdat % r02 ( 5 , 26 ) - rdat % r02 ( 5 , 30 ) + rdat % r01 ( 1 , 15 ) + rdat % r01 ( 1 , 19 ) d2 ( 4 , 1 , 4 , 4 ) =+ rdat % r03 ( 6 , 21 ) - rdat % r02 ( 5 , 27 ) - rdat % r02 ( 5 , 31 ) + rdat % r01 ( 1 , 16 ) + rdat % r01 ( 1 , 20 ) d2 ( 1 , 2 , 4 , 4 ) =+ rdat % r03 ( 9 , 18 ) - rdat % r02 ( 6 , 24 ) - rdat % r02 ( 6 , 28 ) + rdat % r01 ( 2 , 13 ) + rdat % r01 ( 2 , 17 ) d2 ( 2 , 2 , 4 , 4 ) =+ rdat % r03 ( 9 , 19 ) - rdat % r02 ( 6 , 25 ) - rdat % r02 ( 6 , 29 ) + rdat % r01 ( 2 , 14 ) + rdat % r01 ( 2 , 18 ) d2 ( 3 , 2 , 4 , 4 ) =+ rdat % r03 ( 9 , 20 ) - rdat % r02 ( 6 , 26 ) - rdat % r02 ( 6 , 30 ) + rdat % r01 ( 2 , 15 ) + rdat % r01 ( 2 , 19 ) d2 ( 4 , 2 , 4 , 4 ) =+ rdat % r03 ( 9 , 21 ) - rdat % r02 ( 6 , 27 ) - rdat % r02 ( 6 , 31 ) + rdat % r01 ( 2 , 16 ) + rdat % r01 ( 2 , 20 ) d2 ( 1 , 3 , 4 , 4 ) =+ rdat % r03 ( 10 , 18 ) - rdat % r02 ( 3 , 24 ) - rdat % r02 ( 3 , 28 ) + rdat % r01 ( 3 , 13 ) + rdat % r01 ( 3 , 17 ) d2 ( 2 , 3 , 4 , 4 ) =+ rdat % r03 ( 10 , 19 ) - rdat % r02 ( 3 , 25 ) - rdat % r02 ( 3 , 29 ) + rdat % r01 ( 3 , 14 ) + rdat % r01 ( 3 , 18 ) d2 ( 3 , 3 , 4 , 4 ) =+ rdat % r03 ( 10 , 20 ) - rdat % r02 ( 3 , 26 ) - rdat % r02 ( 3 , 30 ) + rdat % r01 ( 3 , 15 ) + rdat % r01 ( 3 , 19 ) d2 ( 4 , 3 , 4 , 4 ) =+ rdat % r03 ( 10 , 21 ) - rdat % r02 ( 3 , 27 ) - rdat % r02 ( 3 , 31 ) + rdat % r01 ( 3 , 16 ) + rdat % r01 ( 3 , 20 ) do i = 1 , 5 d1 ( i , 4 , 4 ) =+ rdat % r02 ( 3 , i + 31 ) - rdat % r01 ( 3 , i + 30 ) - rdat % r01 ( 3 , i + 35 ) + rdat % r00 ( i , 4 ) + rdat % r00 ( i , 5 ) enddo xx = qx * qx zz = qz * qz xz = qx * qz xxx = xx * qx xxz = xx * qz xzz = zz * qx zzz = zz * qz qxd = qx + qx qzd = qz + qz xzd = xz + xz do l = 2 , lx do k = 2 , kx if ( k == 2 . and . l == 3 ) cycle f ( 1 , 1 , k - 1 , l - 1 ) = d4 ( 1 , k , l ) + d2 ( 2 , 1 , k , l ) * 3 + ( + d3 ( 2 , 1 , k , l ) * 2 + d3 ( 3 , 1 , k , l ) + d1 ( 3 , k , l ) * 2 + d1 ( 4 , k , l )) * qx + ( + d2 ( 3 , 1 , k , l ) + d2 ( 4 , 1 , k , l ) * 2 ) * xx + d1 ( 5 , k , l ) * xxx f ( 2 , 1 , k - 1 , l - 1 ) = d4 ( 4 , k , l ) + d2 ( 2 , 1 , k , l ) + ( + d3 ( 3 , 4 , k , l ) + d1 ( 4 , k , l )) * qx f ( 3 , 1 , k - 1 , l - 1 ) = d4 ( 6 , k , l ) + d2 ( 2 , 1 , k , l ) + ( + d3 ( 3 , 6 , k , l ) + d1 ( 4 , k , l )) * qx + d3 ( 2 , 3 , k , l ) * qzd + d2 ( 4 , 3 , k , l ) * xzd + d2 ( 3 , 1 , k , l ) * zz + d1 ( 5 , k , l ) * xzz f ( 4 , 1 , k - 1 , l - 1 ) = d4 ( 2 , k , l ) + d2 ( 2 , 2 , k , l ) + ( + d3 ( 2 , 2 , k , l ) + d3 ( 3 , 2 , k , l )) * qx + d2 ( 4 , 2 , k , l ) * xx f ( 5 , 1 , k - 1 , l - 1 ) = d4 ( 3 , k , l ) + d2 ( 2 , 3 , k , l ) + ( + d3 ( 2 , 3 , k , l ) + d3 ( 3 , 3 , k , l )) * qx + ( + d3 ( 2 , 1 , k , l ) + d1 ( 3 , k , l )) * qz + d2 ( 4 , 3 , k , l ) * xx + ( + d2 ( 3 , 1 , k , l ) + d2 ( 4 , 1 , k , l )) * xz + d1 ( 5 , k , l ) * xxz f ( 6 , 1 , k - 1 , l - 1 ) = d4 ( 5 , k , l ) + d3 ( 3 , 5 , k , l ) * qx + d3 ( 2 , 2 , k , l ) * qz + d2 ( 4 , 2 , k , l ) * xz f ( 1 , 2 , k - 1 , l - 1 ) = d4 ( 2 , k , l ) + d2 ( 2 , 2 , k , l ) + d3 ( 2 , 2 , k , l ) * qxd + d2 ( 3 , 2 , k , l ) * xx f ( 2 , 2 , k - 1 , l - 1 ) = d4 ( 7 , k , l ) + d2 ( 2 , 2 , k , l ) * 3 f ( 3 , 2 , k - 1 , l - 1 ) = d4 ( 9 , k , l ) + d2 ( 2 , 2 , k , l ) + d3 ( 2 , 5 , k , l ) * qzd + d2 ( 3 , 2 , k , l ) * zz f ( 4 , 2 , k - 1 , l - 1 ) = d4 ( 4 , k , l ) + d2 ( 2 , 1 , k , l ) + ( + d3 ( 2 , 4 , k , l ) + d1 ( 3 , k , l )) * qx f ( 5 , 2 , k - 1 , l - 1 ) = d4 ( 5 , k , l ) + d3 ( 2 , 5 , k , l ) * qx + d3 ( 2 , 2 , k , l ) * qz + d2 ( 3 , 2 , k , l ) * xz f ( 6 , 2 , k - 1 , l - 1 ) = d4 ( 8 , k , l ) + d2 ( 2 , 3 , k , l ) + ( + d3 ( 2 , 4 , k , l ) + d1 ( 3 , k , l )) * qz f ( 1 , 3 , k - 1 , l - 1 ) = d4 ( 3 , k , l ) + d2 ( 2 , 3 , k , l ) + d3 ( 2 , 3 , k , l ) * qxd + ( + d3 ( 3 , 1 , k , l ) + d1 ( 4 , k , l )) * qz + d2 ( 3 , 3 , k , l ) * xx + d2 ( 4 , 1 , k , l ) * xzd + d1 ( 5 , k , l ) * xxz f ( 2 , 3 , k - 1 , l - 1 ) = d4 ( 8 , k , l ) + d2 ( 2 , 3 , k , l ) + ( + d3 ( 3 , 4 , k , l ) + d1 ( 4 , k , l )) * qz f ( 3 , 3 , k - 1 , l - 1 ) = d4 ( 10 , k , l ) + d2 ( 2 , 3 , k , l ) * 3 + ( + d3 ( 2 , 6 , k , l ) * 2 + d3 ( 3 , 6 , k , l ) + d1 ( 3 , k , l ) * 2 + d1 ( 4 , k , l )) * qz + ( + d2 ( 3 , 3 , k , l ) + d2 ( 4 , 3 , k , l ) * 2 ) * zz + d1 ( 5 , k , l ) * zzz f ( 4 , 3 , k - 1 , l - 1 ) = d4 ( 5 , k , l ) + d3 ( 2 , 5 , k , l ) * qx + d3 ( 3 , 2 , k , l ) * qz + d2 ( 4 , 2 , k , l ) * xz f ( 5 , 3 , k - 1 , l - 1 ) = d4 ( 6 , k , l ) + d2 ( 2 , 1 , k , l ) + ( + d3 ( 2 , 6 , k , l ) + d1 ( 3 , k , l )) * qx + ( + d3 ( 2 , 3 , k , l ) + d3 ( 3 , 3 , k , l )) * qz + ( + d2 ( 3 , 3 , k , l ) + d2 ( 4 , 3 , k , l )) * xz + d2 ( 4 , 1 , k , l ) * zz + d1 ( 5 , k , l ) * xzz f ( 6 , 3 , k - 1 , l - 1 ) = d4 ( 9 , k , l ) + d2 ( 2 , 2 , k , l ) + ( + d3 ( 2 , 5 , k , l ) + d3 ( 3 , 5 , k , l )) * qz + d2 ( 4 , 2 , k , l ) * zz enddo enddo f (:,:, 1 , 2 ) = f (:,:, 2 , 1 ) end subroutine mcdv_16 ! > ! >    @brief   ddds case ! > ! >    @details integration of a ddds case ! > subroutine mcdv_17 ( f , rdat , qx , qz ) implicit none type ( rotaxis_data_t ) :: rdat real ( kind = dp ) :: f ( 6 , 6 , 6 , * ) real ( kind = dp ) :: qx , qz integer , parameter :: kx = 6 , lx = 1 real ( kind = dp ) :: e1 ( 5 , kx , lx ), e2 ( 4 , 3 , kx , lx ), e3 ( 4 , 6 , kx , lx ), & e4 ( 2 , 10 , kx , lx ), e5 ( 15 , kx , lx ) integer , parameter :: ind ( 15 , kx , lx ) = reshape (& [ 1 , 2 , 3 , 4 , 5 , 6 , 7 , 8 , 9 , 10 , 11 , 12 , 13 , 14 , 15 , 4 , 7 , 8 , 11 , & 12 , 13 , 16 , 17 , 18 , 19 , 22 , 23 , 24 , 25 , 26 , 6 , 9 , 10 , 13 , 14 , & 15 , 18 , 19 , 20 , 21 , 24 , 25 , 26 , 27 , 28 , 2 , 4 , 5 , 7 , 8 , 9 , 11 , & 12 , 13 , 14 , 16 , 17 , 18 , 19 , 20 , 3 , 5 , 6 , 8 , 9 , 10 , 12 , 13 , 14 , & 15 , 17 , 18 , 19 , 20 , 21 , 5 , 8 , 9 , 12 , 13 , 14 , 17 , 18 , 19 , 20 , 23 , & 24 , 25 , 26 , 27 ] & , shape ( ind )) integer :: i , j , k , l , m , ii , jj real ( kind = dp ) :: xx , zz , xz , xxx , xxz , xzz , zzz real ( kind = dp ) :: xxxx , xxzz , xxxz , xzzz , zzzz real ( kind = dp ) :: xxxd , xxzd , xzzd , zzzd real ( kind = dp ) :: xzq real ( kind = dp ) :: qxd , qzd , xzd do j = 1 , 15 e5 ( j , 1 , 1 ) =+ rdat % r06 ( j , 1 ) + rdat % r04 ( j , 1 ) enddo do j = 1 , 10 e4 ( 1 , j , 1 , 1 ) =+ rdat % r05 ( j , 2 ) + rdat % r03 ( j , 1 ) e4 ( 2 , j , 1 , 1 ) =+ rdat % r05 ( j , 3 ) + rdat % r03 ( j , 2 ) enddo do j = 1 , 6 m = in6 ( j ) e3 ( 1 , j , 1 , 1 ) =+ rdat % r04 ( j , 5 ) + rdat % r02 ( m , 1 ) e3 ( 2 , j , 1 , 1 ) =+ rdat % r04 ( j , 6 ) + rdat % r02 ( m , 2 ) e3 ( 3 , j , 1 , 1 ) =+ rdat % r04 ( j , 7 ) + rdat % r02 ( m , 3 ) e3 ( 4 , j , 1 , 1 ) =+ rdat % r04 ( j , 8 ) + rdat % r02 ( m , 4 ) enddo do j = 1 , 3 e2 ( 1 , j , 1 , 1 ) =+ rdat % r03 ( j , 9 ) + rdat % r01 ( j , 1 ) e2 ( 2 , j , 1 , 1 ) =+ rdat % r03 ( j , 10 ) + rdat % r01 ( j , 2 ) e2 ( 3 , j , 1 , 1 ) =+ rdat % r03 ( j , 11 ) + rdat % r01 ( j , 3 ) e2 ( 4 , j , 1 , 1 ) =+ rdat % r03 ( j , 12 ) + rdat % r01 ( j , 4 ) enddo j = 1 do i = 1 , 5 e1 ( i , 1 , 1 ) =+ rdat % r02 ( j , i + 12 ) + rdat % r00 ( i , 1 ) enddo do j = 1 , 15 k = ind ( j , 2 , 1 ) e5 ( j , 2 , 1 ) =+ rdat % r06 ( k , 1 ) + rdat % r04 ( j , 1 ) enddo do j = 1 , 10 k = ind ( j , 2 , 1 ) e4 ( 1 , j , 2 , 1 ) =+ rdat % r05 ( k , 2 ) + rdat % r03 ( j , 1 ) e4 ( 2 , j , 2 , 1 ) =+ rdat % r05 ( k , 3 ) + rdat % r03 ( j , 2 ) enddo do j = 1 , 6 k = ind ( j , 2 , 1 ) m = in6 ( j ) e3 ( 1 , j , 2 , 1 ) =+ rdat % r04 ( k , 5 ) + rdat % r02 ( m , 1 ) e3 ( 2 , j , 2 , 1 ) =+ rdat % r04 ( k , 6 ) + rdat % r02 ( m , 2 ) e3 ( 3 , j , 2 , 1 ) =+ rdat % r04 ( k , 7 ) + rdat % r02 ( m , 3 ) e3 ( 4 , j , 2 , 1 ) =+ rdat % r04 ( k , 8 ) + rdat % r02 ( m , 4 ) enddo do j = 1 , 3 k = ind ( j , 2 , 1 ) e2 ( 1 , j , 2 , 1 ) =+ rdat % r03 ( k , 9 ) + rdat % r01 ( j , 1 ) e2 ( 2 , j , 2 , 1 ) =+ rdat % r03 ( k , 10 ) + rdat % r01 ( j , 2 ) e2 ( 3 , j , 2 , 1 ) =+ rdat % r03 ( k , 11 ) + rdat % r01 ( j , 3 ) e2 ( 4 , j , 2 , 1 ) =+ rdat % r03 ( k , 12 ) + rdat % r01 ( j , 4 ) enddo j = 1 k = ind ( j , 2 , 1 ) m = in6 ( k ) do i = 1 , 5 e1 ( i , 2 , 1 ) =+ rdat % r02 ( m , i + 12 ) + rdat % r00 ( i , 1 ) enddo j = 0 do jj = 1 , 5 do ii = 1 , jj j = j + 1 k = ind ( j , 3 , 1 ) l = k - 2 - jj e5 ( j , 3 , 1 ) =+ rdat % r06 ( k , 1 ) - rdat % r05 ( l , 1 ) * 2 + rdat % r04 ( j , 1 ) + rdat % r04 ( j , 2 ) if ( jj > 4 ) cycle e4 ( 1 , j , 3 , 1 ) =+ rdat % r05 ( k , 2 ) - rdat % r04 ( l , 3 ) * 2 + rdat % r03 ( j , 1 ) + rdat % r03 ( j , 3 ) e4 ( 2 , j , 3 , 1 ) =+ rdat % r05 ( k , 3 ) - rdat % r04 ( l , 4 ) * 2 + rdat % r03 ( j , 2 ) + rdat % r03 ( j , 4 ) if ( jj > 3 ) cycle m = in6 ( j ) do i = 1 , 4 e3 ( i , j , 3 , 1 ) =+ rdat % r04 ( k , i + 4 ) - rdat % r03 ( l , i + 4 ) * 2 + rdat % r02 ( m , i ) + rdat % r02 ( m , i + 4 ) enddo if ( jj > 2 ) cycle m = in6 ( l ) do i = 1 , 4 e2 ( i , j , 3 , 1 ) =+ rdat % r03 ( k , i + 8 ) - rdat % r02 ( m , i + 8 ) * 2 + rdat % r01 ( j , i ) + rdat % r01 ( j , i + 4 ) enddo if ( jj > 1 ) cycle m = in6 ( k ) do i = 1 , 5 e1 ( i , 3 , 1 ) =+ rdat % r02 ( m , i + 12 ) - rdat % r01 ( l , i + 8 ) * 2 + rdat % r00 ( i , 1 ) + rdat % r00 ( i , 2 ) enddo enddo enddo do j = 1 , 15 k = ind ( j , 4 , 1 ) e5 ( j , 4 , 1 ) =+ rdat % r06 ( k , 1 ) enddo do j = 1 , 10 k = ind ( j , 4 , 1 ) e4 ( 1 , j , 4 , 1 ) =+ rdat % r05 ( k , 2 ) e4 ( 2 , j , 4 , 1 ) =+ rdat % r05 ( k , 3 ) enddo do j = 1 , 6 k = ind ( j , 4 , 1 ) e3 ( 1 , j , 4 , 1 ) =+ rdat % r04 ( k , 5 ) e3 ( 2 , j , 4 , 1 ) =+ rdat % r04 ( k , 6 ) e3 ( 3 , j , 4 , 1 ) =+ rdat % r04 ( k , 7 ) e3 ( 4 , j , 4 , 1 ) =+ rdat % r04 ( k , 8 ) enddo do j = 1 , 3 k = ind ( j , 4 , 1 ) e2 ( 1 , j , 4 , 1 ) =+ rdat % r03 ( k , 9 ) e2 ( 2 , j , 4 , 1 ) =+ rdat % r03 ( k , 10 ) e2 ( 3 , j , 4 , 1 ) =+ rdat % r03 ( k , 11 ) e2 ( 4 , j , 4 , 1 ) =+ rdat % r03 ( k , 12 ) enddo j = 1 k = ind ( j , 4 , 1 ) m = in6 ( k ) do i = 1 , 5 e1 ( i , 4 , 1 ) =+ rdat % r02 ( m , i + 12 ) enddo do j = 1 , 15 k = ind ( j , 5 , 1 ) e5 ( j , 5 , 1 ) =+ rdat % r06 ( k , 1 ) - rdat % r05 ( j , 1 ) enddo do j = 1 , 10 k = ind ( j , 5 , 1 ) e4 ( 1 , j , 5 , 1 ) =+ rdat % r05 ( k , 2 ) - rdat % r04 ( j , 3 ) e4 ( 2 , j , 5 , 1 ) =+ rdat % r05 ( k , 3 ) - rdat % r04 ( j , 4 ) enddo do j = 1 , 6 k = ind ( j , 5 , 1 ) e3 ( 1 , j , 5 , 1 ) =+ rdat % r04 ( k , 5 ) - rdat % r03 ( j , 5 ) e3 ( 2 , j , 5 , 1 ) =+ rdat % r04 ( k , 6 ) - rdat % r03 ( j , 6 ) e3 ( 3 , j , 5 , 1 ) =+ rdat % r04 ( k , 7 ) - rdat % r03 ( j , 7 ) e3 ( 4 , j , 5 , 1 ) =+ rdat % r04 ( k , 8 ) - rdat % r03 ( j , 8 ) enddo do j = 1 , 3 k = ind ( j , 5 , 1 ) m = in6 ( j ) e2 ( 1 , j , 5 , 1 ) =+ rdat % r03 ( k , 9 ) - rdat % r02 ( m , 9 ) e2 ( 2 , j , 5 , 1 ) =+ rdat % r03 ( k , 10 ) - rdat % r02 ( m , 10 ) e2 ( 3 , j , 5 , 1 ) =+ rdat % r03 ( k , 11 ) - rdat % r02 ( m , 11 ) e2 ( 4 , j , 5 , 1 ) =+ rdat % r03 ( k , 12 ) - rdat % r02 ( m , 12 ) enddo j = 1 k = ind ( j , 5 , 1 ) m = in6 ( k ) do i = 1 , 5 e1 ( i , 5 , 1 ) =+ rdat % r02 ( m , i + 12 ) - rdat % r01 ( j , i + 8 ) enddo j = 0 do jj = 1 , 5 do ii = 1 , jj j = j + 1 k = ind ( j , 6 , 1 ) l = k - 2 - jj e5 ( j , 6 , 1 ) =+ rdat % r06 ( k , 1 ) - rdat % r05 ( l , 1 ) if ( jj > 4 ) cycle e4 ( 1 , j , 6 , 1 ) =+ rdat % r05 ( k , 2 ) - rdat % r04 ( l , 3 ) e4 ( 2 , j , 6 , 1 ) =+ rdat % r05 ( k , 3 ) - rdat % r04 ( l , 4 ) if ( jj > 3 ) cycle do i = 1 , 4 e3 ( i , j , 6 , 1 ) =+ rdat % r04 ( k , i + 4 ) - rdat % r03 ( l , i + 4 ) enddo if ( jj > 2 ) cycle m = in6 ( l ) do i = 1 , 4 e2 ( i , j , 6 , 1 ) =+ rdat % r03 ( k , i + 8 ) - rdat % r02 ( m , i + 8 ) enddo if ( jj > 1 ) cycle m = in6 ( k ) do i = 1 , 5 e1 ( i , 6 , 1 ) =+ rdat % r02 ( m , i + 12 ) - rdat % r01 ( l , i + 8 ) enddo enddo enddo xx = qx * qx zz = qz * qz xz = qx * qz xxx = xx * qx xxz = xx * qz xzz = zz * qx zzz = zz * qz xxxx = xx * xx xxxz = xx * xz xxzz = xx * zz xzzz = xz * zz zzzz = zz * zz qxd = qx + qx qzd = qz + qz xzd = xz + xz xxxd = xxx + xxx xxzd = xxz + xxz xzzd = xzz + xzz zzzd = zzz + zzz xzq = xz + xz + xz + xz do k = 1 , kx f ( 1 , 1 , k , 1 ) = e5 ( 1 , k , 1 ) + e3 ( 1 , 1 , k , 1 ) * 6 + e1 ( 1 , k , 1 ) * 3 + ( + e4 ( 1 , 1 , k , 1 ) + e4 ( 2 , 1 , k , 1 ) + ( + e2 ( 1 , 1 , k , 1 ) + e2 ( 2 , 1 , k , 1 )) * 3 ) * qxd + ( + e3 ( 2 , 1 , k , 1 ) + e3 ( 3 , 1 , k , 1 ) * 4 + e3 ( 4 , 1 , k , 1 ) + e1 ( 2 , k , 1 ) + e1 ( 3 , k , 1 ) * 4 + e1 ( 4 , k , 1 )) * xx + ( + e2 ( 3 , 1 , k , 1 ) + e2 ( 4 , 1 , k , 1 )) * xxxd + e1 ( 5 , k , 1 ) * xxxx f ( 2 , 1 , k , 1 ) = e5 ( 4 , k , 1 ) + e3 ( 1 , 4 , k , 1 ) + e3 ( 1 , 1 , k , 1 ) + e1 ( 1 , k , 1 ) + ( + e4 ( 2 , 4 , k , 1 ) + e2 ( 2 , 1 , k , 1 )) * qxd + ( + e3 ( 4 , 4 , k , 1 ) + e1 ( 4 , k , 1 )) * xx f ( 3 , 1 , k , 1 ) = e5 ( 6 , k , 1 ) + e3 ( 1 , 6 , k , 1 ) + e3 ( 1 , 1 , k , 1 ) + e1 ( 1 , k , 1 ) + ( + e4 ( 2 , 6 , k , 1 ) + e2 ( 2 , 1 , k , 1 )) * qxd + ( + e4 ( 1 , 3 , k , 1 ) + e2 ( 1 , 3 , k , 1 )) * qzd + ( + e3 ( 4 , 6 , k , 1 ) + e1 ( 4 , k , 1 )) * xx + e3 ( 3 , 3 , k , 1 ) * xzq + ( + e3 ( 2 , 1 , k , 1 ) + e1 ( 2 , k , 1 )) * zz + e2 ( 4 , 3 , k , 1 ) * xxzd + e2 ( 3 , 1 , k , 1 ) * xzzd + e1 ( 5 , k , 1 ) * xxzz f ( 4 , 1 , k , 1 ) = e5 ( 2 , k , 1 ) + e3 ( 1 , 2 , k , 1 ) * 3 + ( + e4 ( 1 , 2 , k , 1 ) + e4 ( 2 , 2 , k , 1 ) * 2 + e2 ( 1 , 2 , k , 1 ) + e2 ( 2 , 2 , k , 1 ) * 2 ) * qx + ( + e3 ( 3 , 2 , k , 1 ) * 2 + e3 ( 4 , 2 , k , 1 )) * xx + e2 ( 4 , 2 , k , 1 ) * xxx f ( 5 , 1 , k , 1 ) = e5 ( 3 , k , 1 ) + e3 ( 1 , 3 , k , 1 ) * 3 + ( + e4 ( 1 , 3 , k , 1 ) + e4 ( 2 , 3 , k , 1 ) * 2 + e2 ( 1 , 3 , k , 1 ) + e2 ( 2 , 3 , k , 1 ) * 2 ) * qx + ( + e4 ( 1 , 1 , k , 1 ) + e2 ( 1 , 1 , k , 1 ) * 3 ) * qz + ( + e3 ( 3 , 3 , k , 1 ) * 2 + e3 ( 4 , 3 , k , 1 )) * xx + ( + e3 ( 2 , 1 , k , 1 ) + e3 ( 3 , 1 , k , 1 ) * 2 + e1 ( 2 , k , 1 ) + e1 ( 3 , k , 1 ) * 2 ) * xz + e2 ( 4 , 3 , k , 1 ) * xxx + ( + e2 ( 3 , 1 , k , 1 ) * 2 + e2 ( 4 , 1 , k , 1 )) * xxz + e1 ( 5 , k , 1 ) * xxxz f ( 6 , 1 , k , 1 ) = e5 ( 5 , k , 1 ) + e3 ( 1 , 5 , k , 1 ) + e4 ( 2 , 5 , k , 1 ) * qxd + ( + e4 ( 1 , 2 , k , 1 ) + e2 ( 1 , 2 , k , 1 )) * qz + e3 ( 4 , 5 , k , 1 ) * xx + e3 ( 3 , 2 , k , 1 ) * xzd + e2 ( 4 , 2 , k , 1 ) * xxz f ( 1 , 2 , k , 1 ) = e5 ( 4 , k , 1 ) + e3 ( 1 , 4 , k , 1 ) + e3 ( 1 , 1 , k , 1 ) + e1 ( 1 , k , 1 ) + ( + e4 ( 1 , 4 , k , 1 ) + e2 ( 1 , 1 , k , 1 )) * qxd + ( + e3 ( 2 , 4 , k , 1 ) + e1 ( 2 , k , 1 )) * xx f ( 2 , 2 , k , 1 ) = e5 ( 11 , k , 1 ) + e3 ( 1 , 4 , k , 1 ) * 6 + e1 ( 1 , k , 1 ) * 3 f ( 3 , 2 , k , 1 ) = e5 ( 13 , k , 1 ) + e3 ( 1 , 6 , k , 1 ) + e3 ( 1 , 4 , k , 1 ) + e1 ( 1 , k , 1 ) + ( + e4 ( 1 , 8 , k , 1 ) + e2 ( 1 , 3 , k , 1 )) * qzd + ( + e3 ( 2 , 4 , k , 1 ) + e1 ( 2 , k , 1 )) * zz f ( 4 , 2 , k , 1 ) = e5 ( 7 , k , 1 ) + e3 ( 1 , 2 , k , 1 ) * 3 + ( + e4 ( 1 , 7 , k , 1 ) + e2 ( 1 , 2 , k , 1 ) * 3 ) * qx f ( 5 , 2 , k , 1 ) = e5 ( 8 , k , 1 ) + e3 ( 1 , 3 , k , 1 ) + ( + e4 ( 1 , 8 , k , 1 ) + e2 ( 1 , 3 , k , 1 )) * qx + ( + e4 ( 1 , 4 , k , 1 ) + e2 ( 1 , 1 , k , 1 )) * qz + ( + e3 ( 2 , 4 , k , 1 ) + e1 ( 2 , k , 1 )) * xz f ( 6 , 2 , k , 1 ) = e5 ( 12 , k , 1 ) + e3 ( 1 , 5 , k , 1 ) * 3 + ( + e4 ( 1 , 7 , k , 1 ) + e2 ( 1 , 2 , k , 1 ) * 3 ) * qz f ( 1 , 3 , k , 1 ) = e5 ( 6 , k , 1 ) + e3 ( 1 , 6 , k , 1 ) + e3 ( 1 , 1 , k , 1 ) + e1 ( 1 , k , 1 ) + ( + e4 ( 1 , 6 , k , 1 ) + e2 ( 1 , 1 , k , 1 )) * qxd + ( + e4 ( 2 , 3 , k , 1 ) + e2 ( 2 , 3 , k , 1 )) * qzd + ( + e3 ( 2 , 6 , k , 1 ) + e1 ( 2 , k , 1 )) * xx + e3 ( 3 , 3 , k , 1 ) * xzq + ( + e3 ( 4 , 1 , k , 1 ) + e1 ( 4 , k , 1 )) * zz + e2 ( 3 , 3 , k , 1 ) * xxzd + e2 ( 4 , 1 , k , 1 ) * xzzd + e1 ( 5 , k , 1 ) * xxzz f ( 2 , 3 , k , 1 ) = e5 ( 13 , k , 1 ) + e3 ( 1 , 6 , k , 1 ) + e3 ( 1 , 4 , k , 1 ) + e1 ( 1 , k , 1 ) + ( + e4 ( 2 , 8 , k , 1 ) + e2 ( 2 , 3 , k , 1 )) * qzd + ( + e3 ( 4 , 4 , k , 1 ) + e1 ( 4 , k , 1 )) * zz f ( 3 , 3 , k , 1 ) = e5 ( 15 , k , 1 ) + e3 ( 1 , 6 , k , 1 ) * 6 + e1 ( 1 , k , 1 ) * 3 + ( + e4 ( 1 , 10 , k , 1 ) + e4 ( 2 , 10 , k , 1 ) + ( + e2 ( 1 , 3 , k , 1 ) + e2 ( 2 , 3 , k , 1 )) * 3 ) * qzd + ( + e3 ( 2 , 6 , k , 1 ) + e3 ( 3 , 6 , k , 1 ) * 4 + e3 ( 4 , 6 , k , 1 ) + e1 ( 2 , k , 1 ) + e1 ( 3 , k , 1 ) * 4 + e1 ( 4 , k , 1 )) * zz + ( + e2 ( 3 , 3 , k , 1 ) + e2 ( 4 , 3 , k , 1 )) * zzzd + e1 ( 5 , k , 1 ) * zzzz f ( 4 , 3 , k , 1 ) = e5 ( 9 , k , 1 ) + e3 ( 1 , 2 , k , 1 ) + ( + e4 ( 1 , 9 , k , 1 ) + e2 ( 1 , 2 , k , 1 )) * qx + e4 ( 2 , 5 , k , 1 ) * qzd + e3 ( 3 , 5 , k , 1 ) * xzd + e3 ( 4 , 2 , k , 1 ) * zz + e2 ( 4 , 2 , k , 1 ) * xzz f ( 5 , 3 , k , 1 ) = e5 ( 10 , k , 1 ) + e3 ( 1 , 3 , k , 1 ) * 3 + ( + e4 ( 1 , 10 , k , 1 ) + e2 ( 1 , 3 , k , 1 ) * 3 ) * qx + ( + e4 ( 1 , 6 , k , 1 ) + e4 ( 2 , 6 , k , 1 ) * 2 + e2 ( 1 , 1 , k , 1 ) + e2 ( 2 , 1 , k , 1 ) * 2 ) * qz + ( + e3 ( 2 , 6 , k , 1 ) + e3 ( 3 , 6 , k , 1 ) * 2 + e1 ( 2 , k , 1 ) + e1 ( 3 , k , 1 ) * 2 ) * xz + ( + e3 ( 3 , 3 , k , 1 ) * 2 + e3 ( 4 , 3 , k , 1 )) * zz + ( + e2 ( 3 , 3 , k , 1 ) * 2 + e2 ( 4 , 3 , k , 1 )) * xzz + e2 ( 4 , 1 , k , 1 ) * zzz + e1 ( 5 , k , 1 ) * xzzz f ( 6 , 3 , k , 1 ) = e5 ( 14 , k , 1 ) + e3 ( 1 , 5 , k , 1 ) * 3 + ( + e4 ( 1 , 9 , k , 1 ) + e4 ( 2 , 9 , k , 1 ) * 2 + e2 ( 1 , 2 , k , 1 ) + e2 ( 2 , 2 , k , 1 ) * 2 ) * qz + ( + e3 ( 3 , 5 , k , 1 ) * 2 + e3 ( 4 , 5 , k , 1 )) * zz + e2 ( 4 , 2 , k , 1 ) * zzz f ( 1 , 4 , k , 1 ) = e5 ( 2 , k , 1 ) + e3 ( 1 , 2 , k , 1 ) * 3 + ( + e4 ( 1 , 2 , k , 1 ) * 2 + e4 ( 2 , 2 , k , 1 ) + e2 ( 1 , 2 , k , 1 ) * 2 + e2 ( 2 , 2 , k , 1 )) * qx + ( + e3 ( 2 , 2 , k , 1 ) + e3 ( 3 , 2 , k , 1 ) * 2 ) * xx + e2 ( 3 , 2 , k , 1 ) * xxx f ( 2 , 4 , k , 1 ) = e5 ( 7 , k , 1 ) + e3 ( 1 , 2 , k , 1 ) * 3 + ( + e4 ( 2 , 7 , k , 1 ) + e2 ( 2 , 2 , k , 1 ) * 3 ) * qx f ( 3 , 4 , k , 1 ) = e5 ( 9 , k , 1 ) + e3 ( 1 , 2 , k , 1 ) + ( + e4 ( 2 , 9 , k , 1 ) + e2 ( 2 , 2 , k , 1 )) * qx + e4 ( 1 , 5 , k , 1 ) * qzd + e3 ( 3 , 5 , k , 1 ) * xzd + e3 ( 2 , 2 , k , 1 ) * zz + e2 ( 3 , 2 , k , 1 ) * xzz f ( 4 , 4 , k , 1 ) = e5 ( 4 , k , 1 ) + e3 ( 1 , 4 , k , 1 ) + e3 ( 1 , 1 , k , 1 ) + e1 ( 1 , k , 1 ) + ( + e4 ( 1 , 4 , k , 1 ) + e4 ( 2 , 4 , k , 1 ) + e2 ( 1 , 1 , k , 1 ) + e2 ( 2 , 1 , k , 1 )) * qx + ( + e3 ( 3 , 4 , k , 1 ) + e1 ( 3 , k , 1 )) * xx f ( 5 , 4 , k , 1 ) = e5 ( 5 , k , 1 ) + e3 ( 1 , 5 , k , 1 ) + ( + e4 ( 1 , 5 , k , 1 ) + e4 ( 2 , 5 , k , 1 )) * qx + ( + e4 ( 1 , 2 , k , 1 ) + e2 ( 1 , 2 , k , 1 )) * qz + e3 ( 3 , 5 , k , 1 ) * xx + ( + e3 ( 2 , 2 , k , 1 ) + e3 ( 3 , 2 , k , 1 )) * xz + e2 ( 3 , 2 , k , 1 ) * xxz f ( 6 , 4 , k , 1 ) = e5 ( 8 , k , 1 ) + e3 ( 1 , 3 , k , 1 ) + ( + e4 ( 2 , 8 , k , 1 ) + e2 ( 2 , 3 , k , 1 )) * qx + ( + e4 ( 1 , 4 , k , 1 ) + e2 ( 1 , 1 , k , 1 )) * qz + ( + e3 ( 3 , 4 , k , 1 ) + e1 ( 3 , k , 1 )) * xz f ( 1 , 5 , k , 1 ) = e5 ( 3 , k , 1 ) + e3 ( 1 , 3 , k , 1 ) * 3 + ( + e4 ( 1 , 3 , k , 1 ) * 2 + e4 ( 2 , 3 , k , 1 ) + e2 ( 1 , 3 , k , 1 ) * 2 + e2 ( 2 , 3 , k , 1 )) * qx + ( + e4 ( 2 , 1 , k , 1 ) + e2 ( 2 , 1 , k , 1 ) * 3 ) * qz + ( + e3 ( 2 , 3 , k , 1 ) + e3 ( 3 , 3 , k , 1 ) * 2 ) * xx + ( + e3 ( 3 , 1 , k , 1 ) * 2 + e3 ( 4 , 1 , k , 1 ) + e1 ( 3 , k , 1 ) * 2 + e1 ( 4 , k , 1 )) * xz + e2 ( 3 , 3 , k , 1 ) * xxx + ( + e2 ( 3 , 1 , k , 1 ) + e2 ( 4 , 1 , k , 1 ) * 2 ) * xxz + e1 ( 5 , k , 1 ) * xxxz f ( 2 , 5 , k , 1 ) = e5 ( 8 , k , 1 ) + e3 ( 1 , 3 , k , 1 ) + ( + e4 ( 2 , 8 , k , 1 ) + e2 ( 2 , 3 , k , 1 )) * qx + ( + e4 ( 2 , 4 , k , 1 ) + e2 ( 2 , 1 , k , 1 )) * qz + ( + e3 ( 4 , 4 , k , 1 ) + e1 ( 4 , k , 1 )) * xz f ( 3 , 5 , k , 1 ) = e5 ( 10 , k , 1 ) + e3 ( 1 , 3 , k , 1 ) * 3 + ( + e4 ( 2 , 10 , k , 1 ) + e2 ( 2 , 3 , k , 1 ) * 3 ) * qx + ( + e4 ( 1 , 6 , k , 1 ) * 2 + e4 ( 2 , 6 , k , 1 ) + e2 ( 1 , 1 , k , 1 ) * 2 + e2 ( 2 , 1 , k , 1 )) * qz + ( + e3 ( 3 , 6 , k , 1 ) * 2 + e3 ( 4 , 6 , k , 1 ) + e1 ( 3 , k , 1 ) * 2 + e1 ( 4 , k , 1 )) * xz + ( + e3 ( 2 , 3 , k , 1 ) + e3 ( 3 , 3 , k , 1 ) * 2 ) * zz + ( + e2 ( 3 , 3 , k , 1 ) + e2 ( 4 , 3 , k , 1 ) * 2 ) * xzz + e2 ( 3 , 1 , k , 1 ) * zzz + e1 ( 5 , k , 1 ) * xzzz f ( 4 , 5 , k , 1 ) = e5 ( 5 , k , 1 ) + e3 ( 1 , 5 , k , 1 ) + ( + e4 ( 1 , 5 , k , 1 ) + e4 ( 2 , 5 , k , 1 )) * qx + ( + e4 ( 2 , 2 , k , 1 ) + e2 ( 2 , 2 , k , 1 )) * qz + e3 ( 3 , 5 , k , 1 ) * xx + ( + e3 ( 3 , 2 , k , 1 ) + e3 ( 4 , 2 , k , 1 )) * xz + e2 ( 4 , 2 , k , 1 ) * xxz f ( 5 , 5 , k , 1 ) = e5 ( 6 , k , 1 ) + e3 ( 1 , 6 , k , 1 ) + e3 ( 1 , 1 , k , 1 ) + e1 ( 1 , k , 1 ) + ( + e4 ( 1 , 6 , k , 1 ) + e4 ( 2 , 6 , k , 1 ) + e2 ( 1 , 1 , k , 1 ) + e2 ( 2 , 1 , k , 1 )) * qx + ( + e4 ( 1 , 3 , k , 1 ) + e4 ( 2 , 3 , k , 1 ) + e2 ( 1 , 3 , k , 1 ) + e2 ( 2 , 3 , k , 1 )) * qz + ( + e3 ( 3 , 6 , k , 1 ) + e1 ( 3 , k , 1 )) * xx + ( + e3 ( 2 , 3 , k , 1 ) + e3 ( 3 , 3 , k , 1 ) * 2 + e3 ( 4 , 3 , k , 1 )) * xz + ( + e3 ( 3 , 1 , k , 1 ) + e1 ( 3 , k , 1 )) * zz + ( + e2 ( 3 , 3 , k , 1 ) + e2 ( 4 , 3 , k , 1 )) * xxz + ( + e2 ( 3 , 1 , k , 1 ) + e2 ( 4 , 1 , k , 1 )) * xzz + e1 ( 5 , k , 1 ) * xxzz f ( 6 , 5 , k , 1 ) = e5 ( 9 , k , 1 ) + e3 ( 1 , 2 , k , 1 ) + ( + e4 ( 2 , 9 , k , 1 ) + e2 ( 2 , 2 , k , 1 )) * qx + ( + e4 ( 1 , 5 , k , 1 ) + e4 ( 2 , 5 , k , 1 )) * qz + ( + e3 ( 3 , 5 , k , 1 ) + e3 ( 4 , 5 , k , 1 )) * xz + e3 ( 3 , 2 , k , 1 ) * zz + e2 ( 4 , 2 , k , 1 ) * xzz f ( 1 , 6 , k , 1 ) = e5 ( 5 , k , 1 ) + e3 ( 1 , 5 , k , 1 ) + e4 ( 1 , 5 , k , 1 ) * qxd + ( + e4 ( 2 , 2 , k , 1 ) + e2 ( 2 , 2 , k , 1 )) * qz + e3 ( 2 , 5 , k , 1 ) * xx + e3 ( 3 , 2 , k , 1 ) * xzd + e2 ( 3 , 2 , k , 1 ) * xxz f ( 2 , 6 , k , 1 ) = e5 ( 12 , k , 1 ) + e3 ( 1 , 5 , k , 1 ) * 3 + ( + e4 ( 2 , 7 , k , 1 ) + e2 ( 2 , 2 , k , 1 ) * 3 ) * qz f ( 3 , 6 , k , 1 ) = e5 ( 14 , k , 1 ) + e3 ( 1 , 5 , k , 1 ) * 3 + ( + e4 ( 1 , 9 , k , 1 ) * 2 + e4 ( 2 , 9 , k , 1 ) + e2 ( 1 , 2 , k , 1 ) * 2 + e2 ( 2 , 2 , k , 1 )) * qz + ( + e3 ( 2 , 5 , k , 1 ) + e3 ( 3 , 5 , k , 1 ) * 2 ) * zz + e2 ( 3 , 2 , k , 1 ) * zzz f ( 4 , 6 , k , 1 ) = e5 ( 8 , k , 1 ) + e3 ( 1 , 3 , k , 1 ) + ( + e4 ( 1 , 8 , k , 1 ) + e2 ( 1 , 3 , k , 1 )) * qx + ( + e4 ( 2 , 4 , k , 1 ) + e2 ( 2 , 1 , k , 1 )) * qz + ( + e3 ( 3 , 4 , k , 1 ) + e1 ( 3 , k , 1 )) * xz f ( 5 , 6 , k , 1 ) = e5 ( 9 , k , 1 ) + e3 ( 1 , 2 , k , 1 ) + ( + e4 ( 1 , 9 , k , 1 ) + e2 ( 1 , 2 , k , 1 )) * qx + ( + e4 ( 1 , 5 , k , 1 ) + e4 ( 2 , 5 , k , 1 )) * qz + ( + e3 ( 2 , 5 , k , 1 ) + e3 ( 3 , 5 , k , 1 )) * xz + e3 ( 3 , 2 , k , 1 ) * zz + e2 ( 3 , 2 , k , 1 ) * xzz f ( 6 , 6 , k , 1 ) = e5 ( 13 , k , 1 ) + e3 ( 1 , 6 , k , 1 ) + e3 ( 1 , 4 , k , 1 ) + e1 ( 1 , k , 1 ) + ( + e4 ( 1 , 8 , k , 1 ) + e4 ( 2 , 8 , k , 1 ) + e2 ( 1 , 3 , k , 1 ) + e2 ( 2 , 3 , k , 1 )) * qz + ( + e3 ( 3 , 4 , k , 1 ) + e1 ( 3 , k , 1 )) * zz enddo end subroutine mcdv_17 ! > ! >    @brief   ddpp case ! > ! >    @details integration of a ddpp case ! > subroutine mcdv_18 ( f , rdat , qx , qz ) implicit none type ( rotaxis_data_t ) :: rdat real ( kind = dp ) :: f ( 6 , 6 , 3 , 3 ) real ( kind = dp ) :: qx , qz integer , parameter :: kx = 4 , lx = 4 real ( kind = dp ) :: e1 ( 5 , kx , lx ), e2 ( 4 , 3 , kx , lx ), e3 ( 4 , 6 , kx , lx ), & e4 ( 2 , 10 , kx , lx ), e5 ( 15 , kx , lx ) integer , parameter :: ind ( 15 , kx , lx ) = reshape (& [ 1 , 2 , 3 , 4 , 5 , 6 , 7 , 8 , 9 , 10 , 11 , 12 , 13 , 14 , 15 , 1 , 2 , 3 , 4 , & 5 , 6 , 7 , 8 , 9 , 10 , 11 , 12 , 13 , 14 , 15 , 2 , 4 , 5 , 7 , 8 , 9 , 11 , 12 , & 13 , 14 , 16 , 17 , 18 , 19 , 20 , 3 , 5 , 6 , 8 , 9 , 10 , 12 , 13 , 14 , 15 , & 17 , 18 , 19 , 20 , 21 , 1 , 2 , 3 , 4 , 5 , 6 , 7 , 8 , 9 , 10 , 11 , 12 , 13 , & 14 , 15 , 1 , 2 , 3 , 4 , 5 , 6 , 7 , 8 , 9 , 10 , 11 , 12 , 13 , 14 , 15 , 2 , 4 , & 5 , 7 , 8 , 9 , 11 , 12 , 13 , 14 , 16 , 17 , 18 , 19 , 20 , 3 , 5 , 6 , 8 , 9 , & 10 , 12 , 13 , 14 , 15 , 17 , 18 , 19 , 20 , 21 , 2 , 4 , 5 , 7 , 8 , 9 , 11 , & 12 , 13 , 14 , 16 , 17 , 18 , 19 , 20 , 2 , 4 , 5 , 7 , 8 , 9 , 11 , 12 , 13 , & 14 , 16 , 17 , 18 , 19 , 20 , 4 , 7 , 8 , 11 , 12 , 13 , 16 , 17 , 18 , 19 , 22 , & 23 , 24 , 25 , 26 , 5 , 8 , 9 , 12 , 13 , 14 , 17 , 18 , 19 , 20 , 23 , 24 , 25 , & 26 , 27 , 3 , 5 , 6 , 8 , 9 , 10 , 12 , 13 , 14 , 15 , 17 , 18 , 19 , 20 , 21 , & 3 , 5 , 6 , 8 , 9 , 10 , 12 , 13 , 14 , 15 , 17 , 18 , 19 , 20 , 21 , 5 , 8 , 9 , & 12 , 13 , 14 , 17 , 18 , 19 , 20 , 23 , 24 , 25 , 26 , 27 , 6 , 9 , 10 , 13 , & 14 , 15 , 18 , 19 , 20 , 21 , 24 , 25 , 26 , 27 , 28 ] & , shape ( ind )) integer :: i , j , k , l , m , ii , jj real ( kind = dp ) :: xx , zz , xz , xxx , xxz , xzz , zzz real ( kind = dp ) :: xxxx , xxzz , xxxz , xzzz , zzzz real ( kind = dp ) :: xxxd , xxzd , xzzd , zzzd real ( kind = dp ) :: xzq real ( kind = dp ) :: qxd , qzd , xzd do j = 1 , 15 e5 ( j , 1 , 1 ) =+ rdat % r04 ( j , 1 ) enddo do j = 1 , 10 e4 ( 1 , j , 1 , 1 ) =+ rdat % r03 ( j , 1 ) e4 ( 2 , j , 1 , 1 ) =+ rdat % r03 ( j , 2 ) enddo do j = 1 , 6 m = in6 ( j ) e3 ( 1 , j , 1 , 1 ) =+ rdat % r02 ( m , 1 ) e3 ( 2 , j , 1 , 1 ) =+ rdat % r02 ( m , 2 ) e3 ( 3 , j , 1 , 1 ) =+ rdat % r02 ( m , 3 ) e3 ( 4 , j , 1 , 1 ) =+ rdat % r02 ( m , 4 ) enddo do j = 1 , 3 e2 ( 1 , j , 1 , 1 ) =+ rdat % r01 ( j , 1 ) e2 ( 2 , j , 1 , 1 ) =+ rdat % r01 ( j , 2 ) e2 ( 3 , j , 1 , 1 ) =+ rdat % r01 ( j , 3 ) e2 ( 4 , j , 1 , 1 ) =+ rdat % r01 ( j , 4 ) enddo do i = 1 , 5 e1 ( i , 1 , 1 ) =+ rdat % r00 ( i , 1 ) enddo do j = 1 , 15 e5 ( j , 2 , 1 ) =- rdat % r05 ( j , 2 ) enddo do j = 1 , 10 e4 ( 1 , j , 2 , 1 ) =- rdat % r04 ( j , 8 ) e4 ( 2 , j , 2 , 1 ) =- rdat % r04 ( j , 9 ) enddo do j = 1 , 6 e3 ( 1 , j , 2 , 1 ) =- rdat % r03 ( j , 11 ) e3 ( 2 , j , 2 , 1 ) =- rdat % r03 ( j , 12 ) e3 ( 3 , j , 2 , 1 ) =- rdat % r03 ( j , 13 ) e3 ( 4 , j , 2 , 1 ) =- rdat % r03 ( j , 14 ) enddo do j = 1 , 3 m = in6 ( j ) e2 ( 1 , j , 2 , 1 ) =- rdat % r02 ( m , 21 ) e2 ( 2 , j , 2 , 1 ) =- rdat % r02 ( m , 22 ) e2 ( 3 , j , 2 , 1 ) =- rdat % r02 ( m , 23 ) e2 ( 4 , j , 2 , 1 ) =- rdat % r02 ( m , 24 ) enddo j = 1 do i = 1 , 5 e1 ( i , 2 , 1 ) =- rdat % r01 ( j , i + 20 ) enddo do j = 1 , 15 k = ind ( j , 3 , 1 ) e5 ( j , 3 , 1 ) =- rdat % r05 ( k , 2 ) enddo do j = 1 , 10 k = ind ( j , 3 , 1 ) e4 ( 1 , j , 3 , 1 ) =- rdat % r04 ( k , 8 ) e4 ( 2 , j , 3 , 1 ) =- rdat % r04 ( k , 9 ) enddo do j = 1 , 6 k = ind ( j , 3 , 1 ) e3 ( 1 , j , 3 , 1 ) =- rdat % r03 ( k , 11 ) e3 ( 2 , j , 3 , 1 ) =- rdat % r03 ( k , 12 ) e3 ( 3 , j , 3 , 1 ) =- rdat % r03 ( k , 13 ) e3 ( 4 , j , 3 , 1 ) =- rdat % r03 ( k , 14 ) enddo do j = 1 , 3 k = ind ( j , 3 , 1 ) m = in6 ( k ) e2 ( 1 , j , 3 , 1 ) =- rdat % r02 ( m , 21 ) e2 ( 2 , j , 3 , 1 ) =- rdat % r02 ( m , 22 ) e2 ( 3 , j , 3 , 1 ) =- rdat % r02 ( m , 23 ) e2 ( 4 , j , 3 , 1 ) =- rdat % r02 ( m , 24 ) enddo j = 1 k = ind ( j , 3 , 1 ) do i = 1 , 5 e1 ( i , 3 , 1 ) =- rdat % r01 ( k , i + 20 ) enddo do j = 1 , 15 k = ind ( j , 4 , 1 ) e5 ( j , 4 , 1 ) =- rdat % r05 ( k , 2 ) + rdat % r04 ( j , 2 ) enddo do j = 1 , 10 k = ind ( j , 4 , 1 ) e4 ( 1 , j , 4 , 1 ) =- rdat % r04 ( k , 8 ) + rdat % r03 ( j , 3 ) e4 ( 2 , j , 4 , 1 ) =- rdat % r04 ( k , 9 ) + rdat % r03 ( j , 4 ) enddo do j = 1 , 6 k = ind ( j , 4 , 1 ) m = in6 ( j ) e3 ( 1 , j , 4 , 1 ) =- rdat % r03 ( k , 11 ) + rdat % r02 ( m , 5 ) e3 ( 2 , j , 4 , 1 ) =- rdat % r03 ( k , 12 ) + rdat % r02 ( m , 6 ) e3 ( 3 , j , 4 , 1 ) =- rdat % r03 ( k , 13 ) + rdat % r02 ( m , 7 ) e3 ( 4 , j , 4 , 1 ) =- rdat % r03 ( k , 14 ) + rdat % r02 ( m , 8 ) enddo do j = 1 , 3 k = ind ( j , 4 , 1 ) m = in6 ( k ) e2 ( 1 , j , 4 , 1 ) =- rdat % r02 ( m , 21 ) + rdat % r01 ( j , 5 ) e2 ( 2 , j , 4 , 1 ) =- rdat % r02 ( m , 22 ) + rdat % r01 ( j , 6 ) e2 ( 3 , j , 4 , 1 ) =- rdat % r02 ( m , 23 ) + rdat % r01 ( j , 7 ) e2 ( 4 , j , 4 , 1 ) =- rdat % r02 ( m , 24 ) + rdat % r01 ( j , 8 ) enddo j = 1 k = ind ( j , 4 , 1 ) do i = 1 , 5 e1 ( i , 4 , 1 ) =- rdat % r01 ( k , i + 20 ) + rdat % r00 ( i , 2 ) enddo do j = 1 , 15 e5 ( j , 1 , 2 ) =- rdat % r05 ( j , 3 ) enddo do j = 1 , 10 e4 ( 1 , j , 1 , 2 ) =- rdat % r04 ( j , 10 ) e4 ( 2 , j , 1 , 2 ) =- rdat % r04 ( j , 11 ) enddo do j = 1 , 6 e3 ( 1 , j , 1 , 2 ) =- rdat % r03 ( j , 15 ) e3 ( 2 , j , 1 , 2 ) =- rdat % r03 ( j , 16 ) e3 ( 3 , j , 1 , 2 ) =- rdat % r03 ( j , 17 ) e3 ( 4 , j , 1 , 2 ) =- rdat % r03 ( j , 18 ) enddo do j = 1 , 3 m = in6 ( j ) e2 ( 1 , j , 1 , 2 ) =- rdat % r02 ( m , 25 ) e2 ( 2 , j , 1 , 2 ) =- rdat % r02 ( m , 26 ) e2 ( 3 , j , 1 , 2 ) =- rdat % r02 ( m , 27 ) e2 ( 4 , j , 1 , 2 ) =- rdat % r02 ( m , 28 ) enddo j = 1 do i = 1 , 5 e1 ( i , 1 , 2 ) =- rdat % r01 ( j , i + 25 ) enddo do j = 1 , 15 e5 ( j , 2 , 2 ) =+ rdat % r06 ( j , 1 ) + rdat % r04 ( j , 5 ) enddo do j = 1 , 10 e4 ( 1 , j , 2 , 2 ) =+ rdat % r05 ( j , 5 ) + rdat % r03 ( j , 9 ) e4 ( 2 , j , 2 , 2 ) =+ rdat % r05 ( j , 6 ) + rdat % r03 ( j , 10 ) enddo do j = 1 , 6 m = in6 ( j ) e3 ( 1 , j , 2 , 2 ) =+ rdat % r04 ( j , 14 ) + rdat % r02 ( m , 17 ) e3 ( 2 , j , 2 , 2 ) =+ rdat % r04 ( j , 15 ) + rdat % r02 ( m , 18 ) e3 ( 3 , j , 2 , 2 ) =+ rdat % r04 ( j , 16 ) + rdat % r02 ( m , 19 ) e3 ( 4 , j , 2 , 2 ) =+ rdat % r04 ( j , 17 ) + rdat % r02 ( m , 20 ) enddo do j = 1 , 3 e2 ( 1 , j , 2 , 2 ) =+ rdat % r03 ( j , 27 ) + rdat % r01 ( j , 17 ) e2 ( 2 , j , 2 , 2 ) =+ rdat % r03 ( j , 28 ) + rdat % r01 ( j , 18 ) e2 ( 3 , j , 2 , 2 ) =+ rdat % r03 ( j , 29 ) + rdat % r01 ( j , 19 ) e2 ( 4 , j , 2 , 2 ) =+ rdat % r03 ( j , 30 ) + rdat % r01 ( j , 20 ) enddo j = 1 do i = 1 , 5 e1 ( i , 2 , 2 ) =+ rdat % r02 ( j , i + 36 ) + rdat % r00 ( i , 5 ) enddo do j = 1 , 15 k = ind ( j , 3 , 2 ) e5 ( j , 3 , 2 ) =+ rdat % r06 ( k , 1 ) enddo do j = 1 , 10 k = ind ( j , 3 , 2 ) e4 ( 1 , j , 3 , 2 ) =+ rdat % r05 ( k , 5 ) e4 ( 2 , j , 3 , 2 ) =+ rdat % r05 ( k , 6 ) enddo do j = 1 , 6 k = ind ( j , 3 , 2 ) e3 ( 1 , j , 3 , 2 ) =+ rdat % r04 ( k , 14 ) e3 ( 2 , j , 3 , 2 ) =+ rdat % r04 ( k , 15 ) e3 ( 3 , j , 3 , 2 ) =+ rdat % r04 ( k , 16 ) e3 ( 4 , j , 3 , 2 ) =+ rdat % r04 ( k , 17 ) enddo do j = 1 , 3 k = ind ( j , 3 , 2 ) e2 ( 1 , j , 3 , 2 ) =+ rdat % r03 ( k , 27 ) e2 ( 2 , j , 3 , 2 ) =+ rdat % r03 ( k , 28 ) e2 ( 3 , j , 3 , 2 ) =+ rdat % r03 ( k , 29 ) e2 ( 4 , j , 3 , 2 ) =+ rdat % r03 ( k , 30 ) enddo j = 1 k = ind ( j , 3 , 2 ) m = in6 ( k ) do i = 1 , 5 e1 ( i , 3 , 2 ) =+ rdat % r02 ( m , i + 36 ) enddo do j = 1 , 15 k = ind ( j , 4 , 2 ) e5 ( j , 4 , 2 ) =+ rdat % r06 ( k , 1 ) - rdat % r05 ( j , 4 ) enddo do j = 1 , 10 k = ind ( j , 4 , 2 ) e4 ( 1 , j , 4 , 2 ) =+ rdat % r05 ( k , 5 ) - rdat % r04 ( j , 12 ) e4 ( 2 , j , 4 , 2 ) =+ rdat % r05 ( k , 6 ) - rdat % r04 ( j , 13 ) enddo do j = 1 , 6 k = ind ( j , 4 , 2 ) e3 ( 1 , j , 4 , 2 ) =+ rdat % r04 ( k , 14 ) - rdat % r03 ( j , 19 ) e3 ( 2 , j , 4 , 2 ) =+ rdat % r04 ( k , 15 ) - rdat % r03 ( j , 20 ) e3 ( 3 , j , 4 , 2 ) =+ rdat % r04 ( k , 16 ) - rdat % r03 ( j , 21 ) e3 ( 4 , j , 4 , 2 ) =+ rdat % r04 ( k , 17 ) - rdat % r03 ( j , 22 ) enddo do j = 1 , 3 k = ind ( j , 4 , 2 ) m = in6 ( j ) e2 ( 1 , j , 4 , 2 ) =+ rdat % r03 ( k , 27 ) - rdat % r02 ( m , 29 ) e2 ( 2 , j , 4 , 2 ) =+ rdat % r03 ( k , 28 ) - rdat % r02 ( m , 30 ) e2 ( 3 , j , 4 , 2 ) =+ rdat % r03 ( k , 29 ) - rdat % r02 ( m , 31 ) e2 ( 4 , j , 4 , 2 ) =+ rdat % r03 ( k , 30 ) - rdat % r02 ( m , 32 ) enddo j = 1 k = ind ( j , 4 , 2 ) m = in6 ( k ) do i = 1 , 5 e1 ( i , 4 , 2 ) =+ rdat % r02 ( m , i + 36 ) - rdat % r01 ( j , i + 30 ) enddo do j = 1 , 15 k = ind ( j , 1 , 3 ) e5 ( j , 1 , 3 ) =- rdat % r05 ( k , 3 ) enddo do j = 1 , 10 k = ind ( j , 1 , 3 ) e4 ( 1 , j , 1 , 3 ) =- rdat % r04 ( k , 10 ) e4 ( 2 , j , 1 , 3 ) =- rdat % r04 ( k , 11 ) enddo do j = 1 , 6 k = ind ( j , 1 , 3 ) e3 ( 1 , j , 1 , 3 ) =- rdat % r03 ( k , 15 ) e3 ( 2 , j , 1 , 3 ) =- rdat % r03 ( k , 16 ) e3 ( 3 , j , 1 , 3 ) =- rdat % r03 ( k , 17 ) e3 ( 4 , j , 1 , 3 ) =- rdat % r03 ( k , 18 ) enddo do j = 1 , 3 k = ind ( j , 1 , 3 ) m = in6 ( k ) e2 ( 1 , j , 1 , 3 ) =- rdat % r02 ( m , 25 ) e2 ( 2 , j , 1 , 3 ) =- rdat % r02 ( m , 26 ) e2 ( 3 , j , 1 , 3 ) =- rdat % r02 ( m , 27 ) e2 ( 4 , j , 1 , 3 ) =- rdat % r02 ( m , 28 ) enddo j = 1 k = ind ( j , 1 , 3 ) do i = 1 , 5 e1 ( i , 1 , 3 ) =- rdat % r01 ( k , i + 25 ) enddo do j = 1 , 15 k = ind ( j , 3 , 3 ) e5 ( j , 3 , 3 ) =+ rdat % r06 ( k , 1 ) + rdat % r04 ( j , 5 ) enddo do j = 1 , 10 k = ind ( j , 3 , 3 ) e4 ( 1 , j , 3 , 3 ) =+ rdat % r05 ( k , 5 ) + rdat % r03 ( j , 9 ) e4 ( 2 , j , 3 , 3 ) =+ rdat % r05 ( k , 6 ) + rdat % r03 ( j , 10 ) enddo do j = 1 , 6 k = ind ( j , 3 , 3 ) m = in6 ( j ) e3 ( 1 , j , 3 , 3 ) =+ rdat % r04 ( k , 14 ) + rdat % r02 ( m , 17 ) e3 ( 2 , j , 3 , 3 ) =+ rdat % r04 ( k , 15 ) + rdat % r02 ( m , 18 ) e3 ( 3 , j , 3 , 3 ) =+ rdat % r04 ( k , 16 ) + rdat % r02 ( m , 19 ) e3 ( 4 , j , 3 , 3 ) =+ rdat % r04 ( k , 17 ) + rdat % r02 ( m , 20 ) enddo do j = 1 , 3 k = ind ( j , 3 , 3 ) e2 ( 1 , j , 3 , 3 ) =+ rdat % r03 ( k , 27 ) + rdat % r01 ( j , 17 ) e2 ( 2 , j , 3 , 3 ) =+ rdat % r03 ( k , 28 ) + rdat % r01 ( j , 18 ) e2 ( 3 , j , 3 , 3 ) =+ rdat % r03 ( k , 29 ) + rdat % r01 ( j , 19 ) e2 ( 4 , j , 3 , 3 ) =+ rdat % r03 ( k , 30 ) + rdat % r01 ( j , 20 ) enddo j = 1 k = ind ( j , 3 , 3 ) m = in6 ( k ) do i = 1 , 5 e1 ( i , 3 , 3 ) =+ rdat % r02 ( m , i + 36 ) + rdat % r00 ( i , 5 ) enddo j = 0 do jj = 1 , 5 do ii = 1 , jj j = j + 1 k = ind ( j , 4 , 3 ) l = k - 2 - jj e5 ( j , 4 , 3 ) =+ rdat % r06 ( k , 1 ) - rdat % r05 ( l , 4 ) if ( jj > 4 ) cycle e4 ( 1 , j , 4 , 3 ) =+ rdat % r05 ( k , 5 ) - rdat % r04 ( l , 12 ) e4 ( 2 , j , 4 , 3 ) =+ rdat % r05 ( k , 6 ) - rdat % r04 ( l , 13 ) if ( jj > 3 ) cycle do i = 1 , 4 e3 ( i , j , 4 , 3 ) =+ rdat % r04 ( k , i + 13 ) - rdat % r03 ( l , i + 18 ) enddo if ( jj > 2 ) cycle m = in6 ( l ) do i = 1 , 4 e2 ( i , j , 4 , 3 ) =+ rdat % r03 ( k , i + 26 ) - rdat % r02 ( m , i + 28 ) enddo if ( jj > 1 ) cycle m = in6 ( k ) do i = 1 , 5 e1 ( i , 4 , 3 ) =+ rdat % r02 ( m , i + 36 ) - rdat % r01 ( l , i + 30 ) enddo enddo enddo do j = 1 , 15 k = ind ( j , 1 , 4 ) e5 ( j , 1 , 4 ) =- rdat % r05 ( k , 3 ) + rdat % r04 ( j , 3 ) enddo do j = 1 , 10 k = ind ( j , 1 , 4 ) e4 ( 1 , j , 1 , 4 ) =- rdat % r04 ( k , 10 ) + rdat % r03 ( j , 5 ) e4 ( 2 , j , 1 , 4 ) =- rdat % r04 ( k , 11 ) + rdat % r03 ( j , 6 ) enddo do j = 1 , 6 k = ind ( j , 1 , 4 ) m = in6 ( j ) e3 ( 1 , j , 1 , 4 ) =- rdat % r03 ( k , 15 ) + rdat % r02 ( m , 9 ) e3 ( 2 , j , 1 , 4 ) =- rdat % r03 ( k , 16 ) + rdat % r02 ( m , 10 ) e3 ( 3 , j , 1 , 4 ) =- rdat % r03 ( k , 17 ) + rdat % r02 ( m , 11 ) e3 ( 4 , j , 1 , 4 ) =- rdat % r03 ( k , 18 ) + rdat % r02 ( m , 12 ) enddo do j = 1 , 3 k = ind ( j , 1 , 4 ) m = in6 ( k ) e2 ( 1 , j , 1 , 4 ) =- rdat % r02 ( m , 25 ) + rdat % r01 ( j , 9 ) e2 ( 2 , j , 1 , 4 ) =- rdat % r02 ( m , 26 ) + rdat % r01 ( j , 10 ) e2 ( 3 , j , 1 , 4 ) =- rdat % r02 ( m , 27 ) + rdat % r01 ( j , 11 ) e2 ( 4 , j , 1 , 4 ) =- rdat % r02 ( m , 28 ) + rdat % r01 ( j , 12 ) enddo j = 1 k = ind ( j , 1 , 4 ) do i = 1 , 5 e1 ( i , 1 , 4 ) =- rdat % r01 ( k , i + 25 ) + rdat % r00 ( i , 3 ) enddo do j = 1 , 15 k = ind ( j , 2 , 4 ) e5 ( j , 2 , 4 ) =+ rdat % r06 ( k , 1 ) - rdat % r05 ( j , 1 ) enddo do j = 1 , 10 k = ind ( j , 2 , 4 ) e4 ( 1 , j , 2 , 4 ) =+ rdat % r05 ( k , 5 ) - rdat % r04 ( j , 6 ) e4 ( 2 , j , 2 , 4 ) =+ rdat % r05 ( k , 6 ) - rdat % r04 ( j , 7 ) enddo do j = 1 , 6 k = ind ( j , 2 , 4 ) e3 ( 1 , j , 2 , 4 ) =+ rdat % r04 ( k , 14 ) - rdat % r03 ( j , 23 ) e3 ( 2 , j , 2 , 4 ) =+ rdat % r04 ( k , 15 ) - rdat % r03 ( j , 24 ) e3 ( 3 , j , 2 , 4 ) =+ rdat % r04 ( k , 16 ) - rdat % r03 ( j , 25 ) e3 ( 4 , j , 2 , 4 ) =+ rdat % r04 ( k , 17 ) - rdat % r03 ( j , 26 ) enddo do j = 1 , 3 k = ind ( j , 2 , 4 ) m = in6 ( j ) e2 ( 1 , j , 2 , 4 ) =+ rdat % r03 ( k , 27 ) - rdat % r02 ( m , 33 ) e2 ( 2 , j , 2 , 4 ) =+ rdat % r03 ( k , 28 ) - rdat % r02 ( m , 34 ) e2 ( 3 , j , 2 , 4 ) =+ rdat % r03 ( k , 29 ) - rdat % r02 ( m , 35 ) e2 ( 4 , j , 2 , 4 ) =+ rdat % r03 ( k , 30 ) - rdat % r02 ( m , 36 ) enddo j = 1 k = ind ( j , 2 , 4 ) m = in6 ( k ) do i = 1 , 5 e1 ( i , 2 , 4 ) =+ rdat % r02 ( m , i + 36 ) - rdat % r01 ( j , i + 35 ) enddo j = 0 do jj = 1 , 5 do ii = 1 , jj j = j + 1 k = ind ( j , 3 , 4 ) l = k - 2 - jj e5 ( j , 3 , 4 ) =+ rdat % r06 ( k , 1 ) - rdat % r05 ( l , 1 ) if ( jj > 4 ) cycle e4 ( 1 , j , 3 , 4 ) =+ rdat % r05 ( k , 5 ) - rdat % r04 ( l , 6 ) e4 ( 2 , j , 3 , 4 ) =+ rdat % r05 ( k , 6 ) - rdat % r04 ( l , 7 ) if ( jj > 3 ) cycle do i = 1 , 4 e3 ( i , j , 3 , 4 ) =+ rdat % r04 ( k , i + 13 ) - rdat % r03 ( l , i + 22 ) enddo if ( jj > 2 ) cycle m = in6 ( l ) do i = 1 , 4 e2 ( i , j , 3 , 4 ) =+ rdat % r03 ( k , i + 26 ) - rdat % r02 ( m , i + 32 ) enddo if ( jj > 1 ) cycle m = in6 ( k ) do i = 1 , 5 e1 ( i , 3 , 4 ) =+ rdat % r02 ( m , i + 36 ) - rdat % r01 ( l , i + 35 ) enddo enddo enddo j = 0 do jj = 1 , 5 do ii = 1 , jj j = j + 1 k = ind ( j , 4 , 4 ) l = k - 2 - jj e5 ( j , 4 , 4 ) =+ rdat % r06 ( k , 1 ) - rdat % r05 ( l , 1 ) - rdat % r05 ( l , 4 ) + rdat % r04 ( j , 4 ) + rdat % r04 ( j , 5 ) if ( jj > 4 ) cycle e4 ( 1 , j , 4 , 4 ) =+ rdat % r05 ( k , 5 ) - rdat % r04 ( l , 6 ) - rdat % r04 ( l , 12 ) + rdat % r03 ( j , 7 ) + rdat % r03 ( j , 9 ) e4 ( 2 , j , 4 , 4 ) =+ rdat % r05 ( k , 6 ) - rdat % r04 ( l , 7 ) - rdat % r04 ( l , 13 ) + rdat % r03 ( j , 8 ) + rdat % r03 ( j , 10 ) if ( jj > 3 ) cycle m = in6 ( j ) do i = 1 , 4 e3 ( i , j , 4 , 4 ) =+ rdat % r04 ( k , i + 13 ) - rdat % r03 ( l , i + 18 ) - rdat % r03 ( l , i + 22 ) & & + rdat % r02 ( m , i + 12 ) + rdat % r02 ( m , i + 16 ) enddo if ( jj > 2 ) cycle m = in6 ( l ) do i = 1 , 4 e2 ( i , j , 4 , 4 ) =+ rdat % r03 ( k , i + 26 ) - rdat % r02 ( m , i + 28 ) - rdat % r02 ( m , i + 32 ) & & + rdat % r01 ( j , i + 12 ) + rdat % r01 ( j , i + 16 ) enddo if ( jj > 1 ) cycle m = in6 ( k ) do i = 1 , 5 e1 ( i , 4 , 4 ) =+ rdat % r02 ( m , i + 36 ) - rdat % r01 ( l , i + 30 ) - rdat % r01 ( l , i + 35 ) & & + rdat % r00 ( i , 4 ) + rdat % r00 ( i , 5 ) enddo enddo enddo xx = qx * qx zz = qz * qz xz = qx * qz xxx = xx * qx xxz = xx * qz xzz = zz * qx zzz = zz * qz xxxx = xx * xx xxxz = xx * xz xxzz = xx * zz xzzz = xz * zz zzzz = zz * zz qxd = qx + qx qzd = qz + qz xzd = xz + xz xxxd = xxx + xxx xxzd = xxz + xxz xzzd = xzz + xzz zzzd = zzz + zzz xzq = xz + xz + xz + xz do l = 2 , lx do k = 2 , kx if ( k == 2 . and . l == 3 ) cycle f ( 1 , 1 , k - 1 , l - 1 ) = e5 ( 1 , k , l ) + e3 ( 1 , 1 , k , l ) * 6 + e1 ( 1 , k , l ) * 3 + ( + e4 ( 1 , 1 , k , l ) + e4 ( 2 , 1 , k , l ) + ( + e2 ( 1 , 1 , k , l ) + e2 ( 2 , 1 , k , l )) * 3 ) * qxd + ( + e3 ( 2 , 1 , k , l ) + e3 ( 3 , 1 , k , l ) * 4 + e3 ( 4 , 1 , k , l ) + e1 ( 2 , k , l ) + e1 ( 3 , k , l ) * 4 + e1 ( 4 , k , l )) * xx + ( + e2 ( 3 , 1 , k , l ) + e2 ( 4 , 1 , k , l )) * xxxd + e1 ( 5 , k , l ) * xxxx f ( 2 , 1 , k - 1 , l - 1 ) = e5 ( 4 , k , l ) + e3 ( 1 , 4 , k , l ) + e3 ( 1 , 1 , k , l ) + e1 ( 1 , k , l ) + ( + e4 ( 2 , 4 , k , l ) + e2 ( 2 , 1 , k , l )) * qxd + ( + e3 ( 4 , 4 , k , l ) + e1 ( 4 , k , l )) * xx f ( 3 , 1 , k - 1 , l - 1 ) = e5 ( 6 , k , l ) + e3 ( 1 , 6 , k , l ) + e3 ( 1 , 1 , k , l ) + e1 ( 1 , k , l ) + ( + e4 ( 2 , 6 , k , l ) + e2 ( 2 , 1 , k , l )) * qxd + ( + e4 ( 1 , 3 , k , l ) + e2 ( 1 , 3 , k , l )) * qzd + ( + e3 ( 4 , 6 , k , l ) + e1 ( 4 , k , l )) * xx + e3 ( 3 , 3 , k , l ) * xzq + ( + e3 ( 2 , 1 , k , l ) + e1 ( 2 , k , l )) * zz + e2 ( 4 , 3 , k , l ) * xxzd + e2 ( 3 , 1 , k , l ) * xzzd + e1 ( 5 , k , l ) * xxzz f ( 4 , 1 , k - 1 , l - 1 ) = e5 ( 2 , k , l ) + e3 ( 1 , 2 , k , l ) * 3 + ( + e4 ( 1 , 2 , k , l ) + e4 ( 2 , 2 , k , l ) * 2 + e2 ( 1 , 2 , k , l ) + e2 ( 2 , 2 , k , l ) * 2 ) * qx + ( + e3 ( 3 , 2 , k , l ) * 2 + e3 ( 4 , 2 , k , l )) * xx + e2 ( 4 , 2 , k , l ) * xxx f ( 5 , 1 , k - 1 , l - 1 ) = e5 ( 3 , k , l ) + e3 ( 1 , 3 , k , l ) * 3 + ( + e4 ( 1 , 3 , k , l ) + e4 ( 2 , 3 , k , l ) * 2 + e2 ( 1 , 3 , k , l ) + e2 ( 2 , 3 , k , l ) * 2 ) * qx + ( + e4 ( 1 , 1 , k , l ) + e2 ( 1 , 1 , k , l ) * 3 ) * qz + ( + e3 ( 3 , 3 , k , l ) * 2 + e3 ( 4 , 3 , k , l )) * xx + ( + e3 ( 2 , 1 , k , l ) + e3 ( 3 , 1 , k , l ) * 2 + e1 ( 2 , k , l ) + e1 ( 3 , k , l ) * 2 ) * xz + e2 ( 4 , 3 , k , l ) * xxx + ( + e2 ( 3 , 1 , k , l ) * 2 + e2 ( 4 , 1 , k , l )) * xxz + e1 ( 5 , k , l ) * xxxz f ( 6 , 1 , k - 1 , l - 1 ) = e5 ( 5 , k , l ) + e3 ( 1 , 5 , k , l ) + e4 ( 2 , 5 , k , l ) * qxd + ( + e4 ( 1 , 2 , k , l ) + e2 ( 1 , 2 , k , l )) * qz + e3 ( 4 , 5 , k , l ) * xx + e3 ( 3 , 2 , k , l ) * xzd + e2 ( 4 , 2 , k , l ) * xxz f ( 1 , 2 , k - 1 , l - 1 ) = e5 ( 4 , k , l ) + e3 ( 1 , 4 , k , l ) + e3 ( 1 , 1 , k , l ) + e1 ( 1 , k , l ) + ( + e4 ( 1 , 4 , k , l ) + e2 ( 1 , 1 , k , l )) * qxd + ( + e3 ( 2 , 4 , k , l ) + e1 ( 2 , k , l )) * xx f ( 2 , 2 , k - 1 , l - 1 ) = e5 ( 11 , k , l ) + e3 ( 1 , 4 , k , l ) * 6 + e1 ( 1 , k , l ) * 3 f ( 3 , 2 , k - 1 , l - 1 ) = e5 ( 13 , k , l ) + e3 ( 1 , 6 , k , l ) + e3 ( 1 , 4 , k , l ) + e1 ( 1 , k , l ) + ( + e4 ( 1 , 8 , k , l ) + e2 ( 1 , 3 , k , l )) * qzd + ( + e3 ( 2 , 4 , k , l ) + e1 ( 2 , k , l )) * zz f ( 4 , 2 , k - 1 , l - 1 ) = e5 ( 7 , k , l ) + e3 ( 1 , 2 , k , l ) * 3 + ( + e4 ( 1 , 7 , k , l ) + e2 ( 1 , 2 , k , l ) * 3 ) * qx f ( 5 , 2 , k - 1 , l - 1 ) = e5 ( 8 , k , l ) + e3 ( 1 , 3 , k , l ) + ( + e4 ( 1 , 8 , k , l ) + e2 ( 1 , 3 , k , l )) * qx + ( + e4 ( 1 , 4 , k , l ) + e2 ( 1 , 1 , k , l )) * qz + ( + e3 ( 2 , 4 , k , l ) + e1 ( 2 , k , l )) * xz f ( 6 , 2 , k - 1 , l - 1 ) = e5 ( 12 , k , l ) + e3 ( 1 , 5 , k , l ) * 3 + ( + e4 ( 1 , 7 , k , l ) + e2 ( 1 , 2 , k , l ) * 3 ) * qz f ( 1 , 3 , k - 1 , l - 1 ) = e5 ( 6 , k , l ) + e3 ( 1 , 6 , k , l ) + e3 ( 1 , 1 , k , l ) + e1 ( 1 , k , l ) + ( + e4 ( 1 , 6 , k , l ) + e2 ( 1 , 1 , k , l )) * qxd + ( + e4 ( 2 , 3 , k , l ) + e2 ( 2 , 3 , k , l )) * qzd + ( + e3 ( 2 , 6 , k , l ) + e1 ( 2 , k , l )) * xx + e3 ( 3 , 3 , k , l ) * xzq + ( + e3 ( 4 , 1 , k , l ) + e1 ( 4 , k , l )) * zz + e2 ( 3 , 3 , k , l ) * xxzd + e2 ( 4 , 1 , k , l ) * xzzd + e1 ( 5 , k , l ) * xxzz f ( 2 , 3 , k - 1 , l - 1 ) = e5 ( 13 , k , l ) + e3 ( 1 , 6 , k , l ) + e3 ( 1 , 4 , k , l ) + e1 ( 1 , k , l ) + ( + e4 ( 2 , 8 , k , l ) + e2 ( 2 , 3 , k , l )) * qzd + ( + e3 ( 4 , 4 , k , l ) + e1 ( 4 , k , l )) * zz f ( 3 , 3 , k - 1 , l - 1 ) = e5 ( 15 , k , l ) + e3 ( 1 , 6 , k , l ) * 6 + e1 ( 1 , k , l ) * 3 + ( + e4 ( 1 , 10 , k , l ) + e4 ( 2 , 10 , k , l ) + ( + e2 ( 1 , 3 , k , l ) + e2 ( 2 , 3 , k , l )) * 3 ) * qzd + ( + e3 ( 2 , 6 , k , l ) + e3 ( 3 , 6 , k , l ) * 4 + e3 ( 4 , 6 , k , l ) + e1 ( 2 , k , l ) + e1 ( 3 , k , l ) * 4 + e1 ( 4 , k , l )) * zz + ( + e2 ( 3 , 3 , k , l ) + e2 ( 4 , 3 , k , l )) * zzzd + e1 ( 5 , k , l ) * zzzz f ( 4 , 3 , k - 1 , l - 1 ) = e5 ( 9 , k , l ) + e3 ( 1 , 2 , k , l ) + ( + e4 ( 1 , 9 , k , l ) + e2 ( 1 , 2 , k , l )) * qx + e4 ( 2 , 5 , k , l ) * qzd + e3 ( 3 , 5 , k , l ) * xzd + e3 ( 4 , 2 , k , l ) * zz + e2 ( 4 , 2 , k , l ) * xzz f ( 5 , 3 , k - 1 , l - 1 ) = e5 ( 10 , k , l ) + e3 ( 1 , 3 , k , l ) * 3 + ( + e4 ( 1 , 10 , k , l ) + e2 ( 1 , 3 , k , l ) * 3 ) * qx + ( + e4 ( 1 , 6 , k , l ) + e4 ( 2 , 6 , k , l ) * 2 + e2 ( 1 , 1 , k , l ) + e2 ( 2 , 1 , k , l ) * 2 ) * qz + ( + e3 ( 2 , 6 , k , l ) + e3 ( 3 , 6 , k , l ) * 2 + e1 ( 2 , k , l ) + e1 ( 3 , k , l ) * 2 ) * xz + ( + e3 ( 3 , 3 , k , l ) * 2 + e3 ( 4 , 3 , k , l )) * zz + ( + e2 ( 3 , 3 , k , l ) * 2 + e2 ( 4 , 3 , k , l )) * xzz + e2 ( 4 , 1 , k , l ) * zzz + e1 ( 5 , k , l ) * xzzz f ( 6 , 3 , k - 1 , l - 1 ) = e5 ( 14 , k , l ) + e3 ( 1 , 5 , k , l ) * 3 + ( + e4 ( 1 , 9 , k , l ) + e4 ( 2 , 9 , k , l ) * 2 + e2 ( 1 , 2 , k , l ) + e2 ( 2 , 2 , k , l ) * 2 ) * qz + ( + e3 ( 3 , 5 , k , l ) * 2 + e3 ( 4 , 5 , k , l )) * zz + e2 ( 4 , 2 , k , l ) * zzz f ( 1 , 4 , k - 1 , l - 1 ) = e5 ( 2 , k , l ) + e3 ( 1 , 2 , k , l ) * 3 + ( + e4 ( 1 , 2 , k , l ) * 2 + e4 ( 2 , 2 , k , l ) + e2 ( 1 , 2 , k , l ) * 2 + e2 ( 2 , 2 , k , l )) * qx + ( + e3 ( 2 , 2 , k , l ) + e3 ( 3 , 2 , k , l ) * 2 ) * xx + e2 ( 3 , 2 , k , l ) * xxx f ( 2 , 4 , k - 1 , l - 1 ) = e5 ( 7 , k , l ) + e3 ( 1 , 2 , k , l ) * 3 + ( + e4 ( 2 , 7 , k , l ) + e2 ( 2 , 2 , k , l ) * 3 ) * qx f ( 3 , 4 , k - 1 , l - 1 ) = e5 ( 9 , k , l ) + e3 ( 1 , 2 , k , l ) + ( + e4 ( 2 , 9 , k , l ) + e2 ( 2 , 2 , k , l )) * qx + e4 ( 1 , 5 , k , l ) * qzd + e3 ( 3 , 5 , k , l ) * xzd + e3 ( 2 , 2 , k , l ) * zz + e2 ( 3 , 2 , k , l ) * xzz f ( 4 , 4 , k - 1 , l - 1 ) = e5 ( 4 , k , l ) + e3 ( 1 , 4 , k , l ) + e3 ( 1 , 1 , k , l ) + e1 ( 1 , k , l ) + ( + e4 ( 1 , 4 , k , l ) + e4 ( 2 , 4 , k , l ) + e2 ( 1 , 1 , k , l ) + e2 ( 2 , 1 , k , l )) * qx + ( + e3 ( 3 , 4 , k , l ) + e1 ( 3 , k , l )) * xx f ( 5 , 4 , k - 1 , l - 1 ) = e5 ( 5 , k , l ) + e3 ( 1 , 5 , k , l ) + ( + e4 ( 1 , 5 , k , l ) + e4 ( 2 , 5 , k , l )) * qx + ( + e4 ( 1 , 2 , k , l ) + e2 ( 1 , 2 , k , l )) * qz + e3 ( 3 , 5 , k , l ) * xx + ( + e3 ( 2 , 2 , k , l ) + e3 ( 3 , 2 , k , l )) * xz + e2 ( 3 , 2 , k , l ) * xxz f ( 6 , 4 , k - 1 , l - 1 ) = e5 ( 8 , k , l ) + e3 ( 1 , 3 , k , l ) + ( + e4 ( 2 , 8 , k , l ) + e2 ( 2 , 3 , k , l )) * qx + ( + e4 ( 1 , 4 , k , l ) + e2 ( 1 , 1 , k , l )) * qz + ( + e3 ( 3 , 4 , k , l ) + e1 ( 3 , k , l )) * xz f ( 1 , 5 , k - 1 , l - 1 ) = e5 ( 3 , k , l ) + e3 ( 1 , 3 , k , l ) * 3 + ( + e4 ( 1 , 3 , k , l ) * 2 + e4 ( 2 , 3 , k , l ) + e2 ( 1 , 3 , k , l ) * 2 + e2 ( 2 , 3 , k , l )) * qx + ( + e4 ( 2 , 1 , k , l ) + e2 ( 2 , 1 , k , l ) * 3 ) * qz + ( + e3 ( 2 , 3 , k , l ) + e3 ( 3 , 3 , k , l ) * 2 ) * xx + ( + e3 ( 3 , 1 , k , l ) * 2 + e3 ( 4 , 1 , k , l ) + e1 ( 3 , k , l ) * 2 + e1 ( 4 , k , l )) * xz + e2 ( 3 , 3 , k , l ) * xxx + ( + e2 ( 3 , 1 , k , l ) + e2 ( 4 , 1 , k , l ) * 2 ) * xxz + e1 ( 5 , k , l ) * xxxz f ( 2 , 5 , k - 1 , l - 1 ) = e5 ( 8 , k , l ) + e3 ( 1 , 3 , k , l ) + ( + e4 ( 2 , 8 , k , l ) + e2 ( 2 , 3 , k , l )) * qx + ( + e4 ( 2 , 4 , k , l ) + e2 ( 2 , 1 , k , l )) * qz + ( + e3 ( 4 , 4 , k , l ) + e1 ( 4 , k , l )) * xz f ( 3 , 5 , k - 1 , l - 1 ) = e5 ( 10 , k , l ) + e3 ( 1 , 3 , k , l ) * 3 + ( + e4 ( 2 , 10 , k , l ) + e2 ( 2 , 3 , k , l ) * 3 ) * qx + ( + e4 ( 1 , 6 , k , l ) * 2 + e4 ( 2 , 6 , k , l ) + e2 ( 1 , 1 , k , l ) * 2 + e2 ( 2 , 1 , k , l )) * qz + ( + e3 ( 3 , 6 , k , l ) * 2 + e3 ( 4 , 6 , k , l ) + e1 ( 3 , k , l ) * 2 + e1 ( 4 , k , l )) * xz + ( + e3 ( 2 , 3 , k , l ) + e3 ( 3 , 3 , k , l ) * 2 ) * zz + ( + e2 ( 3 , 3 , k , l ) + e2 ( 4 , 3 , k , l ) * 2 ) * xzz + e2 ( 3 , 1 , k , l ) * zzz + e1 ( 5 , k , l ) * xzzz f ( 4 , 5 , k - 1 , l - 1 ) = e5 ( 5 , k , l ) + e3 ( 1 , 5 , k , l ) + ( + e4 ( 1 , 5 , k , l ) + e4 ( 2 , 5 , k , l )) * qx + ( + e4 ( 2 , 2 , k , l ) + e2 ( 2 , 2 , k , l )) * qz + e3 ( 3 , 5 , k , l ) * xx + ( + e3 ( 3 , 2 , k , l ) + e3 ( 4 , 2 , k , l )) * xz + e2 ( 4 , 2 , k , l ) * xxz f ( 5 , 5 , k - 1 , l - 1 ) = e5 ( 6 , k , l ) + e3 ( 1 , 6 , k , l ) + e3 ( 1 , 1 , k , l ) + e1 ( 1 , k , l ) + ( + e4 ( 1 , 6 , k , l ) + e4 ( 2 , 6 , k , l ) + e2 ( 1 , 1 , k , l ) + e2 ( 2 , 1 , k , l )) * qx + ( + e4 ( 1 , 3 , k , l ) + e4 ( 2 , 3 , k , l ) + e2 ( 1 , 3 , k , l ) + e2 ( 2 , 3 , k , l )) * qz + ( + e3 ( 3 , 6 , k , l ) + e1 ( 3 , k , l )) * xx + ( + e3 ( 2 , 3 , k , l ) + e3 ( 3 , 3 , k , l ) * 2 + e3 ( 4 , 3 , k , l )) * xz + ( + e3 ( 3 , 1 , k , l ) + e1 ( 3 , k , l )) * zz + ( + e2 ( 3 , 3 , k , l ) + e2 ( 4 , 3 , k , l )) * xxz + ( + e2 ( 3 , 1 , k , l ) + e2 ( 4 , 1 , k , l )) * xzz + e1 ( 5 , k , l ) * xxzz f ( 6 , 5 , k - 1 , l - 1 ) = e5 ( 9 , k , l ) + e3 ( 1 , 2 , k , l ) + ( + e4 ( 2 , 9 , k , l ) + e2 ( 2 , 2 , k , l )) * qx + ( + e4 ( 1 , 5 , k , l ) + e4 ( 2 , 5 , k , l )) * qz + ( + e3 ( 3 , 5 , k , l ) + e3 ( 4 , 5 , k , l )) * xz + e3 ( 3 , 2 , k , l ) * zz + e2 ( 4 , 2 , k , l ) * xzz f ( 1 , 6 , k - 1 , l - 1 ) = e5 ( 5 , k , l ) + e3 ( 1 , 5 , k , l ) + e4 ( 1 , 5 , k , l ) * qxd + ( + e4 ( 2 , 2 , k , l ) + e2 ( 2 , 2 , k , l )) * qz + e3 ( 2 , 5 , k , l ) * xx + e3 ( 3 , 2 , k , l ) * xzd + e2 ( 3 , 2 , k , l ) * xxz f ( 2 , 6 , k - 1 , l - 1 ) = e5 ( 12 , k , l ) + e3 ( 1 , 5 , k , l ) * 3 + ( + e4 ( 2 , 7 , k , l ) + e2 ( 2 , 2 , k , l ) * 3 ) * qz f ( 3 , 6 , k - 1 , l - 1 ) = e5 ( 14 , k , l ) + e3 ( 1 , 5 , k , l ) * 3 + ( + e4 ( 1 , 9 , k , l ) * 2 + e4 ( 2 , 9 , k , l ) + e2 ( 1 , 2 , k , l ) * 2 + e2 ( 2 , 2 , k , l )) * qz + ( + e3 ( 2 , 5 , k , l ) + e3 ( 3 , 5 , k , l ) * 2 ) * zz + e2 ( 3 , 2 , k , l ) * zzz f ( 4 , 6 , k - 1 , l - 1 ) = e5 ( 8 , k , l ) + e3 ( 1 , 3 , k , l ) + ( + e4 ( 1 , 8 , k , l ) + e2 ( 1 , 3 , k , l )) * qx + ( + e4 ( 2 , 4 , k , l ) + e2 ( 2 , 1 , k , l )) * qz + ( + e3 ( 3 , 4 , k , l ) + e1 ( 3 , k , l )) * xz f ( 5 , 6 , k - 1 , l - 1 ) = e5 ( 9 , k , l ) + e3 ( 1 , 2 , k , l ) + ( + e4 ( 1 , 9 , k , l ) + e2 ( 1 , 2 , k , l )) * qx + ( + e4 ( 1 , 5 , k , l ) + e4 ( 2 , 5 , k , l )) * qz + ( + e3 ( 2 , 5 , k , l ) + e3 ( 3 , 5 , k , l )) * xz + e3 ( 3 , 2 , k , l ) * zz + e2 ( 3 , 2 , k , l ) * xzz f ( 6 , 6 , k - 1 , l - 1 ) = e5 ( 13 , k , l ) + e3 ( 1 , 6 , k , l ) + e3 ( 1 , 4 , k , l ) + e1 ( 1 , k , l ) + ( + e4 ( 1 , 8 , k , l ) + e4 ( 2 , 8 , k , l ) + e2 ( 1 , 3 , k , l ) + e2 ( 2 , 3 , k , l )) * qz + ( + e3 ( 3 , 4 , k , l ) + e1 ( 3 , k , l )) * zz enddo enddo f (:,:, 1 , 2 ) = f (:,:, 2 , 1 ) end subroutine mcdv_18 ! > ! >    @brief   dpdp case ! > ! >    @details integration of a dpdp case ! > subroutine mcdv_19 ( f , rdat , qx , qz ) implicit none type ( rotaxis_data_t ) :: rdat real ( kind = dp ) :: f ( 6 , 3 , 6 , * ) real ( kind = dp ) :: qx , qz integer , parameter :: kx = 6 , lx = 4 real ( kind = dp ) :: d1 ( 5 , kx , lx ), d2 ( 4 , 3 , kx , lx ), d3 ( 3 , 6 , kx , lx ), & d4 ( 10 , kx , lx ) integer , parameter :: ind ( 10 , kx , lx ) = reshape (& [ 1 , 2 , 3 , 4 , 5 , 6 , 7 , 8 , 9 , 10 , 4 , 7 , 8 , 11 , 12 , 13 , 16 , 17 , 18 , & 19 , 6 , 9 , 10 , 13 , 14 , 15 , 18 , 19 , 20 , 21 , 2 , 4 , 5 , 7 , 8 , 9 , 11 , & 12 , 13 , 14 , 3 , 5 , 6 , 8 , 9 , 10 , 12 , 13 , 14 , 15 , 5 , 8 , 9 , 12 , 13 , & 14 , 17 , 18 , 19 , 20 , 1 , 2 , 3 , 4 , 5 , 6 , 7 , 8 , 9 , 10 , 4 , 7 , 8 , 11 , & 12 , 13 , 16 , 17 , 18 , 19 , 6 , 9 , 10 , 13 , 14 , 15 , 18 , 19 , 20 , 21 , 2 , & 4 , 5 , 7 , 8 , 9 , 11 , 12 , 13 , 14 , 3 , 5 , 6 , 8 , 9 , 10 , 12 , 13 , 14 , & 15 , 5 , 8 , 9 , 12 , 13 , 14 , 17 , 18 , 19 , 20 , 2 , 4 , 5 , 7 , 8 , 9 , 11 , & 12 , 13 , 14 , 7 , 11 , 12 , 16 , 17 , 18 , 22 , 23 , 24 , 25 , 9 , 13 , 14 , & 18 , 19 , 20 , 24 , 25 , 26 , 27 , 4 , 7 , 8 , 11 , 12 , 13 , 16 , 17 , 18 , 19 , & 5 , 8 , 9 , 12 , 13 , 14 , 17 , 18 , 19 , 20 , 8 , 12 , 13 , 17 , 18 , 19 , 23 , & 24 , 25 , 26 , 3 , 5 , 6 , 8 , 9 , 10 , 12 , 13 , 14 , 15 , 8 , 12 , 13 , 17 , & 18 , 19 , 23 , 24 , 25 , 26 , 10 , 14 , 15 , 19 , 20 , 21 , 25 , 26 , 27 , 28 , & 5 , 8 , 9 , 12 , 13 , 14 , 17 , 18 , 19 , 20 , 6 , 9 , 10 , 13 , 14 , 15 , 18 , & 19 , 20 , 21 , 9 , 13 , 14 , 18 , 19 , 20 , 24 , 25 , 26 , 27 ] & , shape ( ind )) integer :: i , j , k , l , m , n , ii , jj real ( kind = dp ) :: xx , zz , xz , xxx , xxz , xzz , zzz real ( kind = dp ) :: qxd , qzd , xzd do j = 1 , 10 d4 ( j , 1 , 1 ) =+ rdat % r05 ( j , 2 ) + rdat % r03 ( j , 1 ) enddo do j = 1 , 6 m = in6 ( j ) d3 ( 1 , j , 1 , 1 ) =+ rdat % r04 ( j , 5 ) + rdat % r02 ( m , 1 ) d3 ( 2 , j , 1 , 1 ) =+ rdat % r04 ( j , 6 ) + rdat % r02 ( m , 2 ) d3 ( 3 , j , 1 , 1 ) =+ rdat % r04 ( j , 7 ) + rdat % r02 ( m , 3 ) enddo do j = 1 , 3 d2 ( 1 , j , 1 , 1 ) =+ rdat % r03 ( j , 18 ) + rdat % r01 ( j , 1 ) d2 ( 2 , j , 1 , 1 ) =+ rdat % r03 ( j , 19 ) + rdat % r01 ( j , 2 ) d2 ( 3 , j , 1 , 1 ) =+ rdat % r03 ( j , 20 ) + rdat % r01 ( j , 3 ) d2 ( 4 , j , 1 , 1 ) =+ rdat % r03 ( j , 21 ) + rdat % r01 ( j , 4 ) enddo j = 1 do i = 1 , 5 d1 ( i , 1 , 1 ) =+ rdat % r02 ( j , i + 31 ) + rdat % r00 ( i , 1 ) enddo do j = 1 , 10 k = ind ( j , 2 , 1 ) d4 ( j , 2 , 1 ) =+ rdat % r05 ( k , 2 ) + rdat % r03 ( j , 1 ) enddo do j = 1 , 6 k = ind ( j , 2 , 1 ) m = in6 ( j ) d3 ( 1 , j , 2 , 1 ) =+ rdat % r04 ( k , 5 ) + rdat % r02 ( m , 1 ) d3 ( 2 , j , 2 , 1 ) =+ rdat % r04 ( k , 6 ) + rdat % r02 ( m , 2 ) d3 ( 3 , j , 2 , 1 ) =+ rdat % r04 ( k , 7 ) + rdat % r02 ( m , 3 ) enddo do j = 1 , 3 k = ind ( j , 2 , 1 ) d2 ( 1 , j , 2 , 1 ) =+ rdat % r03 ( k , 18 ) + rdat % r01 ( j , 1 ) d2 ( 2 , j , 2 , 1 ) =+ rdat % r03 ( k , 19 ) + rdat % r01 ( j , 2 ) d2 ( 3 , j , 2 , 1 ) =+ rdat % r03 ( k , 20 ) + rdat % r01 ( j , 3 ) d2 ( 4 , j , 2 , 1 ) =+ rdat % r03 ( k , 21 ) + rdat % r01 ( j , 4 ) enddo j = 1 k = ind ( j , 2 , 1 ) m = in6 ( k ) do i = 1 , 5 d1 ( i , 2 , 1 ) =+ rdat % r02 ( m , i + 31 ) + rdat % r00 ( i , 1 ) enddo j = 0 do jj = 1 , 4 do ii = 1 , jj j = j + 1 k = ind ( j , 3 , 1 ) l = k - 2 - jj d4 ( j , 3 , 1 ) =+ rdat % r05 ( k , 2 ) - rdat % r04 ( l , 2 ) * 2 + rdat % r03 ( j , 1 ) + rdat % r03 ( j , 2 ) if ( jj > 3 ) cycle m = in6 ( j ) do i = 1 , 3 d3 ( i , j , 3 , 1 ) =+ rdat % r04 ( k , i + 4 ) - rdat % r03 ( l , i + 8 ) * 2 + rdat % r02 ( m , i ) + rdat % r02 ( m , i + 3 ) enddo if ( jj > 2 ) cycle m = in6 ( l ) do i = 1 , 4 d2 ( i , j , 3 , 1 ) =+ rdat % r03 ( k , i + 17 ) - rdat % r02 ( m , i + 15 ) * 2 + rdat % r01 ( j , i ) + rdat % r01 ( j , i + 4 ) enddo if ( jj > 1 ) cycle m = in6 ( k ) do i = 1 , 5 d1 ( i , 3 , 1 ) =+ rdat % r02 ( m , i + 31 ) - rdat % r01 ( l , i + 20 ) * 2 + rdat % r00 ( i , 1 ) + rdat % r00 ( i , 2 ) enddo enddo enddo do j = 1 , 10 k = ind ( j , 4 , 1 ) d4 ( j , 4 , 1 ) =+ rdat % r05 ( k , 2 ) enddo do j = 1 , 6 k = ind ( j , 4 , 1 ) d3 ( 1 , j , 4 , 1 ) =+ rdat % r04 ( k , 5 ) d3 ( 2 , j , 4 , 1 ) =+ rdat % r04 ( k , 6 ) d3 ( 3 , j , 4 , 1 ) =+ rdat % r04 ( k , 7 ) enddo do j = 1 , 3 k = ind ( j , 4 , 1 ) d2 ( 1 , j , 4 , 1 ) =+ rdat % r03 ( k , 18 ) d2 ( 2 , j , 4 , 1 ) =+ rdat % r03 ( k , 19 ) d2 ( 3 , j , 4 , 1 ) =+ rdat % r03 ( k , 20 ) d2 ( 4 , j , 4 , 1 ) =+ rdat % r03 ( k , 21 ) enddo j = 1 k = ind ( j , 4 , 1 ) m = in6 ( k ) do i = 1 , 5 d1 ( i , 4 , 1 ) =+ rdat % r02 ( m , i + 31 ) enddo do j = 1 , 10 k = ind ( j , 5 , 1 ) d4 ( j , 5 , 1 ) =+ rdat % r05 ( k , 2 ) - rdat % r04 ( j , 2 ) enddo do j = 1 , 6 k = ind ( j , 5 , 1 ) d3 ( 1 , j , 5 , 1 ) =+ rdat % r04 ( k , 5 ) - rdat % r03 ( j , 9 ) d3 ( 2 , j , 5 , 1 ) =+ rdat % r04 ( k , 6 ) - rdat % r03 ( j , 10 ) d3 ( 3 , j , 5 , 1 ) =+ rdat % r04 ( k , 7 ) - rdat % r03 ( j , 11 ) enddo do j = 1 , 3 k = ind ( j , 5 , 1 ) m = in6 ( j ) d2 ( 1 , j , 5 , 1 ) =+ rdat % r03 ( k , 18 ) - rdat % r02 ( m , 16 ) d2 ( 2 , j , 5 , 1 ) =+ rdat % r03 ( k , 19 ) - rdat % r02 ( m , 17 ) d2 ( 3 , j , 5 , 1 ) =+ rdat % r03 ( k , 20 ) - rdat % r02 ( m , 18 ) d2 ( 4 , j , 5 , 1 ) =+ rdat % r03 ( k , 21 ) - rdat % r02 ( m , 19 ) enddo j = 1 k = ind ( j , 5 , 1 ) m = in6 ( k ) do i = 1 , 5 d1 ( i , 5 , 1 ) =+ rdat % r02 ( m , i + 31 ) - rdat % r01 ( j , i + 20 ) enddo j = 0 do jj = 1 , 4 do ii = 1 , jj j = j + 1 k = ind ( j , 6 , 1 ) l = k - 2 - jj d4 ( j , 6 , 1 ) =+ rdat % r05 ( k , 2 ) - rdat % r04 ( l , 2 ) if ( jj > 3 ) cycle do i = 1 , 3 d3 ( i , j , 6 , 1 ) =+ rdat % r04 ( k , i + 4 ) - rdat % r03 ( l , i + 8 ) enddo if ( jj > 2 ) cycle m = in6 ( l ) do i = 1 , 4 d2 ( i , j , 6 , 1 ) =+ rdat % r03 ( k , i + 17 ) - rdat % r02 ( m , i + 15 ) enddo if ( jj > 1 ) cycle m = in6 ( k ) do i = 1 , 5 d1 ( i , 6 , 1 ) =+ rdat % r02 ( m , i + 31 ) - rdat % r01 ( l , i + 20 ) enddo enddo enddo do j = 1 , 10 d4 ( j , 1 , 2 ) =- rdat % r06 ( j , 1 ) - rdat % r04 ( j , 4 ) * 3 enddo do j = 1 , 6 d3 ( 1 , j , 1 , 2 ) =- rdat % r05 ( j , 4 ) - rdat % r03 ( j , 15 ) * 3 d3 ( 2 , j , 1 , 2 ) =- rdat % r05 ( j , 5 ) - rdat % r03 ( j , 16 ) * 3 d3 ( 3 , j , 1 , 2 ) =- rdat % r05 ( j , 6 ) - rdat % r03 ( j , 17 ) * 3 enddo do j = 1 , 3 m = in6 ( j ) d2 ( 1 , j , 1 , 2 ) =- rdat % r04 ( j , 14 ) - rdat % r02 ( m , 24 ) * 3 d2 ( 2 , j , 1 , 2 ) =- rdat % r04 ( j , 15 ) - rdat % r02 ( m , 25 ) * 3 d2 ( 3 , j , 1 , 2 ) =- rdat % r04 ( j , 16 ) - rdat % r02 ( m , 26 ) * 3 d2 ( 4 , j , 1 , 2 ) =- rdat % r04 ( j , 17 ) - rdat % r02 ( m , 27 ) * 3 enddo j = 1 do i = 1 , 5 d1 ( i , 1 , 2 ) =- rdat % r03 ( j , i + 29 ) - rdat % r01 ( j , i + 30 ) * 3 enddo do j = 1 , 10 k = ind ( j , 2 , 2 ) d4 ( j , 2 , 2 ) =- rdat % r06 ( k , 1 ) - rdat % r04 ( j , 4 ) enddo do j = 1 , 6 k = ind ( j , 2 , 2 ) d3 ( 1 , j , 2 , 2 ) =- rdat % r05 ( k , 4 ) - rdat % r03 ( j , 15 ) d3 ( 2 , j , 2 , 2 ) =- rdat % r05 ( k , 5 ) - rdat % r03 ( j , 16 ) d3 ( 3 , j , 2 , 2 ) =- rdat % r05 ( k , 6 ) - rdat % r03 ( j , 17 ) enddo do j = 1 , 3 k = ind ( j , 2 , 2 ) m = in6 ( j ) d2 ( 1 , j , 2 , 2 ) =- rdat % r04 ( k , 14 ) - rdat % r02 ( m , 24 ) d2 ( 2 , j , 2 , 2 ) =- rdat % r04 ( k , 15 ) - rdat % r02 ( m , 25 ) d2 ( 3 , j , 2 , 2 ) =- rdat % r04 ( k , 16 ) - rdat % r02 ( m , 26 ) d2 ( 4 , j , 2 , 2 ) =- rdat % r04 ( k , 17 ) - rdat % r02 ( m , 27 ) enddo j = 1 k = ind ( j , 2 , 2 ) do i = 1 , 5 d1 ( i , 2 , 2 ) =- rdat % r03 ( k , i + 29 ) - rdat % r01 ( j , i + 30 ) enddo j = 0 do jj = 1 , 4 do ii = 1 , jj j = j + 1 k = ind ( j , 3 , 2 ) l = k - 2 - jj d4 ( j , 3 , 2 ) =- rdat % r06 ( k , 1 ) + rdat % r05 ( l , 3 ) * 2 - rdat % r04 ( j , 3 ) - rdat % r04 ( j , 4 ) if ( jj > 3 ) cycle do i = 1 , 3 d3 ( i , j , 3 , 2 ) =- rdat % r05 ( k , i + 3 ) + rdat % r04 ( l , i + 7 ) * 2 - rdat % r03 ( j , i + 11 ) - rdat % r03 ( j , i + 14 ) enddo if ( jj > 2 ) cycle m = in6 ( j ) do i = 1 , 4 d2 ( i , j , 3 , 2 ) =- rdat % r04 ( k , i + 13 ) + rdat % r03 ( l , i + 21 ) * 2 - rdat % r02 ( m , i + 19 ) - rdat % r02 ( m , i + 23 ) enddo if ( jj > 1 ) cycle m = in6 ( l ) do i = 1 , 5 d1 ( i , 3 , 2 ) =- rdat % r03 ( k , i + 29 ) + rdat % r02 ( m , i + 36 ) * 2 - rdat % r01 ( j , i + 25 ) - rdat % r01 ( j , i + 30 ) enddo enddo enddo do j = 1 , 10 k = ind ( j , 4 , 2 ) d4 ( j , 4 , 2 ) =- rdat % r06 ( k , 1 ) - rdat % r04 ( k , 4 ) enddo do j = 1 , 6 k = ind ( j , 4 , 2 ) d3 ( 1 , j , 4 , 2 ) =- rdat % r05 ( k , 4 ) - rdat % r03 ( k , 15 ) d3 ( 2 , j , 4 , 2 ) =- rdat % r05 ( k , 5 ) - rdat % r03 ( k , 16 ) d3 ( 3 , j , 4 , 2 ) =- rdat % r05 ( k , 6 ) - rdat % r03 ( k , 17 ) enddo do j = 1 , 3 k = ind ( j , 4 , 2 ) m = in6 ( k ) d2 ( 1 , j , 4 , 2 ) =- rdat % r04 ( k , 14 ) - rdat % r02 ( m , 24 ) d2 ( 2 , j , 4 , 2 ) =- rdat % r04 ( k , 15 ) - rdat % r02 ( m , 25 ) d2 ( 3 , j , 4 , 2 ) =- rdat % r04 ( k , 16 ) - rdat % r02 ( m , 26 ) d2 ( 4 , j , 4 , 2 ) =- rdat % r04 ( k , 17 ) - rdat % r02 ( m , 27 ) enddo j = 1 k = ind ( j , 4 , 2 ) do i = 1 , 5 d1 ( i , 4 , 2 ) =- rdat % r03 ( k , i + 29 ) - rdat % r01 ( k , i + 30 ) enddo do j = 1 , 10 k = ind ( j , 5 , 2 ) d4 ( j , 5 , 2 ) =- rdat % r06 ( k , 1 ) - rdat % r04 ( k , 4 ) + rdat % r05 ( j , 3 ) + rdat % r03 ( j , 5 ) enddo do j = 1 , 6 k = ind ( j , 5 , 2 ) m = in6 ( j ) d3 ( 1 , j , 5 , 2 ) =- rdat % r05 ( k , 4 ) - rdat % r03 ( k , 15 ) + rdat % r04 ( j , 8 ) + rdat % r02 ( m , 13 ) d3 ( 2 , j , 5 , 2 ) =- rdat % r05 ( k , 5 ) - rdat % r03 ( k , 16 ) + rdat % r04 ( j , 9 ) + rdat % r02 ( m , 14 ) d3 ( 3 , j , 5 , 2 ) =- rdat % r05 ( k , 6 ) - rdat % r03 ( k , 17 ) + rdat % r04 ( j , 10 ) + rdat % r02 ( m , 15 ) enddo do j = 1 , 3 k = ind ( j , 5 , 2 ) m = in6 ( k ) d2 ( 1 , j , 5 , 2 ) =- rdat % r04 ( k , 14 ) - rdat % r02 ( m , 24 ) + rdat % r03 ( j , 22 ) + rdat % r01 ( j , 17 ) d2 ( 2 , j , 5 , 2 ) =- rdat % r04 ( k , 15 ) - rdat % r02 ( m , 25 ) + rdat % r03 ( j , 23 ) + rdat % r01 ( j , 18 ) d2 ( 3 , j , 5 , 2 ) =- rdat % r04 ( k , 16 ) - rdat % r02 ( m , 26 ) + rdat % r03 ( j , 24 ) + rdat % r01 ( j , 19 ) d2 ( 4 , j , 5 , 2 ) =- rdat % r04 ( k , 17 ) - rdat % r02 ( m , 27 ) + rdat % r03 ( j , 25 ) + rdat % r01 ( j , 20 ) enddo j = 1 k = ind ( j , 5 , 2 ) do i = 1 , 5 d1 ( i , 5 , 2 ) =- rdat % r03 ( k , i + 29 ) - rdat % r01 ( k , i + 30 ) + rdat % r02 ( j , i + 36 ) + rdat % r00 ( i , 5 ) enddo j = 0 do jj = 1 , 4 do ii = 1 , jj j = j + 1 k = ind ( j , 6 , 2 ) l = k - 2 - jj d4 ( j , 6 , 2 ) =- rdat % r06 ( k , 1 ) + rdat % r05 ( l , 3 ) if ( jj > 3 ) cycle do i = 1 , 3 d3 ( i , j , 6 , 2 ) =- rdat % r05 ( k , i + 3 ) + rdat % r04 ( l , i + 7 ) enddo if ( jj > 2 ) cycle do i = 1 , 4 d2 ( i , j , 6 , 2 ) =- rdat % r04 ( k , i + 13 ) + rdat % r03 ( l , i + 21 ) enddo if ( jj > 1 ) cycle m = in6 ( l ) do i = 1 , 5 d1 ( i , 6 , 2 ) =- rdat % r03 ( k , i + 29 ) + rdat % r02 ( m , i + 36 ) enddo enddo enddo j = 0 do jj = 1 , 4 do ii = 1 , jj j = j + 1 k = ind ( j , 2 , 3 ) l = k - 3 - jj - jj d4 ( j , 2 , 3 ) =- rdat % r06 ( k , 1 ) - rdat % r04 ( l , 4 ) * 3 if ( jj > 3 ) cycle do i = 1 , 3 d3 ( i , j , 2 , 3 ) =- rdat % r05 ( k , i + 3 ) - rdat % r03 ( l , i + 14 ) * 3 enddo if ( jj > 2 ) cycle m = in6 ( l ) do i = 1 , 4 d2 ( i , j , 2 , 3 ) =- rdat % r04 ( k , i + 13 ) - rdat % r02 ( m , i + 23 ) * 3 enddo if ( jj > 1 ) cycle do i = 1 , 5 d1 ( i , 2 , 3 ) =- rdat % r03 ( k , i + 29 ) - rdat % r01 ( l , i + 30 ) * 3 enddo enddo enddo j = 0 do jj = 1 , 4 do ii = 1 , jj j = j + 1 k = ind ( j , 3 , 3 ) l = k - 3 - jj m = l - 2 - jj d4 ( j , 3 , 3 ) =- rdat % r06 ( k , 1 ) + rdat % r05 ( l , 3 ) * 2 - rdat % r04 ( m , 3 ) - rdat % r04 ( m , 4 ) if ( jj > 3 ) cycle do i = 1 , 3 d3 ( i , j , 3 , 3 ) =- rdat % r05 ( k , i + 3 ) + rdat % r04 ( l , i + 7 ) * 2 - rdat % r03 ( m , i + 11 ) - rdat % r03 ( m , i + 14 ) enddo if ( jj > 2 ) cycle n = in6 ( m ) do i = 1 , 4 d2 ( i , j , 3 , 3 ) =- rdat % r04 ( k , i + 13 ) + rdat % r03 ( l , i + 21 ) * 2 - rdat % r02 ( n , i + 19 ) - rdat % r02 ( n , i + 23 ) enddo if ( jj > 1 ) cycle n = in6 ( l ) do i = 1 , 5 d1 ( i , 3 , 3 ) =- rdat % r03 ( k , i + 29 ) + rdat % r02 ( n , i + 36 ) * 2 - rdat % r01 ( m , i + 25 ) - rdat % r01 ( m , i + 30 ) enddo enddo enddo j = 0 do jj = 1 , 4 do ii = 1 , jj j = j + 1 k = ind ( j , 6 , 3 ) l = k - 3 - jj m = l - jj d4 ( j , 6 , 3 ) =- rdat % r06 ( k , 1 ) - rdat % r04 ( m , 4 ) + rdat % r05 ( l , 3 ) + rdat % r03 ( j , 5 ) if ( jj > 3 ) cycle n = in6 ( j ) do i = 1 , 3 d3 ( i , j , 6 , 3 ) =- rdat % r05 ( k , i + 3 ) - rdat % r03 ( m , i + 14 ) + rdat % r04 ( l , i + 7 ) + rdat % r02 ( n , i + 12 ) enddo if ( jj > 2 ) cycle n = in6 ( m ) do i = 1 , 4 d2 ( i , j , 6 , 3 ) =- rdat % r04 ( k , i + 13 ) - rdat % r02 ( n , i + 23 ) + rdat % r03 ( l , i + 21 ) + rdat % r01 ( j , i + 16 ) enddo if ( jj > 1 ) cycle n = in6 ( l ) do i = 1 , 5 d1 ( i , 6 , 3 ) =- rdat % r03 ( k , i + 29 ) - rdat % r01 ( m , i + 30 ) + rdat % r02 ( n , i + 36 ) + rdat % r00 ( i , 5 ) enddo enddo enddo do j = 1 , 10 k = ind ( j , 1 , 4 ) d4 ( j , 1 , 4 ) =- rdat % r06 ( k , 1 ) - rdat % r04 ( k , 4 ) + rdat % r05 ( j , 1 ) + rdat % r03 ( j , 4 ) enddo do j = 1 , 6 k = ind ( j , 1 , 4 ) m = in6 ( j ) d3 ( 1 , j , 1 , 4 ) =- rdat % r05 ( k , 4 ) - rdat % r03 ( k , 15 ) + rdat % r04 ( j , 11 ) + rdat % r02 ( m , 10 ) d3 ( 2 , j , 1 , 4 ) =- rdat % r05 ( k , 5 ) - rdat % r03 ( k , 16 ) + rdat % r04 ( j , 12 ) + rdat % r02 ( m , 11 ) d3 ( 3 , j , 1 , 4 ) =- rdat % r05 ( k , 6 ) - rdat % r03 ( k , 17 ) + rdat % r04 ( j , 13 ) + rdat % r02 ( m , 12 ) enddo do j = 1 , 3 k = ind ( j , 1 , 4 ) m = in6 ( k ) d2 ( 1 , j , 1 , 4 ) =- rdat % r04 ( k , 14 ) - rdat % r02 ( m , 24 ) + rdat % r03 ( j , 26 ) + rdat % r01 ( j , 13 ) d2 ( 2 , j , 1 , 4 ) =- rdat % r04 ( k , 15 ) - rdat % r02 ( m , 25 ) + rdat % r03 ( j , 27 ) + rdat % r01 ( j , 14 ) d2 ( 3 , j , 1 , 4 ) =- rdat % r04 ( k , 16 ) - rdat % r02 ( m , 26 ) + rdat % r03 ( j , 28 ) + rdat % r01 ( j , 15 ) d2 ( 4 , j , 1 , 4 ) =- rdat % r04 ( k , 17 ) - rdat % r02 ( m , 27 ) + rdat % r03 ( j , 29 ) + rdat % r01 ( j , 16 ) enddo j = 1 k = ind ( j , 1 , 4 ) do i = 1 , 5 d1 ( i , 1 , 4 ) =- rdat % r03 ( k , i + 29 ) - rdat % r01 ( k , i + 30 ) + rdat % r02 ( j , i + 41 ) + rdat % r00 ( i , 4 ) enddo j = 0 do jj = 1 , 4 do ii = 1 , jj j = j + 1 k = ind ( j , 2 , 4 ) l = k - 3 - jj m = l - jj d4 ( j , 2 , 4 ) =- rdat % r06 ( k , 1 ) + rdat % r05 ( l , 1 ) - rdat % r04 ( m , 4 ) + rdat % r03 ( j , 4 ) if ( jj > 3 ) cycle n = in6 ( j ) do i = 1 , 3 d3 ( i , j , 2 , 4 ) =- rdat % r05 ( k , i + 3 ) + rdat % r04 ( l , i + 10 ) - rdat % r03 ( m , i + 14 ) + rdat % r02 ( n , i + 9 ) enddo if ( jj > 2 ) cycle n = in6 ( m ) do i = 1 , 4 d2 ( i , j , 2 , 4 ) =- rdat % r04 ( k , i + 13 ) + rdat % r03 ( l , i + 25 ) - rdat % r02 ( n , i + 23 ) + rdat % r01 ( j , i + 12 ) enddo if ( jj > 1 ) cycle n = in6 ( l ) do i = 1 , 5 d1 ( i , 2 , 4 ) =- rdat % r03 ( k , i + 29 ) + rdat % r02 ( n , i + 41 ) - rdat % r01 ( m , i + 30 ) + rdat % r00 ( i , 4 ) enddo enddo enddo j = 0 do jj = 1 , 4 do ii = 1 , jj j = j + 1 k = ind ( j , 3 , 4 ) l = k - 3 - jj m = l - 2 - jj d4 ( j , 3 , 4 ) =- rdat % r06 ( k , 1 ) + rdat % r05 ( l , 1 ) + rdat % r05 ( l , 3 ) * 2 & & - rdat % r04 ( m , 1 ) * 2 - rdat % r04 ( m , 3 ) - rdat % r04 ( m , 4 ) * 3 & & + rdat % r03 ( j , 3 ) + rdat % r03 ( j , 4 ) + rdat % r03 ( j , 5 ) * 2 if ( jj > 3 ) cycle n = in6 ( j ) do i = 1 , 3 d3 ( i , j , 3 , 4 ) =- rdat % r05 ( k , i + 3 ) + rdat % r04 ( l , i + 7 ) * 2 + rdat % r04 ( l , i + 10 ) & & - rdat % r03 ( m , i + 5 ) * 2 - rdat % r03 ( m , i + 11 ) - rdat % r03 ( m , i + 14 ) * 3 & & + rdat % r02 ( n , i + 6 ) + rdat % r02 ( n , i + 9 ) + rdat % r02 ( n , i + 12 ) * 2 enddo if ( jj > 2 ) cycle n = in6 ( m ) do i = 1 , 4 d2 ( i , j , 3 , 4 ) =- rdat % r04 ( k , i + 13 ) + rdat % r03 ( l , i + 21 ) * 2 + rdat % r03 ( l , i + 25 ) & & - rdat % r02 ( n , i + 19 ) - rdat % r02 ( n , i + 23 ) * 3 - rdat % r02 ( n , i + 27 ) * 2 & & + rdat % r01 ( j , i + 8 ) + rdat % r01 ( j , i + 12 ) + rdat % r01 ( j , i + 16 ) * 2 enddo if ( jj > 1 ) cycle n = in6 ( l ) do i = 1 , 5 d1 ( i , 3 , 4 ) =- rdat % r03 ( k , i + 29 ) + rdat % r02 ( n , i + 36 ) * 2 + rdat % r02 ( n , i + 41 ) & & - rdat % r01 ( m , i + 25 ) - rdat % r01 ( m , i + 30 ) * 3 - rdat % r01 ( m , i + 35 ) * 2 & & + rdat % r00 ( i , 3 ) + rdat % r00 ( i , 4 ) + rdat % r00 ( i , 5 ) * 2 enddo enddo enddo j = 0 do jj = 1 , 4 do ii = 1 , jj j = j + 1 k = ind ( j , 4 , 4 ) l = k - 2 - jj d4 ( j , 4 , 4 ) =- rdat % r06 ( k , 1 ) + rdat % r05 ( l , 1 ) if ( jj > 3 ) cycle do i = 1 , 3 d3 ( i , j , 4 , 4 ) =- rdat % r05 ( k , i + 3 ) + rdat % r04 ( l , i + 10 ) enddo if ( jj > 2 ) cycle do i = 1 , 4 d2 ( i , j , 4 , 4 ) =- rdat % r04 ( k , i + 13 ) + rdat % r03 ( l , i + 25 ) enddo if ( jj > 1 ) cycle m = in6 ( l ) do i = 1 , 5 d1 ( i , 4 , 4 ) =- rdat % r03 ( k , i + 29 ) + rdat % r02 ( m , i + 41 ) enddo enddo enddo j = 0 do jj = 1 , 4 do ii = 1 , jj j = j + 1 k = ind ( j , 5 , 4 ) l = k - 2 - jj d4 ( j , 5 , 4 ) =- rdat % r06 ( k , 1 ) + rdat % r05 ( l , 1 ) + rdat % r05 ( l , 3 ) & & - rdat % r04 ( j , 1 ) - rdat % r04 ( j , 4 ) if ( jj > 3 ) cycle do i = 1 , 3 d3 ( i , j , 5 , 4 ) =- rdat % r05 ( k , i + 3 ) + rdat % r04 ( l , i + 7 ) + rdat % r04 ( l , i + 10 ) & & - rdat % r03 ( j , i + 5 ) - rdat % r03 ( j , i + 14 ) enddo if ( jj > 2 ) cycle m = in6 ( j ) do i = 1 , 4 d2 ( i , j , 5 , 4 ) =- rdat % r04 ( k , i + 13 ) + rdat % r03 ( l , i + 21 ) + rdat % r03 ( l , i + 25 ) & & - rdat % r02 ( m , i + 23 ) - rdat % r02 ( m , i + 27 ) enddo if ( jj > 1 ) cycle m = in6 ( l ) do i = 1 , 5 d1 ( i , 5 , 4 ) =- rdat % r03 ( k , i + 29 ) + rdat % r02 ( m , i + 36 ) + rdat % r02 ( m , i + 41 ) & & - rdat % r01 ( j , i + 30 ) - rdat % r01 ( j , i + 35 ) enddo enddo enddo j = 0 do jj = 1 , 4 do ii = 1 , jj j = j + 1 k = ind ( j , 6 , 4 ) l = k - 3 - jj m = l - 2 - jj d4 ( j , 6 , 4 ) =- rdat % r06 ( k , 1 ) + rdat % r05 ( l , 1 ) + rdat % r05 ( l , 3 ) & & - rdat % r04 ( m , 1 ) - rdat % r04 ( m , 4 ) if ( jj > 3 ) cycle do i = 1 , 3 d3 ( i , j , 6 , 4 ) =- rdat % r05 ( k , i + 3 ) + rdat % r04 ( l , i + 7 ) + rdat % r04 ( l , i + 10 ) & & - rdat % r03 ( m , i + 5 ) - rdat % r03 ( m , i + 14 ) enddo if ( jj > 2 ) cycle n = in6 ( m ) do i = 1 , 4 d2 ( i , j , 6 , 4 ) =- rdat % r04 ( k , i + 13 ) + rdat % r03 ( l , i + 21 ) + rdat % r03 ( l , i + 25 ) & & - rdat % r02 ( n , i + 23 ) - rdat % r02 ( n , i + 27 ) enddo if ( jj > 1 ) cycle n = in6 ( l ) do i = 1 , 5 d1 ( i , 6 , 4 ) =- rdat % r03 ( k , i + 29 ) + rdat % r02 ( n , i + 36 ) + rdat % r02 ( n , i + 41 ) & & - rdat % r01 ( m , i + 30 ) - rdat % r01 ( m , i + 35 ) enddo enddo enddo xx = qx * qx zz = qz * qz xz = qx * qz xxx = xx * qx xxz = xx * qz xzz = zz * qx zzz = zz * qz qxd = qx + qx qzd = qz + qz xzd = xz + xz do l = 2 , lx do k = 1 , kx if ( k == 1 . and . l == 3 ) cycle if ( k == 4 . and . l == 3 ) cycle if ( k == 5 . and . l == 3 ) cycle f ( 1 , 1 , k , l - 1 ) = d4 ( 1 , k , l ) + d2 ( 2 , 1 , k , l ) * 3 + ( + d3 ( 2 , 1 , k , l ) * 2 + d3 ( 3 , 1 , k , l ) + d1 ( 3 , k , l ) * 2 + d1 ( 4 , k , l )) * qx + ( + d2 ( 3 , 1 , k , l ) + d2 ( 4 , 1 , k , l ) * 2 ) * xx + d1 ( 5 , k , l ) * xxx f ( 2 , 1 , k , l - 1 ) = d4 ( 4 , k , l ) + d2 ( 2 , 1 , k , l ) + ( + d3 ( 3 , 4 , k , l ) + d1 ( 4 , k , l )) * qx f ( 3 , 1 , k , l - 1 ) = d4 ( 6 , k , l ) + d2 ( 2 , 1 , k , l ) + ( + d3 ( 3 , 6 , k , l ) + d1 ( 4 , k , l )) * qx + d3 ( 2 , 3 , k , l ) * qzd + d2 ( 4 , 3 , k , l ) * xzd + d2 ( 3 , 1 , k , l ) * zz + d1 ( 5 , k , l ) * xzz f ( 4 , 1 , k , l - 1 ) = d4 ( 2 , k , l ) + d2 ( 2 , 2 , k , l ) + ( + d3 ( 2 , 2 , k , l ) + d3 ( 3 , 2 , k , l )) * qx + d2 ( 4 , 2 , k , l ) * xx f ( 5 , 1 , k , l - 1 ) = d4 ( 3 , k , l ) + d2 ( 2 , 3 , k , l ) + ( + d3 ( 2 , 3 , k , l ) + d3 ( 3 , 3 , k , l )) * qx + ( + d3 ( 2 , 1 , k , l ) + d1 ( 3 , k , l )) * qz + d2 ( 4 , 3 , k , l ) * xx + ( + d2 ( 3 , 1 , k , l ) + d2 ( 4 , 1 , k , l )) * xz + d1 ( 5 , k , l ) * xxz f ( 6 , 1 , k , l - 1 ) = d4 ( 5 , k , l ) + d3 ( 3 , 5 , k , l ) * qx + d3 ( 2 , 2 , k , l ) * qz + d2 ( 4 , 2 , k , l ) * xz f ( 1 , 2 , k , l - 1 ) = d4 ( 2 , k , l ) + d2 ( 2 , 2 , k , l ) + d3 ( 2 , 2 , k , l ) * qxd + d2 ( 3 , 2 , k , l ) * xx f ( 2 , 2 , k , l - 1 ) = d4 ( 7 , k , l ) + d2 ( 2 , 2 , k , l ) * 3 f ( 3 , 2 , k , l - 1 ) = d4 ( 9 , k , l ) + d2 ( 2 , 2 , k , l ) + d3 ( 2 , 5 , k , l ) * qzd + d2 ( 3 , 2 , k , l ) * zz f ( 4 , 2 , k , l - 1 ) = d4 ( 4 , k , l ) + d2 ( 2 , 1 , k , l ) + ( + d3 ( 2 , 4 , k , l ) + d1 ( 3 , k , l )) * qx f ( 5 , 2 , k , l - 1 ) = d4 ( 5 , k , l ) + d3 ( 2 , 5 , k , l ) * qx + d3 ( 2 , 2 , k , l ) * qz + d2 ( 3 , 2 , k , l ) * xz f ( 6 , 2 , k , l - 1 ) = d4 ( 8 , k , l ) + d2 ( 2 , 3 , k , l ) + ( + d3 ( 2 , 4 , k , l ) + d1 ( 3 , k , l )) * qz f ( 1 , 3 , k , l - 1 ) = d4 ( 3 , k , l ) + d2 ( 2 , 3 , k , l ) + d3 ( 2 , 3 , k , l ) * qxd + ( + d3 ( 3 , 1 , k , l ) + d1 ( 4 , k , l )) * qz + d2 ( 3 , 3 , k , l ) * xx + d2 ( 4 , 1 , k , l ) * xzd + d1 ( 5 , k , l ) * xxz f ( 2 , 3 , k , l - 1 ) = d4 ( 8 , k , l ) + d2 ( 2 , 3 , k , l ) + ( + d3 ( 3 , 4 , k , l ) + d1 ( 4 , k , l )) * qz f ( 3 , 3 , k , l - 1 ) = d4 ( 10 , k , l ) + d2 ( 2 , 3 , k , l ) * 3 + ( + d3 ( 2 , 6 , k , l ) * 2 + d3 ( 3 , 6 , k , l ) + d1 ( 3 , k , l ) * 2 + d1 ( 4 , k , l )) * qz + ( + d2 ( 3 , 3 , k , l ) + d2 ( 4 , 3 , k , l ) * 2 ) * zz + d1 ( 5 , k , l ) * zzz f ( 4 , 3 , k , l - 1 ) = d4 ( 5 , k , l ) + d3 ( 2 , 5 , k , l ) * qx + d3 ( 3 , 2 , k , l ) * qz + d2 ( 4 , 2 , k , l ) * xz f ( 5 , 3 , k , l - 1 ) = d4 ( 6 , k , l ) + d2 ( 2 , 1 , k , l ) + ( + d3 ( 2 , 6 , k , l ) + d1 ( 3 , k , l )) * qx + ( + d3 ( 2 , 3 , k , l ) + d3 ( 3 , 3 , k , l )) * qz + ( + d2 ( 3 , 3 , k , l ) + d2 ( 4 , 3 , k , l )) * xz + d2 ( 4 , 1 , k , l ) * zz + d1 ( 5 , k , l ) * xzz f ( 6 , 3 , k , l - 1 ) = d4 ( 9 , k , l ) + d2 ( 2 , 2 , k , l ) + ( + d3 ( 2 , 5 , k , l ) + d3 ( 3 , 5 , k , l )) * qz + d2 ( 4 , 2 , k , l ) * zz enddo enddo f (:,:, 1 , 2 ) = f (:,:, 4 , 1 ) f (:,:, 4 , 2 ) = f (:,:, 2 , 1 ) f (:,:, 5 , 2 ) = f (:,:, 6 , 1 ) end subroutine mcdv_19 ! > ! >    @brief   dddp case ! > ! >    @details integration of a dddp case ! > subroutine mcdv_20 ( f , rdat , qx , qz ) implicit none type ( rotaxis_data_t ) :: rdat real ( kind = dp ) :: f ( 6 , 6 , 6 , * ) real ( kind = dp ) :: qx , qz integer , parameter :: kx = 6 , lx = 4 real ( kind = dp ) :: e1 ( 5 , kx , lx ), e2 ( 4 , 3 , kx , lx ), e3 ( 4 , 6 , kx , lx ), & e4 ( 2 , 10 , kx , lx ), e5 ( 15 , kx , lx ) integer :: ind ( 15 , kx , lx ) = reshape (& [ 1 , 2 , 3 , 4 , 5 , 6 , 7 , 8 , 9 , 10 , 11 , 12 , 13 , 14 , 15 , 4 , 7 , 8 , 11 , & 12 , 13 , 16 , 17 , 18 , 19 , 22 , 23 , 24 , 25 , 26 , 6 , 9 , 10 , 13 , 14 , 15 , & 18 , 19 , 20 , 21 , 24 , 25 , 26 , 27 , 28 , 2 , 4 , 5 , 7 , 8 , 9 , 11 , 12 , 13 , & 14 , 16 , 17 , 18 , 19 , 20 , 3 , 5 , 6 , 8 , 9 , 10 , 12 , 13 , 14 , 15 , 17 , 18 , & 19 , 20 , 21 , 5 , 8 , 9 , 12 , 13 , 14 , 17 , 18 , 19 , 20 , 23 , 24 , 25 , 26 , & 27 , 1 , 2 , 3 , 4 , 5 , 6 , 7 , 8 , 9 , 10 , 11 , 12 , 13 , 14 , 15 , 4 , 7 , 8 , & 11 , 12 , 13 , 16 , 17 , 18 , 19 , 22 , 23 , 24 , 25 , 26 , 6 , 9 , 10 , 13 , 14 , & 15 , 18 , 19 , 20 , 21 , 24 , 25 , 26 , 27 , 28 , 2 , 4 , 5 , 7 , 8 , 9 , 11 , 12 , & 13 , 14 , 16 , 17 , 18 , 19 , 20 , 3 , 5 , 6 , 8 , 9 , 10 , 12 , 13 , 14 , 15 , 17 , & 18 , 19 , 20 , 21 , 5 , 8 , 9 , 12 , 13 , 14 , 17 , 18 , 19 , 20 , 23 , 24 , 25 , & 26 , 27 , 2 , 4 , 5 , 7 , 8 , 9 , 11 , 12 , 13 , 14 , 16 , 17 , 18 , 19 , 20 , 7 , & 11 , 12 , 16 , 17 , 18 , 22 , 23 , 24 , 25 , 29 , 30 , 31 , 32 , 33 , 9 , 13 , 14 , & 18 , 19 , 20 , 24 , 25 , 26 , 27 , 31 , 32 , 33 , 34 , 35 , 4 , 7 , 8 , 11 , 12 , & 13 , 16 , 17 , 18 , 19 , 22 , 23 , 24 , 25 , 26 , 5 , 8 , 9 , 12 , 13 , 14 , 17 , & 18 , 19 , 20 , 23 , 24 , 25 , 26 , 27 , 8 , 12 , 13 , 17 , 18 , 19 , 23 , 24 , 25 , & 26 , 30 , 31 , 32 , 33 , 34 , 3 , 5 , 6 , 8 , 9 , 10 , 12 , 13 , 14 , 15 , 17 , 18 , & 19 , 20 , 21 , 8 , 12 , 13 , 17 , 18 , 19 , 23 , 24 , 25 , 26 , 30 , 31 , 32 , 33 , & 34 , 10 , 14 , 15 , 19 , 20 , 21 , 25 , 26 , 27 , 28 , 32 , 33 , 34 , 35 , 36 , 5 , & 8 , 9 , 12 , 13 , 14 , 17 , 18 , 19 , 20 , 23 , 24 , 25 , 26 , 27 , 6 , 9 , 10 , & 13 , 14 , 15 , 18 , 19 , 20 , 21 , 24 , 25 , 26 , 27 , 28 , 9 , 13 , 14 , 18 , 19 , & 20 , 24 , 25 , 26 , 27 , 31 , 32 , 33 , 34 , 35 ] & , shape ( ind )) integer :: i , j , k , l , m , n , ii , jj real ( kind = dp ) :: xx , zz , xz , xxx , xxz , xzz , zzz real ( kind = dp ) :: xxxx , xxzz , xxxz , xzzz , zzzz real ( kind = dp ) :: xxxd , xxzd , xzzd , zzzd real ( kind = dp ) :: xzq real ( kind = dp ) :: qxd , qzd , xzd do j = 1 , 15 e5 ( j , 1 , 1 ) =+ rdat % r06 ( j , 2 ) + rdat % r04 ( j , 1 ) enddo do j = 1 , 10 e4 ( 1 , j , 1 , 1 ) =+ rdat % r05 ( j , 5 ) + rdat % r03 ( j , 1 ) e4 ( 2 , j , 1 , 1 ) =+ rdat % r05 ( j , 6 ) + rdat % r03 ( j , 2 ) enddo do j = 1 , 6 m = in6 ( j ) e3 ( 1 , j , 1 , 1 ) =+ rdat % r04 ( j , 14 ) + rdat % r02 ( m , 1 ) e3 ( 2 , j , 1 , 1 ) =+ rdat % r04 ( j , 15 ) + rdat % r02 ( m , 2 ) e3 ( 3 , j , 1 , 1 ) =+ rdat % r04 ( j , 16 ) + rdat % r02 ( m , 3 ) e3 ( 4 , j , 1 , 1 ) =+ rdat % r04 ( j , 17 ) + rdat % r02 ( m , 4 ) enddo do j = 1 , 3 e2 ( 1 , j , 1 , 1 ) =+ rdat % r03 ( j , 27 ) + rdat % r01 ( j , 1 ) e2 ( 2 , j , 1 , 1 ) =+ rdat % r03 ( j , 28 ) + rdat % r01 ( j , 2 ) e2 ( 3 , j , 1 , 1 ) =+ rdat % r03 ( j , 29 ) + rdat % r01 ( j , 3 ) e2 ( 4 , j , 1 , 1 ) =+ rdat % r03 ( j , 30 ) + rdat % r01 ( j , 4 ) enddo j = 1 do i = 1 , 5 e1 ( i , 1 , 1 ) =+ rdat % r02 ( j , i + 36 ) + rdat % r00 ( i , 1 ) enddo do j = 1 , 15 k = ind ( j , 2 , 1 ) e5 ( j , 2 , 1 ) =+ rdat % r06 ( k , 2 ) + rdat % r04 ( j , 1 ) enddo do j = 1 , 10 k = ind ( j , 2 , 1 ) e4 ( 1 , j , 2 , 1 ) =+ rdat % r05 ( k , 5 ) + rdat % r03 ( j , 1 ) e4 ( 2 , j , 2 , 1 ) =+ rdat % r05 ( k , 6 ) + rdat % r03 ( j , 2 ) enddo do j = 1 , 6 k = ind ( j , 2 , 1 ) m = in6 ( j ) e3 ( 1 , j , 2 , 1 ) =+ rdat % r04 ( k , 14 ) + rdat % r02 ( m , 1 ) e3 ( 2 , j , 2 , 1 ) =+ rdat % r04 ( k , 15 ) + rdat % r02 ( m , 2 ) e3 ( 3 , j , 2 , 1 ) =+ rdat % r04 ( k , 16 ) + rdat % r02 ( m , 3 ) e3 ( 4 , j , 2 , 1 ) =+ rdat % r04 ( k , 17 ) + rdat % r02 ( m , 4 ) enddo do j = 1 , 3 k = ind ( j , 2 , 1 ) e2 ( 1 , j , 2 , 1 ) =+ rdat % r03 ( k , 27 ) + rdat % r01 ( j , 1 ) e2 ( 2 , j , 2 , 1 ) =+ rdat % r03 ( k , 28 ) + rdat % r01 ( j , 2 ) e2 ( 3 , j , 2 , 1 ) =+ rdat % r03 ( k , 29 ) + rdat % r01 ( j , 3 ) e2 ( 4 , j , 2 , 1 ) =+ rdat % r03 ( k , 30 ) + rdat % r01 ( j , 4 ) enddo j = 1 k = ind ( j , 2 , 1 ) m = in6 ( k ) do i = 1 , 5 e1 ( i , 2 , 1 ) =+ rdat % r02 ( m , i + 36 ) + rdat % r00 ( i , 1 ) enddo j = 0 do jj = 1 , 5 do ii = 1 , jj j = j + 1 k = ind ( j , 3 , 1 ) l = k - 2 - jj e5 ( j , 3 , 1 ) =+ rdat % r06 ( k , 2 ) - rdat % r05 ( l , 2 ) * 2 + rdat % r04 ( j , 1 ) + rdat % r04 ( j , 2 ) if ( jj > 4 ) cycle e4 ( 1 , j , 3 , 1 ) =+ rdat % r05 ( k , 5 ) - rdat % r04 ( l , 8 ) * 2 + rdat % r03 ( j , 1 ) + rdat % r03 ( j , 3 ) e4 ( 2 , j , 3 , 1 ) =+ rdat % r05 ( k , 6 ) - rdat % r04 ( l , 9 ) * 2 + rdat % r03 ( j , 2 ) + rdat % r03 ( j , 4 ) if ( jj > 3 ) cycle m = in6 ( j ) do i = 1 , 4 e3 ( i , j , 3 , 1 ) =+ rdat % r04 ( k , i + 13 ) - rdat % r03 ( l , i + 10 ) * 2 + rdat % r02 ( m , i ) + rdat % r02 ( m , i + 4 ) enddo if ( jj > 2 ) cycle m = in6 ( l ) do i = 1 , 4 e2 ( i , j , 3 , 1 ) =+ rdat % r03 ( k , i + 26 ) - rdat % r02 ( m , i + 20 ) * 2 + rdat % r01 ( j , i ) + rdat % r01 ( j , i + 4 ) enddo if ( jj > 1 ) cycle m = in6 ( k ) do i = 1 , 5 e1 ( i , 3 , 1 ) =+ rdat % r02 ( m , i + 36 ) - rdat % r01 ( l , i + 20 ) * 2 + rdat % r00 ( i , 1 ) + rdat % r00 ( i , 2 ) enddo enddo enddo do j = 1 , 15 k = ind ( j , 4 , 1 ) e5 ( j , 4 , 1 ) =+ rdat % r06 ( k , 2 ) enddo do j = 1 , 10 k = ind ( j , 4 , 1 ) e4 ( 1 , j , 4 , 1 ) =+ rdat % r05 ( k , 5 ) e4 ( 2 , j , 4 , 1 ) =+ rdat % r05 ( k , 6 ) enddo do j = 1 , 6 k = ind ( j , 4 , 1 ) e3 ( 1 , j , 4 , 1 ) =+ rdat % r04 ( k , 14 ) e3 ( 2 , j , 4 , 1 ) =+ rdat % r04 ( k , 15 ) e3 ( 3 , j , 4 , 1 ) =+ rdat % r04 ( k , 16 ) e3 ( 4 , j , 4 , 1 ) =+ rdat % r04 ( k , 17 ) enddo do j = 1 , 3 k = ind ( j , 4 , 1 ) e2 ( 1 , j , 4 , 1 ) =+ rdat % r03 ( k , 27 ) e2 ( 2 , j , 4 , 1 ) =+ rdat % r03 ( k , 28 ) e2 ( 3 , j , 4 , 1 ) =+ rdat % r03 ( k , 29 ) e2 ( 4 , j , 4 , 1 ) =+ rdat % r03 ( k , 30 ) enddo j = 1 k = ind ( j , 4 , 1 ) m = in6 ( k ) do i = 1 , 5 e1 ( i , 4 , 1 ) =+ rdat % r02 ( m , i + 36 ) enddo do j = 1 , 15 k = ind ( j , 5 , 1 ) e5 ( j , 5 , 1 ) =+ rdat % r06 ( k , 2 ) - rdat % r05 ( j , 2 ) enddo do j = 1 , 10 k = ind ( j , 5 , 1 ) e4 ( 1 , j , 5 , 1 ) =+ rdat % r05 ( k , 5 ) - rdat % r04 ( j , 8 ) e4 ( 2 , j , 5 , 1 ) =+ rdat % r05 ( k , 6 ) - rdat % r04 ( j , 9 ) enddo do j = 1 , 6 k = ind ( j , 5 , 1 ) e3 ( 1 , j , 5 , 1 ) =+ rdat % r04 ( k , 14 ) - rdat % r03 ( j , 11 ) e3 ( 2 , j , 5 , 1 ) =+ rdat % r04 ( k , 15 ) - rdat % r03 ( j , 12 ) e3 ( 3 , j , 5 , 1 ) =+ rdat % r04 ( k , 16 ) - rdat % r03 ( j , 13 ) e3 ( 4 , j , 5 , 1 ) =+ rdat % r04 ( k , 17 ) - rdat % r03 ( j , 14 ) enddo do j = 1 , 3 k = ind ( j , 5 , 1 ) m = in6 ( j ) e2 ( 1 , j , 5 , 1 ) =+ rdat % r03 ( k , 27 ) - rdat % r02 ( m , 21 ) e2 ( 2 , j , 5 , 1 ) =+ rdat % r03 ( k , 28 ) - rdat % r02 ( m , 22 ) e2 ( 3 , j , 5 , 1 ) =+ rdat % r03 ( k , 29 ) - rdat % r02 ( m , 23 ) e2 ( 4 , j , 5 , 1 ) =+ rdat % r03 ( k , 30 ) - rdat % r02 ( m , 24 ) enddo j = 1 k = ind ( j , 5 , 1 ) m = in6 ( k ) do i = 1 , 5 e1 ( i , 5 , 1 ) =+ rdat % r02 ( m , i + 36 ) - rdat % r01 ( j , i + 20 ) enddo j = 0 do jj = 1 , 5 do ii = 1 , jj j = j + 1 k = ind ( j , 6 , 1 ) l = k - 2 - jj e5 ( j , 6 , 1 ) =+ rdat % r06 ( k , 2 ) - rdat % r05 ( l , 2 ) if ( jj > 4 ) cycle e4 ( 1 , j , 6 , 1 ) =+ rdat % r05 ( k , 5 ) - rdat % r04 ( l , 8 ) e4 ( 2 , j , 6 , 1 ) =+ rdat % r05 ( k , 6 ) - rdat % r04 ( l , 9 ) if ( jj > 3 ) cycle do i = 1 , 4 e3 ( i , j , 6 , 1 ) =+ rdat % r04 ( k , i + 13 ) - rdat % r03 ( l , i + 10 ) enddo if ( jj > 2 ) cycle m = in6 ( l ) do i = 1 , 4 e2 ( i , j , 6 , 1 ) =+ rdat % r03 ( k , i + 26 ) - rdat % r02 ( m , i + 20 ) enddo if ( jj > 1 ) cycle m = in6 ( k ) do i = 1 , 5 e1 ( i , 6 , 1 ) =+ rdat % r02 ( m , i + 36 ) - rdat % r01 ( l , i + 20 ) enddo enddo enddo do j = 1 , 15 e5 ( j , 1 , 2 ) =- rdat % r07 ( j , 1 ) - rdat % r05 ( j , 4 ) * 3 enddo do j = 1 , 10 e4 ( 1 , j , 1 , 2 ) =- rdat % r06 ( j , 4 ) - rdat % r04 ( j , 12 ) * 3 e4 ( 2 , j , 1 , 2 ) =- rdat % r06 ( j , 5 ) - rdat % r04 ( j , 13 ) * 3 enddo do j = 1 , 6 e3 ( 1 , j , 1 , 2 ) =- rdat % r05 ( j , 11 ) - rdat % r03 ( j , 19 ) * 3 e3 ( 2 , j , 1 , 2 ) =- rdat % r05 ( j , 12 ) - rdat % r03 ( j , 20 ) * 3 e3 ( 3 , j , 1 , 2 ) =- rdat % r05 ( j , 13 ) - rdat % r03 ( j , 21 ) * 3 e3 ( 4 , j , 1 , 2 ) =- rdat % r05 ( j , 14 ) - rdat % r03 ( j , 22 ) * 3 enddo do j = 1 , 3 m = in6 ( j ) e2 ( 1 , j , 1 , 2 ) =- rdat % r04 ( j , 26 ) - rdat % r02 ( m , 29 ) * 3 e2 ( 2 , j , 1 , 2 ) =- rdat % r04 ( j , 27 ) - rdat % r02 ( m , 30 ) * 3 e2 ( 3 , j , 1 , 2 ) =- rdat % r04 ( j , 28 ) - rdat % r02 ( m , 31 ) * 3 e2 ( 4 , j , 1 , 2 ) =- rdat % r04 ( j , 29 ) - rdat % r02 ( m , 32 ) * 3 enddo j = 1 do i = 1 , 5 e1 ( i , 1 , 2 ) =- rdat % r03 ( j , i + 38 ) - rdat % r01 ( j , i + 30 ) * 3 enddo do j = 1 , 15 k = ind ( j , 2 , 2 ) e5 ( j , 2 , 2 ) =- rdat % r07 ( k , 1 ) - rdat % r05 ( j , 4 ) enddo do j = 1 , 10 k = ind ( j , 2 , 2 ) e4 ( 1 , j , 2 , 2 ) =- rdat % r06 ( k , 4 ) - rdat % r04 ( j , 12 ) e4 ( 2 , j , 2 , 2 ) =- rdat % r06 ( k , 5 ) - rdat % r04 ( j , 13 ) enddo do j = 1 , 6 k = ind ( j , 2 , 2 ) e3 ( 1 , j , 2 , 2 ) =- rdat % r05 ( k , 11 ) - rdat % r03 ( j , 19 ) e3 ( 2 , j , 2 , 2 ) =- rdat % r05 ( k , 12 ) - rdat % r03 ( j , 20 ) e3 ( 3 , j , 2 , 2 ) =- rdat % r05 ( k , 13 ) - rdat % r03 ( j , 21 ) e3 ( 4 , j , 2 , 2 ) =- rdat % r05 ( k , 14 ) - rdat % r03 ( j , 22 ) enddo do j = 1 , 3 k = ind ( j , 2 , 2 ) m = in6 ( j ) e2 ( 1 , j , 2 , 2 ) =- rdat % r04 ( k , 26 ) - rdat % r02 ( m , 29 ) e2 ( 2 , j , 2 , 2 ) =- rdat % r04 ( k , 27 ) - rdat % r02 ( m , 30 ) e2 ( 3 , j , 2 , 2 ) =- rdat % r04 ( k , 28 ) - rdat % r02 ( m , 31 ) e2 ( 4 , j , 2 , 2 ) =- rdat % r04 ( k , 29 ) - rdat % r02 ( m , 32 ) enddo j = 1 k = ind ( j , 2 , 2 ) do i = 1 , 5 e1 ( i , 2 , 2 ) =- rdat % r03 ( k , i + 38 ) - rdat % r01 ( j , i + 30 ) enddo j = 0 do jj = 1 , 5 do ii = 1 , jj j = j + 1 k = ind ( j , 3 , 2 ) l = k - 2 - jj e5 ( j , 3 , 2 ) =- rdat % r07 ( k , 1 ) + rdat % r06 ( l , 3 ) * 2 - rdat % r05 ( j , 3 ) - rdat % r05 ( j , 4 ) if ( jj > 4 ) cycle e4 ( 1 , j , 3 , 2 ) =- rdat % r06 ( k , 4 ) + rdat % r05 ( l , 7 ) * 2 - rdat % r04 ( j , 10 ) - rdat % r04 ( j , 12 ) e4 ( 2 , j , 3 , 2 ) =- rdat % r06 ( k , 5 ) + rdat % r05 ( l , 8 ) * 2 - rdat % r04 ( j , 11 ) - rdat % r04 ( j , 13 ) if ( jj > 3 ) cycle do i = 1 , 4 e3 ( i , j , 3 , 2 ) =- rdat % r05 ( k , i + 10 ) + rdat % r04 ( l , i + 17 ) * 2 - rdat % r03 ( j , i + 14 ) - rdat % r03 ( j , i + 18 ) enddo if ( jj > 2 ) cycle m = in6 ( j ) do i = 1 , 4 e2 ( i , j , 3 , 2 ) =- rdat % r04 ( k , i + 25 ) + rdat % r03 ( l , i + 30 ) * 2 - rdat % r02 ( m , i + 24 ) - rdat % r02 ( m , i + 28 ) enddo if ( jj > 1 ) cycle m = in6 ( l ) do i = 1 , 5 e1 ( i , 3 , 2 ) =- rdat % r03 ( k , i + 38 ) + rdat % r02 ( m , i + 41 ) * 2 - rdat % r01 ( j , i + 25 ) - rdat % r01 ( j , i + 30 ) enddo enddo enddo do j = 1 , 15 k = ind ( j , 4 , 2 ) e5 ( j , 4 , 2 ) =- rdat % r07 ( k , 1 ) - rdat % r05 ( k , 4 ) enddo do j = 1 , 10 k = ind ( j , 4 , 2 ) e4 ( 1 , j , 4 , 2 ) =- rdat % r06 ( k , 4 ) - rdat % r04 ( k , 12 ) e4 ( 2 , j , 4 , 2 ) =- rdat % r06 ( k , 5 ) - rdat % r04 ( k , 13 ) enddo do j = 1 , 6 k = ind ( j , 4 , 2 ) e3 ( 1 , j , 4 , 2 ) =- rdat % r05 ( k , 11 ) - rdat % r03 ( k , 19 ) e3 ( 2 , j , 4 , 2 ) =- rdat % r05 ( k , 12 ) - rdat % r03 ( k , 20 ) e3 ( 3 , j , 4 , 2 ) =- rdat % r05 ( k , 13 ) - rdat % r03 ( k , 21 ) e3 ( 4 , j , 4 , 2 ) =- rdat % r05 ( k , 14 ) - rdat % r03 ( k , 22 ) enddo do j = 1 , 3 k = ind ( j , 4 , 2 ) m = in6 ( k ) e2 ( 1 , j , 4 , 2 ) =- rdat % r04 ( k , 26 ) - rdat % r02 ( m , 29 ) e2 ( 2 , j , 4 , 2 ) =- rdat % r04 ( k , 27 ) - rdat % r02 ( m , 30 ) e2 ( 3 , j , 4 , 2 ) =- rdat % r04 ( k , 28 ) - rdat % r02 ( m , 31 ) e2 ( 4 , j , 4 , 2 ) =- rdat % r04 ( k , 29 ) - rdat % r02 ( m , 32 ) enddo j = 1 k = ind ( j , 4 , 2 ) do i = 1 , 5 e1 ( i , 4 , 2 ) =- rdat % r03 ( k , i + 38 ) - rdat % r01 ( k , i + 30 ) enddo do j = 1 , 15 k = ind ( j , 5 , 2 ) e5 ( j , 5 , 2 ) =- rdat % r07 ( k , 1 ) + rdat % r06 ( j , 3 ) - rdat % r05 ( k , 4 ) + rdat % r04 ( j , 5 ) enddo do j = 1 , 10 k = ind ( j , 5 , 2 ) e4 ( 1 , j , 5 , 2 ) =- rdat % r06 ( k , 4 ) + rdat % r05 ( j , 7 ) - rdat % r04 ( k , 12 ) + rdat % r03 ( j , 9 ) e4 ( 2 , j , 5 , 2 ) =- rdat % r06 ( k , 5 ) + rdat % r05 ( j , 8 ) - rdat % r04 ( k , 13 ) + rdat % r03 ( j , 10 ) enddo do j = 1 , 6 k = ind ( j , 5 , 2 ) m = in6 ( j ) e3 ( 1 , j , 5 , 2 ) =- rdat % r05 ( k , 11 ) + rdat % r04 ( j , 18 ) - rdat % r03 ( k , 19 ) + rdat % r02 ( m , 17 ) e3 ( 2 , j , 5 , 2 ) =- rdat % r05 ( k , 12 ) + rdat % r04 ( j , 19 ) - rdat % r03 ( k , 20 ) + rdat % r02 ( m , 18 ) e3 ( 3 , j , 5 , 2 ) =- rdat % r05 ( k , 13 ) + rdat % r04 ( j , 20 ) - rdat % r03 ( k , 21 ) + rdat % r02 ( m , 19 ) e3 ( 4 , j , 5 , 2 ) =- rdat % r05 ( k , 14 ) + rdat % r04 ( j , 21 ) - rdat % r03 ( k , 22 ) + rdat % r02 ( m , 20 ) enddo do j = 1 , 3 k = ind ( j , 5 , 2 ) m = in6 ( k ) e2 ( 1 , j , 5 , 2 ) =- rdat % r04 ( k , 26 ) + rdat % r03 ( j , 31 ) - rdat % r02 ( m , 29 ) + rdat % r01 ( j , 17 ) e2 ( 2 , j , 5 , 2 ) =- rdat % r04 ( k , 27 ) + rdat % r03 ( j , 32 ) - rdat % r02 ( m , 30 ) + rdat % r01 ( j , 18 ) e2 ( 3 , j , 5 , 2 ) =- rdat % r04 ( k , 28 ) + rdat % r03 ( j , 33 ) - rdat % r02 ( m , 31 ) + rdat % r01 ( j , 19 ) e2 ( 4 , j , 5 , 2 ) =- rdat % r04 ( k , 29 ) + rdat % r03 ( j , 34 ) - rdat % r02 ( m , 32 ) + rdat % r01 ( j , 20 ) enddo j = 1 k = ind ( j , 5 , 2 ) do i = 1 , 5 e1 ( i , 5 , 2 ) =- rdat % r03 ( k , i + 38 ) + rdat % r02 ( j , i + 41 ) - rdat % r01 ( k , i + 30 ) + rdat % r00 ( i , 5 ) enddo j = 0 do jj = 1 , 5 do ii = 1 , jj j = j + 1 k = ind ( j , 6 , 2 ) l = k - 2 - jj e5 ( j , 6 , 2 ) =- rdat % r07 ( k , 1 ) + rdat % r06 ( l , 3 ) if ( jj > 4 ) cycle e4 ( 1 , j , 6 , 2 ) =- rdat % r06 ( k , 4 ) + rdat % r05 ( l , 7 ) e4 ( 2 , j , 6 , 2 ) =- rdat % r06 ( k , 5 ) + rdat % r05 ( l , 8 ) if ( jj > 3 ) cycle do i = 1 , 4 e3 ( i , j , 6 , 2 ) =- rdat % r05 ( k , i + 10 ) + rdat % r04 ( l , i + 17 ) enddo if ( jj > 2 ) cycle do i = 1 , 4 e2 ( i , j , 6 , 2 ) =- rdat % r04 ( k , i + 25 ) + rdat % r03 ( l , i + 30 ) enddo if ( jj > 1 ) cycle m = in6 ( l ) do i = 1 , 5 e1 ( i , 6 , 2 ) =- rdat % r03 ( k , i + 38 ) + rdat % r02 ( m , i + 41 ) enddo enddo enddo j = 0 do jj = 1 , 5 do ii = 1 , jj j = j + 1 k = ind ( j , 2 , 3 ) l = k - 3 - jj - jj e5 ( j , 2 , 3 ) =- rdat % r07 ( k , 1 ) - rdat % r05 ( l , 4 ) * 3 if ( jj > 4 ) cycle e4 ( 1 , j , 2 , 3 ) =- rdat % r06 ( k , 4 ) - rdat % r04 ( l , 12 ) * 3 e4 ( 2 , j , 2 , 3 ) =- rdat % r06 ( k , 5 ) - rdat % r04 ( l , 13 ) * 3 if ( jj > 3 ) cycle do i = 1 , 4 e3 ( i , j , 2 , 3 ) =- rdat % r05 ( k , i + 10 ) - rdat % r03 ( l , i + 18 ) * 3 enddo if ( jj > 2 ) cycle m = in6 ( l ) do i = 1 , 4 e2 ( i , j , 2 , 3 ) =- rdat % r04 ( k , i + 25 ) - rdat % r02 ( m , i + 28 ) * 3 enddo if ( jj > 1 ) cycle do i = 1 , 5 e1 ( i , 2 , 3 ) =- rdat % r03 ( k , i + 38 ) - rdat % r01 ( l , i + 30 ) * 3 enddo enddo enddo j = 0 do jj = 1 , 5 do ii = 1 , jj j = j + 1 k = ind ( j , 3 , 3 ) l = k - 3 - jj m = l - 2 - jj e5 ( j , 3 , 3 ) =- rdat % r07 ( k , 1 ) + rdat % r06 ( l , 3 ) * 2 - rdat % r05 ( m , 3 ) - rdat % r05 ( m , 4 ) if ( jj > 4 ) cycle e4 ( 1 , j , 3 , 3 ) =- rdat % r06 ( k , 4 ) + rdat % r05 ( l , 7 ) * 2 - rdat % r04 ( m , 10 ) - rdat % r04 ( m , 12 ) e4 ( 2 , j , 3 , 3 ) =- rdat % r06 ( k , 5 ) + rdat % r05 ( l , 8 ) * 2 - rdat % r04 ( m , 11 ) - rdat % r04 ( m , 13 ) if ( jj > 3 ) cycle do i = 1 , 4 e3 ( i , j , 3 , 3 ) =- rdat % r05 ( k , i + 10 ) + rdat % r04 ( l , i + 17 ) * 2 - rdat % r03 ( m , i + 14 ) - rdat % r03 ( m , i + 18 ) enddo if ( jj > 2 ) cycle n = in6 ( m ) do i = 1 , 4 e2 ( i , j , 3 , 3 ) =- rdat % r04 ( k , i + 25 ) + rdat % r03 ( l , i + 30 ) * 2 - rdat % r02 ( n , i + 24 ) - rdat % r02 ( n , i + 28 ) enddo if ( jj > 1 ) cycle n = in6 ( l ) do i = 1 , 5 e1 ( i , 3 , 3 ) =- rdat % r03 ( k , i + 38 ) + rdat % r02 ( n , i + 41 ) * 2 - rdat % r01 ( m , i + 25 ) - rdat % r01 ( m , i + 30 ) enddo enddo enddo j = 0 do jj = 1 , 5 do ii = 1 , jj j = j + 1 k = ind ( j , 6 , 3 ) l = k - 3 - jj m = l - jj e5 ( j , 6 , 3 ) =- rdat % r07 ( k , 1 ) + rdat % r06 ( l , 3 ) - rdat % r05 ( m , 4 ) + rdat % r04 ( j , 5 ) if ( jj > 4 ) cycle e4 ( 1 , j , 6 , 3 ) =- rdat % r06 ( k , 4 ) + rdat % r05 ( l , 7 ) - rdat % r04 ( m , 12 ) + rdat % r03 ( j , 9 ) e4 ( 2 , j , 6 , 3 ) =- rdat % r06 ( k , 5 ) + rdat % r05 ( l , 8 ) - rdat % r04 ( m , 13 ) + rdat % r03 ( j , 10 ) if ( jj > 3 ) cycle n = in6 ( j ) do i = 1 , 4 e3 ( i , j , 6 , 3 ) =- rdat % r05 ( k , i + 10 ) + rdat % r04 ( l , i + 17 ) - rdat % r03 ( m , i + 18 ) + rdat % r02 ( n , i + 16 ) enddo if ( jj > 2 ) cycle n = in6 ( m ) do i = 1 , 4 e2 ( i , j , 6 , 3 ) =- rdat % r04 ( k , i + 25 ) + rdat % r03 ( l , i + 30 ) - rdat % r02 ( n , i + 28 ) + rdat % r01 ( j , i + 16 ) enddo if ( jj > 1 ) cycle n = in6 ( l ) do i = 1 , 5 e1 ( i , 6 , 3 ) =- rdat % r03 ( k , i + 38 ) + rdat % r02 ( n , i + 41 ) - rdat % r01 ( m , i + 30 ) + rdat % r00 ( i , 5 ) enddo enddo enddo do j = 1 , 15 k = ind ( j , 1 , 4 ) e5 ( j , 1 , 4 ) =- rdat % r07 ( k , 1 ) + rdat % r06 ( j , 1 ) - rdat % r05 ( k , 4 ) + rdat % r04 ( j , 4 ) enddo do j = 1 , 10 k = ind ( j , 1 , 4 ) e4 ( 1 , j , 1 , 4 ) =- rdat % r06 ( k , 4 ) + rdat % r05 ( j , 9 ) - rdat % r04 ( k , 12 ) + rdat % r03 ( j , 7 ) e4 ( 2 , j , 1 , 4 ) =- rdat % r06 ( k , 5 ) + rdat % r05 ( j , 10 ) - rdat % r04 ( k , 13 ) + rdat % r03 ( j , 8 ) enddo do j = 1 , 6 k = ind ( j , 1 , 4 ) m = in6 ( j ) e3 ( 1 , j , 1 , 4 ) =- rdat % r05 ( k , 11 ) + rdat % r04 ( j , 22 ) - rdat % r03 ( k , 19 ) + rdat % r02 ( m , 13 ) e3 ( 2 , j , 1 , 4 ) =- rdat % r05 ( k , 12 ) + rdat % r04 ( j , 23 ) - rdat % r03 ( k , 20 ) + rdat % r02 ( m , 14 ) e3 ( 3 , j , 1 , 4 ) =- rdat % r05 ( k , 13 ) + rdat % r04 ( j , 24 ) - rdat % r03 ( k , 21 ) + rdat % r02 ( m , 15 ) e3 ( 4 , j , 1 , 4 ) =- rdat % r05 ( k , 14 ) + rdat % r04 ( j , 25 ) - rdat % r03 ( k , 22 ) + rdat % r02 ( m , 16 ) enddo do j = 1 , 3 k = ind ( j , 1 , 4 ) m = in6 ( k ) e2 ( 1 , j , 1 , 4 ) =- rdat % r04 ( k , 26 ) + rdat % r03 ( j , 35 ) - rdat % r02 ( m , 29 ) + rdat % r01 ( j , 13 ) e2 ( 2 , j , 1 , 4 ) =- rdat % r04 ( k , 27 ) + rdat % r03 ( j , 36 ) - rdat % r02 ( m , 30 ) + rdat % r01 ( j , 14 ) e2 ( 3 , j , 1 , 4 ) =- rdat % r04 ( k , 28 ) + rdat % r03 ( j , 37 ) - rdat % r02 ( m , 31 ) + rdat % r01 ( j , 15 ) e2 ( 4 , j , 1 , 4 ) =- rdat % r04 ( k , 29 ) + rdat % r03 ( j , 38 ) - rdat % r02 ( m , 32 ) + rdat % r01 ( j , 16 ) enddo j = 1 k = ind ( j , 1 , 4 ) do i = 1 , 5 e1 ( i , 1 , 4 ) =- rdat % r03 ( k , i + 38 ) + rdat % r02 ( j , i + 46 ) - rdat % r01 ( k , i + 30 ) + rdat % r00 ( i , 4 ) enddo j = 0 do jj = 1 , 5 do ii = 1 , jj j = j + 1 k = ind ( j , 2 , 4 ) l = k - 3 - jj m = l - jj e5 ( j , 2 , 4 ) =- rdat % r07 ( k , 1 ) + rdat % r06 ( l , 1 ) - rdat % r05 ( m , 4 ) + rdat % r04 ( j , 4 ) if ( jj > 4 ) cycle e4 ( 1 , j , 2 , 4 ) =- rdat % r06 ( k , 4 ) + rdat % r05 ( l , 9 ) - rdat % r04 ( m , 12 ) + rdat % r03 ( j , 7 ) e4 ( 2 , j , 2 , 4 ) =- rdat % r06 ( k , 5 ) + rdat % r05 ( l , 10 ) - rdat % r04 ( m , 13 ) + rdat % r03 ( j , 8 ) if ( jj > 3 ) cycle n = in6 ( j ) do i = 1 , 4 e3 ( i , j , 2 , 4 ) =- rdat % r05 ( k , i + 10 ) + rdat % r04 ( l , i + 21 ) - rdat % r03 ( m , i + 18 ) + rdat % r02 ( n , i + 12 ) enddo if ( jj > 2 ) cycle n = in6 ( m ) do i = 1 , 4 e2 ( i , j , 2 , 4 ) =- rdat % r04 ( k , i + 25 ) + rdat % r03 ( l , i + 34 ) - rdat % r02 ( n , i + 28 ) + rdat % r01 ( j , i + 12 ) enddo if ( jj > 1 ) cycle n = in6 ( l ) do i = 1 , 5 e1 ( i , 2 , 4 ) =- rdat % r03 ( k , i + 38 ) + rdat % r02 ( n , i + 46 ) - rdat % r01 ( m , i + 30 ) + rdat % r00 ( i , 4 ) enddo enddo enddo j = 0 do jj = 1 , 5 do ii = 1 , jj j = j + 1 k = ind ( j , 3 , 4 ) l = k - 3 - jj m = l - 2 - jj e5 ( j , 3 , 4 ) =- rdat % r07 ( k , 1 ) + rdat % r06 ( l , 1 ) + rdat % r06 ( l , 3 ) * 2 & & - rdat % r05 ( m , 1 ) * 2 - rdat % r05 ( m , 3 ) - rdat % r05 ( m , 4 ) * 3 & & + rdat % r04 ( j , 3 ) + rdat % r04 ( j , 4 ) + rdat % r04 ( j , 5 ) * 2 if ( jj > 4 ) cycle do i = 1 , 2 e4 ( i , j , 3 , 4 ) =- rdat % r06 ( k , i + 3 ) + rdat % r05 ( l , i + 6 ) * 2 + rdat % r05 ( l , i + 8 ) & & - rdat % r04 ( m , i + 5 ) * 2 - rdat % r04 ( m , i + 9 ) - rdat % r04 ( m , i + 11 ) * 3 & & + rdat % r03 ( j , i + 4 ) + rdat % r03 ( j , i + 6 ) + rdat % r03 ( j , i + 8 ) * 2 enddo if ( jj > 3 ) cycle n = in6 ( j ) do i = 1 , 4 e3 ( i , j , 3 , 4 ) =- rdat % r05 ( k , i + 10 ) + rdat % r04 ( l , i + 17 ) * 2 + rdat % r04 ( l , i + 21 ) & & - rdat % r03 ( m , i + 14 ) - rdat % r03 ( m , i + 18 ) * 3 - rdat % r03 ( m , i + 22 ) * 2 & & + rdat % r02 ( n , i + 8 ) + rdat % r02 ( n , i + 12 ) + rdat % r02 ( n , i + 16 ) * 2 enddo if ( jj > 2 ) cycle n = in6 ( m ) do i = 1 , 4 e2 ( i , j , 3 , 4 ) =- rdat % r04 ( k , i + 25 ) + rdat % r03 ( l , i + 30 ) * 2 + rdat % r03 ( l , i + 34 ) & & - rdat % r02 ( n , i + 24 ) - rdat % r02 ( n , i + 28 ) * 3 - rdat % r02 ( n , i + 32 ) * 2 & & + rdat % r01 ( j , i + 8 ) + rdat % r01 ( j , i + 12 ) + rdat % r01 ( j , i + 16 ) * 2 enddo if ( jj > 1 ) cycle n = in6 ( l ) do i = 1 , 5 e1 ( i , 3 , 4 ) =- rdat % r03 ( k , i + 38 ) + rdat % r02 ( n , i + 41 ) * 2 + rdat % r02 ( n , i + 46 ) & & - rdat % r01 ( m , i + 25 ) - rdat % r01 ( m , i + 30 ) * 3 - rdat % r01 ( m , i + 35 ) * 2 & & + rdat % r00 ( i , 3 ) + rdat % r00 ( i , 4 ) + rdat % r00 ( i , 5 ) * 2 enddo enddo enddo j = 0 do jj = 1 , 5 do ii = 1 , jj j = j + 1 k = ind ( j , 4 , 4 ) l = k - 2 - jj e5 ( j , 4 , 4 ) =- rdat % r07 ( k , 1 ) + rdat % r06 ( l , 1 ) if ( jj > 4 ) cycle e4 ( 1 , j , 4 , 4 ) =- rdat % r06 ( k , 4 ) + rdat % r05 ( l , 9 ) e4 ( 2 , j , 4 , 4 ) =- rdat % r06 ( k , 5 ) + rdat % r05 ( l , 10 ) if ( jj > 3 ) cycle do i = 1 , 4 e3 ( i , j , 4 , 4 ) =- rdat % r05 ( k , i + 10 ) + rdat % r04 ( l , i + 21 ) enddo if ( jj > 2 ) cycle do i = 1 , 4 e2 ( i , j , 4 , 4 ) =- rdat % r04 ( k , i + 25 ) + rdat % r03 ( l , i + 34 ) enddo if ( jj > 1 ) cycle m = in6 ( l ) do i = 1 , 5 e1 ( i , 4 , 4 ) =- rdat % r03 ( k , i + 38 ) + rdat % r02 ( m , i + 46 ) enddo enddo enddo j = 0 do jj = 1 , 5 do ii = 1 , jj j = j + 1 k = ind ( j , 5 , 4 ) l = k - 2 - jj e5 ( j , 5 , 4 ) =- rdat % r07 ( k , 1 ) + rdat % r06 ( l , 1 ) + rdat % r06 ( l , 3 ) & & - rdat % r05 ( j , 1 ) - rdat % r05 ( j , 4 ) if ( jj > 4 ) cycle e4 ( 1 , j , 5 , 4 ) =- rdat % r06 ( k , 4 ) + rdat % r05 ( l , 7 ) + rdat % r05 ( l , 9 ) & & - rdat % r04 ( j , 6 ) - rdat % r04 ( j , 12 ) e4 ( 2 , j , 5 , 4 ) =- rdat % r06 ( k , 5 ) + rdat % r05 ( l , 8 ) + rdat % r05 ( l , 10 ) & & - rdat % r04 ( j , 7 ) - rdat % r04 ( j , 13 ) if ( jj > 3 ) cycle do i = 1 , 4 e3 ( i , j , 5 , 4 ) =- rdat % r05 ( k , i + 10 ) + rdat % r04 ( l , i + 17 ) + rdat % r04 ( l , i + 21 ) & & - rdat % r03 ( j , i + 18 ) - rdat % r03 ( j , i + 22 ) enddo if ( jj > 2 ) cycle m = in6 ( j ) do i = 1 , 4 e2 ( i , j , 5 , 4 ) =- rdat % r04 ( k , i + 25 ) + rdat % r03 ( l , i + 30 ) + rdat % r03 ( l , i + 34 ) & & - rdat % r02 ( m , i + 28 ) - rdat % r02 ( m , i + 32 ) enddo if ( jj > 1 ) cycle m = in6 ( l ) do i = 1 , 5 e1 ( i , 5 , 4 ) =- rdat % r03 ( k , i + 38 ) + rdat % r02 ( m , i + 41 ) + rdat % r02 ( m , i + 46 ) & & - rdat % r01 ( j , i + 30 ) - rdat % r01 ( j , i + 35 ) enddo enddo enddo j = 0 do jj = 1 , 5 do ii = 1 , jj j = j + 1 k = ind ( j , 6 , 4 ) l = k - 3 - jj m = l - 2 - jj e5 ( j , 6 , 4 ) =- rdat % r07 ( k , 1 ) + rdat % r06 ( l , 1 ) + rdat % r06 ( l , 3 ) & & - rdat % r05 ( m , 1 ) - rdat % r05 ( m , 4 ) if ( jj > 4 ) cycle e4 ( 1 , j , 6 , 4 ) =- rdat % r06 ( k , 4 ) + rdat % r05 ( l , 7 ) + rdat % r05 ( l , 9 ) & & - rdat % r04 ( m , 6 ) - rdat % r04 ( m , 12 ) e4 ( 2 , j , 6 , 4 ) =- rdat % r06 ( k , 5 ) + rdat % r05 ( l , 8 ) + rdat % r05 ( l , 10 ) & & - rdat % r04 ( m , 7 ) - rdat % r04 ( m , 13 ) if ( jj > 3 ) cycle do i = 1 , 4 e3 ( i , j , 6 , 4 ) =- rdat % r05 ( k , i + 10 ) + rdat % r04 ( l , i + 17 ) + rdat % r04 ( l , i + 21 ) & & - rdat % r03 ( m , i + 18 ) - rdat % r03 ( m , i + 22 ) enddo if ( jj > 2 ) cycle n = in6 ( m ) do i = 1 , 4 e2 ( i , j , 6 , 4 ) =- rdat % r04 ( k , i + 25 ) + rdat % r03 ( l , i + 30 ) + rdat % r03 ( l , i + 34 ) & & - rdat % r02 ( n , i + 28 ) - rdat % r02 ( n , i + 32 ) enddo if ( jj > 1 ) cycle n = in6 ( l ) do i = 1 , 5 e1 ( i , 6 , 4 ) =- rdat % r03 ( k , i + 38 ) + rdat % r02 ( n , i + 41 ) + rdat % r02 ( n , i + 46 ) & & - rdat % r01 ( m , i + 30 ) - rdat % r01 ( m , i + 35 ) enddo enddo enddo xx = qx * qx zz = qz * qz xz = qx * qz xxx = xx * qx xxz = xx * qz xzz = zz * qx zzz = zz * qz xxxx = xx * xx xxxz = xx * xz xxzz = xx * zz xzzz = xz * zz zzzz = zz * zz qxd = qx + qx qzd = qz + qz xzd = xz + xz xxxd = xxx + xxx xxzd = xxz + xxz xzzd = xzz + xzz zzzd = zzz + zzz xzq = xz + xz + xz + xz do l = 2 , lx do k = 1 , kx if ( k == 1 . and . l == 3 ) cycle if ( k == 4 . and . l == 3 ) cycle if ( k == 5 . and . l == 3 ) cycle f ( 1 , 1 , k , l - 1 ) = e5 ( 1 , k , l ) + e3 ( 1 , 1 , k , l ) * 6 + e1 ( 1 , k , l ) * 3 + ( + e4 ( 1 , 1 , k , l ) + e4 ( 2 , 1 , k , l ) + ( + e2 ( 1 , 1 , k , l ) + e2 ( 2 , 1 , k , l )) * 3 ) * qxd + ( + e3 ( 2 , 1 , k , l ) + e3 ( 3 , 1 , k , l ) * 4 + e3 ( 4 , 1 , k , l ) + e1 ( 2 , k , l ) + e1 ( 3 , k , l ) * 4 + e1 ( 4 , k , l )) * xx + ( + e2 ( 3 , 1 , k , l ) + e2 ( 4 , 1 , k , l )) * xxxd + e1 ( 5 , k , l ) * xxxx f ( 2 , 1 , k , l - 1 ) = e5 ( 4 , k , l ) + e3 ( 1 , 4 , k , l ) + e3 ( 1 , 1 , k , l ) + e1 ( 1 , k , l ) + ( + e4 ( 2 , 4 , k , l ) + e2 ( 2 , 1 , k , l )) * qxd + ( + e3 ( 4 , 4 , k , l ) + e1 ( 4 , k , l )) * xx f ( 3 , 1 , k , l - 1 ) = e5 ( 6 , k , l ) + e3 ( 1 , 6 , k , l ) + e3 ( 1 , 1 , k , l ) + e1 ( 1 , k , l ) + ( + e4 ( 2 , 6 , k , l ) + e2 ( 2 , 1 , k , l )) * qxd + ( + e4 ( 1 , 3 , k , l ) + e2 ( 1 , 3 , k , l )) * qzd + ( + e3 ( 4 , 6 , k , l ) + e1 ( 4 , k , l )) * xx + e3 ( 3 , 3 , k , l ) * xzq + ( + e3 ( 2 , 1 , k , l ) + e1 ( 2 , k , l )) * zz + e2 ( 4 , 3 , k , l ) * xxzd + e2 ( 3 , 1 , k , l ) * xzzd + e1 ( 5 , k , l ) * xxzz f ( 4 , 1 , k , l - 1 ) = e5 ( 2 , k , l ) + e3 ( 1 , 2 , k , l ) * 3 + ( + e4 ( 1 , 2 , k , l ) + e4 ( 2 , 2 , k , l ) * 2 + e2 ( 1 , 2 , k , l ) + e2 ( 2 , 2 , k , l ) * 2 ) * qx + ( + e3 ( 3 , 2 , k , l ) * 2 + e3 ( 4 , 2 , k , l )) * xx + e2 ( 4 , 2 , k , l ) * xxx f ( 5 , 1 , k , l - 1 ) = e5 ( 3 , k , l ) + e3 ( 1 , 3 , k , l ) * 3 + ( + e4 ( 1 , 3 , k , l ) + e4 ( 2 , 3 , k , l ) * 2 + e2 ( 1 , 3 , k , l ) + e2 ( 2 , 3 , k , l ) * 2 ) * qx + ( + e4 ( 1 , 1 , k , l ) + e2 ( 1 , 1 , k , l ) * 3 ) * qz + ( + e3 ( 3 , 3 , k , l ) * 2 + e3 ( 4 , 3 , k , l )) * xx + ( + e3 ( 2 , 1 , k , l ) + e3 ( 3 , 1 , k , l ) * 2 + e1 ( 2 , k , l ) + e1 ( 3 , k , l ) * 2 ) * xz + e2 ( 4 , 3 , k , l ) * xxx + ( + e2 ( 3 , 1 , k , l ) * 2 + e2 ( 4 , 1 , k , l )) * xxz + e1 ( 5 , k , l ) * xxxz f ( 6 , 1 , k , l - 1 ) = e5 ( 5 , k , l ) + e3 ( 1 , 5 , k , l ) + e4 ( 2 , 5 , k , l ) * qxd + ( + e4 ( 1 , 2 , k , l ) + e2 ( 1 , 2 , k , l )) * qz + e3 ( 4 , 5 , k , l ) * xx + e3 ( 3 , 2 , k , l ) * xzd + e2 ( 4 , 2 , k , l ) * xxz f ( 1 , 2 , k , l - 1 ) = e5 ( 4 , k , l ) + e3 ( 1 , 4 , k , l ) + e3 ( 1 , 1 , k , l ) + e1 ( 1 , k , l ) + ( + e4 ( 1 , 4 , k , l ) + e2 ( 1 , 1 , k , l )) * qxd + ( + e3 ( 2 , 4 , k , l ) + e1 ( 2 , k , l )) * xx f ( 2 , 2 , k , l - 1 ) = e5 ( 11 , k , l ) + e3 ( 1 , 4 , k , l ) * 6 + e1 ( 1 , k , l ) * 3 f ( 3 , 2 , k , l - 1 ) = e5 ( 13 , k , l ) + e3 ( 1 , 6 , k , l ) + e3 ( 1 , 4 , k , l ) + e1 ( 1 , k , l ) + ( + e4 ( 1 , 8 , k , l ) + e2 ( 1 , 3 , k , l )) * qzd + ( + e3 ( 2 , 4 , k , l ) + e1 ( 2 , k , l )) * zz f ( 4 , 2 , k , l - 1 ) = e5 ( 7 , k , l ) + e3 ( 1 , 2 , k , l ) * 3 + ( + e4 ( 1 , 7 , k , l ) + e2 ( 1 , 2 , k , l ) * 3 ) * qx f ( 5 , 2 , k , l - 1 ) = e5 ( 8 , k , l ) + e3 ( 1 , 3 , k , l ) + ( + e4 ( 1 , 8 , k , l ) + e2 ( 1 , 3 , k , l )) * qx + ( + e4 ( 1 , 4 , k , l ) + e2 ( 1 , 1 , k , l )) * qz + ( + e3 ( 2 , 4 , k , l ) + e1 ( 2 , k , l )) * xz f ( 6 , 2 , k , l - 1 ) = e5 ( 12 , k , l ) + e3 ( 1 , 5 , k , l ) * 3 + ( + e4 ( 1 , 7 , k , l ) + e2 ( 1 , 2 , k , l ) * 3 ) * qz f ( 1 , 3 , k , l - 1 ) = e5 ( 6 , k , l ) + e3 ( 1 , 6 , k , l ) + e3 ( 1 , 1 , k , l ) + e1 ( 1 , k , l ) + ( + e4 ( 1 , 6 , k , l ) + e2 ( 1 , 1 , k , l )) * qxd + ( + e4 ( 2 , 3 , k , l ) + e2 ( 2 , 3 , k , l )) * qzd + ( + e3 ( 2 , 6 , k , l ) + e1 ( 2 , k , l )) * xx + e3 ( 3 , 3 , k , l ) * xzq + ( + e3 ( 4 , 1 , k , l ) + e1 ( 4 , k , l )) * zz + e2 ( 3 , 3 , k , l ) * xxzd + e2 ( 4 , 1 , k , l ) * xzzd + e1 ( 5 , k , l ) * xxzz f ( 2 , 3 , k , l - 1 ) = e5 ( 13 , k , l ) + e3 ( 1 , 6 , k , l ) + e3 ( 1 , 4 , k , l ) + e1 ( 1 , k , l ) + ( + e4 ( 2 , 8 , k , l ) + e2 ( 2 , 3 , k , l )) * qzd + ( + e3 ( 4 , 4 , k , l ) + e1 ( 4 , k , l )) * zz f ( 3 , 3 , k , l - 1 ) = e5 ( 15 , k , l ) + e3 ( 1 , 6 , k , l ) * 6 + e1 ( 1 , k , l ) * 3 + ( + e4 ( 1 , 10 , k , l ) + e4 ( 2 , 10 , k , l ) + ( + e2 ( 1 , 3 , k , l ) + e2 ( 2 , 3 , k , l )) * 3 ) * qzd + ( + e3 ( 2 , 6 , k , l ) + e3 ( 3 , 6 , k , l ) * 4 + e3 ( 4 , 6 , k , l ) + e1 ( 2 , k , l ) + e1 ( 3 , k , l ) * 4 + e1 ( 4 , k , l )) * zz + ( + e2 ( 3 , 3 , k , l ) + e2 ( 4 , 3 , k , l )) * zzzd + e1 ( 5 , k , l ) * zzzz f ( 4 , 3 , k , l - 1 ) = e5 ( 9 , k , l ) + e3 ( 1 , 2 , k , l ) + ( + e4 ( 1 , 9 , k , l ) + e2 ( 1 , 2 , k , l )) * qx + e4 ( 2 , 5 , k , l ) * qzd + e3 ( 3 , 5 , k , l ) * xzd + e3 ( 4 , 2 , k , l ) * zz + e2 ( 4 , 2 , k , l ) * xzz f ( 5 , 3 , k , l - 1 ) = e5 ( 10 , k , l ) + e3 ( 1 , 3 , k , l ) * 3 + ( + e4 ( 1 , 10 , k , l ) + e2 ( 1 , 3 , k , l ) * 3 ) * qx + ( + e4 ( 1 , 6 , k , l ) + e4 ( 2 , 6 , k , l ) * 2 + e2 ( 1 , 1 , k , l ) + e2 ( 2 , 1 , k , l ) * 2 ) * qz + ( + e3 ( 2 , 6 , k , l ) + e3 ( 3 , 6 , k , l ) * 2 + e1 ( 2 , k , l ) + e1 ( 3 , k , l ) * 2 ) * xz + ( + e3 ( 3 , 3 , k , l ) * 2 + e3 ( 4 , 3 , k , l )) * zz + ( + e2 ( 3 , 3 , k , l ) * 2 + e2 ( 4 , 3 , k , l )) * xzz + e2 ( 4 , 1 , k , l ) * zzz + e1 ( 5 , k , l ) * xzzz f ( 6 , 3 , k , l - 1 ) = e5 ( 14 , k , l ) + e3 ( 1 , 5 , k , l ) * 3 + ( + e4 ( 1 , 9 , k , l ) + e4 ( 2 , 9 , k , l ) * 2 + e2 ( 1 , 2 , k , l ) + e2 ( 2 , 2 , k , l ) * 2 ) * qz + ( + e3 ( 3 , 5 , k , l ) * 2 + e3 ( 4 , 5 , k , l )) * zz + e2 ( 4 , 2 , k , l ) * zzz f ( 1 , 4 , k , l - 1 ) = e5 ( 2 , k , l ) + e3 ( 1 , 2 , k , l ) * 3 + ( + e4 ( 1 , 2 , k , l ) * 2 + e4 ( 2 , 2 , k , l ) + e2 ( 1 , 2 , k , l ) * 2 + e2 ( 2 , 2 , k , l )) * qx + ( + e3 ( 2 , 2 , k , l ) + e3 ( 3 , 2 , k , l ) * 2 ) * xx + e2 ( 3 , 2 , k , l ) * xxx f ( 2 , 4 , k , l - 1 ) = e5 ( 7 , k , l ) + e3 ( 1 , 2 , k , l ) * 3 + ( + e4 ( 2 , 7 , k , l ) + e2 ( 2 , 2 , k , l ) * 3 ) * qx f ( 3 , 4 , k , l - 1 ) = e5 ( 9 , k , l ) + e3 ( 1 , 2 , k , l ) + ( + e4 ( 2 , 9 , k , l ) + e2 ( 2 , 2 , k , l )) * qx + e4 ( 1 , 5 , k , l ) * qzd + e3 ( 3 , 5 , k , l ) * xzd + e3 ( 2 , 2 , k , l ) * zz + e2 ( 3 , 2 , k , l ) * xzz f ( 4 , 4 , k , l - 1 ) = e5 ( 4 , k , l ) + e3 ( 1 , 4 , k , l ) + e3 ( 1 , 1 , k , l ) + e1 ( 1 , k , l ) + ( + e4 ( 1 , 4 , k , l ) + e4 ( 2 , 4 , k , l ) + e2 ( 1 , 1 , k , l ) + e2 ( 2 , 1 , k , l )) * qx + ( + e3 ( 3 , 4 , k , l ) + e1 ( 3 , k , l )) * xx f ( 5 , 4 , k , l - 1 ) = e5 ( 5 , k , l ) + e3 ( 1 , 5 , k , l ) + ( + e4 ( 1 , 5 , k , l ) + e4 ( 2 , 5 , k , l )) * qx + ( + e4 ( 1 , 2 , k , l ) + e2 ( 1 , 2 , k , l )) * qz + e3 ( 3 , 5 , k , l ) * xx + ( + e3 ( 2 , 2 , k , l ) + e3 ( 3 , 2 , k , l )) * xz + e2 ( 3 , 2 , k , l ) * xxz f ( 6 , 4 , k , l - 1 ) = e5 ( 8 , k , l ) + e3 ( 1 , 3 , k , l ) + ( + e4 ( 2 , 8 , k , l ) + e2 ( 2 , 3 , k , l )) * qx + ( + e4 ( 1 , 4 , k , l ) + e2 ( 1 , 1 , k , l )) * qz + ( + e3 ( 3 , 4 , k , l ) + e1 ( 3 , k , l )) * xz f ( 1 , 5 , k , l - 1 ) = e5 ( 3 , k , l ) + e3 ( 1 , 3 , k , l ) * 3 + ( + e4 ( 1 , 3 , k , l ) * 2 + e4 ( 2 , 3 , k , l ) + e2 ( 1 , 3 , k , l ) * 2 + e2 ( 2 , 3 , k , l )) * qx + ( + e4 ( 2 , 1 , k , l ) + e2 ( 2 , 1 , k , l ) * 3 ) * qz + ( + e3 ( 2 , 3 , k , l ) + e3 ( 3 , 3 , k , l ) * 2 ) * xx + ( + e3 ( 3 , 1 , k , l ) * 2 + e3 ( 4 , 1 , k , l ) + e1 ( 3 , k , l ) * 2 + e1 ( 4 , k , l )) * xz + e2 ( 3 , 3 , k , l ) * xxx + ( + e2 ( 3 , 1 , k , l ) + e2 ( 4 , 1 , k , l ) * 2 ) * xxz + e1 ( 5 , k , l ) * xxxz f ( 2 , 5 , k , l - 1 ) = e5 ( 8 , k , l ) + e3 ( 1 , 3 , k , l ) + ( + e4 ( 2 , 8 , k , l ) + e2 ( 2 , 3 , k , l )) * qx + ( + e4 ( 2 , 4 , k , l ) + e2 ( 2 , 1 , k , l )) * qz + ( + e3 ( 4 , 4 , k , l ) + e1 ( 4 , k , l )) * xz f ( 3 , 5 , k , l - 1 ) = e5 ( 10 , k , l ) + e3 ( 1 , 3 , k , l ) * 3 + ( + e4 ( 2 , 10 , k , l ) + e2 ( 2 , 3 , k , l ) * 3 ) * qx + ( + e4 ( 1 , 6 , k , l ) * 2 + e4 ( 2 , 6 , k , l ) + e2 ( 1 , 1 , k , l ) * 2 + e2 ( 2 , 1 , k , l )) * qz + ( + e3 ( 3 , 6 , k , l ) * 2 + e3 ( 4 , 6 , k , l ) + e1 ( 3 , k , l ) * 2 + e1 ( 4 , k , l )) * xz + ( + e3 ( 2 , 3 , k , l ) + e3 ( 3 , 3 , k , l ) * 2 ) * zz + ( + e2 ( 3 , 3 , k , l ) + e2 ( 4 , 3 , k , l ) * 2 ) * xzz + e2 ( 3 , 1 , k , l ) * zzz + e1 ( 5 , k , l ) * xzzz f ( 4 , 5 , k , l - 1 ) = e5 ( 5 , k , l ) + e3 ( 1 , 5 , k , l ) + ( + e4 ( 1 , 5 , k , l ) + e4 ( 2 , 5 , k , l )) * qx + ( + e4 ( 2 , 2 , k , l ) + e2 ( 2 , 2 , k , l )) * qz + e3 ( 3 , 5 , k , l ) * xx + ( + e3 ( 3 , 2 , k , l ) + e3 ( 4 , 2 , k , l )) * xz + e2 ( 4 , 2 , k , l ) * xxz f ( 5 , 5 , k , l - 1 ) = e5 ( 6 , k , l ) + e3 ( 1 , 6 , k , l ) + e3 ( 1 , 1 , k , l ) + e1 ( 1 , k , l ) + ( + e4 ( 1 , 6 , k , l ) + e4 ( 2 , 6 , k , l ) + e2 ( 1 , 1 , k , l ) + e2 ( 2 , 1 , k , l )) * qx + ( + e4 ( 1 , 3 , k , l ) + e4 ( 2 , 3 , k , l ) + e2 ( 1 , 3 , k , l ) + e2 ( 2 , 3 , k , l )) * qz + ( + e3 ( 3 , 6 , k , l ) + e1 ( 3 , k , l )) * xx + ( + e3 ( 2 , 3 , k , l ) + e3 ( 3 , 3 , k , l ) * 2 + e3 ( 4 , 3 , k , l )) * xz + ( + e3 ( 3 , 1 , k , l ) + e1 ( 3 , k , l )) * zz + ( + e2 ( 3 , 3 , k , l ) + e2 ( 4 , 3 , k , l )) * xxz + ( + e2 ( 3 , 1 , k , l ) + e2 ( 4 , 1 , k , l )) * xzz + e1 ( 5 , k , l ) * xxzz f ( 6 , 5 , k , l - 1 ) = e5 ( 9 , k , l ) + e3 ( 1 , 2 , k , l ) + ( + e4 ( 2 , 9 , k , l ) + e2 ( 2 , 2 , k , l )) * qx + ( + e4 ( 1 , 5 , k , l ) + e4 ( 2 , 5 , k , l )) * qz + ( + e3 ( 3 , 5 , k , l ) + e3 ( 4 , 5 , k , l )) * xz + e3 ( 3 , 2 , k , l ) * zz + e2 ( 4 , 2 , k , l ) * xzz f ( 1 , 6 , k , l - 1 ) = e5 ( 5 , k , l ) + e3 ( 1 , 5 , k , l ) + e4 ( 1 , 5 , k , l ) * qxd + ( + e4 ( 2 , 2 , k , l ) + e2 ( 2 , 2 , k , l )) * qz + e3 ( 2 , 5 , k , l ) * xx + e3 ( 3 , 2 , k , l ) * xzd + e2 ( 3 , 2 , k , l ) * xxz f ( 2 , 6 , k , l - 1 ) = e5 ( 12 , k , l ) + e3 ( 1 , 5 , k , l ) * 3 + ( + e4 ( 2 , 7 , k , l ) + e2 ( 2 , 2 , k , l ) * 3 ) * qz f ( 3 , 6 , k , l - 1 ) = e5 ( 14 , k , l ) + e3 ( 1 , 5 , k , l ) * 3 + ( + e4 ( 1 , 9 , k , l ) * 2 + e4 ( 2 , 9 , k , l ) + e2 ( 1 , 2 , k , l ) * 2 + e2 ( 2 , 2 , k , l )) * qz + ( + e3 ( 2 , 5 , k , l ) + e3 ( 3 , 5 , k , l ) * 2 ) * zz + e2 ( 3 , 2 , k , l ) * zzz f ( 4 , 6 , k , l - 1 ) = e5 ( 8 , k , l ) + e3 ( 1 , 3 , k , l ) + ( + e4 ( 1 , 8 , k , l ) + e2 ( 1 , 3 , k , l )) * qx + ( + e4 ( 2 , 4 , k , l ) + e2 ( 2 , 1 , k , l )) * qz + ( + e3 ( 3 , 4 , k , l ) + e1 ( 3 , k , l )) * xz f ( 5 , 6 , k , l - 1 ) = e5 ( 9 , k , l ) + e3 ( 1 , 2 , k , l ) + ( + e4 ( 1 , 9 , k , l ) + e2 ( 1 , 2 , k , l )) * qx + ( + e4 ( 1 , 5 , k , l ) + e4 ( 2 , 5 , k , l )) * qz + ( + e3 ( 2 , 5 , k , l ) + e3 ( 3 , 5 , k , l )) * xz + e3 ( 3 , 2 , k , l ) * zz + e2 ( 3 , 2 , k , l ) * xzz f ( 6 , 6 , k , l - 1 ) = e5 ( 13 , k , l ) + e3 ( 1 , 6 , k , l ) + e3 ( 1 , 4 , k , l ) + e1 ( 1 , k , l ) + ( + e4 ( 1 , 8 , k , l ) + e4 ( 2 , 8 , k , l ) + e2 ( 1 , 3 , k , l ) + e2 ( 2 , 3 , k , l )) * qz + ( + e3 ( 3 , 4 , k , l ) + e1 ( 3 , k , l )) * zz enddo enddo f (:,:, 1 , 2 ) = f (:,:, 4 , 1 ) f (:,:, 4 , 2 ) = f (:,:, 2 , 1 ) f (:,:, 5 , 2 ) = f (:,:, 6 , 1 ) end subroutine mcdv_20 ! > ! >    @brief   dddd case ! > ! >    @details integration of a dddd case ! > subroutine mcdv_21 ( f , rdat , qx , qz ) implicit none type ( rotaxis_data_t ) :: rdat real ( kind = dp ) :: f ( 6 , 6 , 6 , * ) real ( kind = dp ) :: qx , qz integer , parameter :: kx = 6 , lx = 6 real ( kind = dp ) :: e1 ( 5 , kx , lx ), e2 ( 4 , 3 , kx , lx ), e3 ( 4 , 6 , kx , lx ), & e4 ( 2 , 10 , kx , lx ), e5 ( 15 , kx , lx ) integer , parameter :: ind ( 15 , kx , lx ) = reshape (& [ 1 , 2 , 3 , 4 , 5 , 6 , 7 , 8 , 9 , 10 , 11 , 12 , 13 , 14 , 15 , 4 , 7 , 8 , 11 , & 12 , 13 , 16 , 17 , 18 , 19 , 22 , 23 , 24 , 25 , 26 , 6 , 9 , 10 , 13 , 14 , 15 , & 18 , 19 , 20 , 21 , 24 , 25 , 26 , 27 , 28 , 2 , 4 , 5 , 7 , 8 , 9 , 11 , 12 , 13 , & 14 , 16 , 17 , 18 , 19 , 20 , 3 , 5 , 6 , 8 , 9 , 10 , 12 , 13 , 14 , 15 , 17 , 18 , & 19 , 20 , 21 , 5 , 8 , 9 , 12 , 13 , 14 , 17 , 18 , 19 , 20 , 23 , 24 , 25 , 26 , 27 , & 4 , 7 , 8 , 11 , 12 , 13 , 16 , 17 , 18 , 19 , 22 , 23 , 24 , 25 , 26 , 11 , 16 , 17 , & 22 , 23 , 24 , 29 , 30 , 31 , 32 , 37 , 38 , 39 , 40 , 41 , 13 , 18 , 19 , 24 , 25 , & 26 , 31 , 32 , 33 , 34 , 39 , 40 , 41 , 42 , 43 , 7 , 11 , 12 , 16 , 17 , 18 , 22 , & 23 , 24 , 25 , 29 , 30 , 31 , 32 , 33 , 8 , 12 , 13 , 17 , 18 , 19 , 23 , 24 , 25 , & 26 , 30 , 31 , 32 , 33 , 34 , 12 , 17 , 18 , 23 , 24 , 25 , 30 , 31 , 32 , 33 , 38 , & 39 , 40 , 41 , 42 , 6 , 9 , 10 , 13 , 14 , 15 , 18 , 19 , 20 , 21 , 24 , 25 , 26 , & 27 , 28 , 13 , 18 , 19 , 24 , 25 , 26 , 31 , 32 , 33 , 34 , 39 , 40 , 41 , 42 , 43 , & 15 , 20 , 21 , 26 , 27 , 28 , 33 , 34 , 35 , 36 , 41 , 42 , 43 , 44 , 45 , 9 , 13 , & 14 , 18 , 19 , 20 , 24 , 25 , 26 , 27 , 31 , 32 , 33 , 34 , 35 , 10 , 14 , 15 , 19 , & 20 , 21 , 25 , 26 , 27 , 28 , 32 , 33 , 34 , 35 , 36 , 14 , 19 , 20 , 25 , 26 , 27 , & 32 , 33 , 34 , 35 , 40 , 41 , 42 , 43 , 44 , 2 , 4 , 5 , 7 , 8 , 9 , 11 , 12 , 13 , & 14 , 16 , 17 , 18 , 19 , 20 , 7 , 11 , 12 , 16 , 17 , 18 , 22 , 23 , 24 , 25 , 29 , & 30 , 31 , 32 , 33 , 9 , 13 , 14 , 18 , 19 , 20 , 24 , 25 , 26 , 27 , 31 , 32 , 33 , & 34 , 35 , 4 , 7 , 8 , 11 , 12 , 13 , 16 , 17 , 18 , 19 , 22 , 23 , 24 , 25 , 26 , 5 , & 8 , 9 , 12 , 13 , 14 , 17 , 18 , 19 , 20 , 23 , 24 , 25 , 26 , 27 , 8 , 12 , 13 , 17 , & 18 , 19 , 23 , 24 , 25 , 26 , 30 , 31 , 32 , 33 , 34 , 3 , 5 , 6 , 8 , 9 , 10 , 12 , & 13 , 14 , 15 , 17 , 18 , 19 , 20 , 21 , 8 , 12 , 13 , 17 , 18 , 19 , 23 , 24 , 25 , & 26 , 30 , 31 , 32 , 33 , 34 , 10 , 14 , 15 , 19 , 20 , 21 , 25 , 26 , 27 , 28 , 32 , & 33 , 34 , 35 , 36 , 5 , 8 , 9 , 12 , 13 , 14 , 17 , 18 , 19 , 20 , 23 , 24 , 25 , 26 , & 27 , 6 , 9 , 10 , 13 , 14 , 15 , 18 , 19 , 20 , 21 , 24 , 25 , 26 , 27 , 28 , 9 , 13 , & 14 , 18 , 19 , 20 , 24 , 25 , 26 , 27 , 31 , 32 , 33 , 34 , 35 , 5 , 8 , 9 , 12 , 13 , & 14 , 17 , 18 , 19 , 20 , 23 , 24 , 25 , 26 , 27 , 12 , 17 , 18 , 23 , 24 , 25 , 30 , & 31 , 32 , 33 , 38 , 39 , 40 , 41 , 42 , 14 , 19 , 20 , 25 , 26 , 27 , 32 , 33 , 34 , & 35 , 40 , 41 , 42 , 43 , 44 , 8 , 12 , 13 , 17 , 18 , 19 , 23 , 24 , 25 , 26 , 30 , & 31 , 32 , 33 , 34 , 9 , 13 , 14 , 18 , 19 , 20 , 24 , 25 , 26 , 27 , 31 , 32 , 33 , & 34 , 35 , 13 , 18 , 19 , 24 , 25 , 26 , 31 , 32 , 33 , 34 , 39 , 40 , 41 , 42 , 43 ] & , shape ( ind )) integer , parameter :: jnd1 ( 15 ) = & [ 3 , 5 , 6 , 8 , 9 , 10 , 12 , 13 , 14 , 15 , 17 , 18 , 19 , 20 , 21 ] integer , parameter :: jnd2 ( 15 ) = & [ 4 , 7 , 8 , 11 , 12 , 13 , 16 , 17 , 18 , 19 , 22 , 23 , 24 , 25 , 26 ] integer , parameter :: jnd3 ( 15 ) = & [ 8 , 12 , 13 , 17 , 18 , 19 , 23 , 24 , 25 , 26 , 30 , 31 , 32 , 33 , 34 ] integer :: i , j , k , l , m , n , ii , jj integer :: i4 , i5 , j1 , jn , m1 real ( kind = dp ) :: xx , zz , xz , xxx , xxz , xzz , zzz real ( kind = dp ) :: xxxx , xxzz , xxxz , xzzz , zzzz real ( kind = dp ) :: xxxd , xxzd , xzzd , zzzd real ( kind = dp ) :: xzq real ( kind = dp ) :: qxd , qzd , xzd real ( kind = dp ) :: t531e1 ( 5 ), t531e2 ( 4 , 3 ), t531e3 ( 4 , 6 ), t531e4 ( 2 , 10 ), & t531e5 ( 15 ), v531e1 ( 5 ), v531e2 ( 4 , 3 ), v531e3 ( 4 , 6 ), v531e4 ( 2 , 10 ), & v531e5 ( 15 ), u5e1 ( 5 , 4 ), u5e2 ( 4 , 3 , 4 ), u5e3 ( 4 , 6 , 4 ), u5e4 ( 2 , 10 , 4 ), & u5e5 ( 15 , 4 ), t632e1 ( 5 ), t632e2 ( 4 , 3 ), t632e3 ( 4 , 6 ), t632e4 ( 2 , 10 ), & t632e5 ( 15 ), v632e1 ( 5 ), v632e2 ( 4 , 3 ), v632e3 ( 4 , 6 ), v632e4 ( 2 , 10 ), & v632e5 ( 15 ), u6e1 ( 5 , 4 ), u6e2 ( 4 , 3 , 4 ), u6e3 ( 4 , 6 , 4 ), u6e4 ( 2 , 10 , 4 ), & u6e5 ( 15 , 4 ) do j = 1 , 15 e5 ( j , 1 , 1 ) =+ rdat % r08 ( j ) + rdat % r06 ( j , 1 ) * 6 + rdat % r04 ( j , 1 ) * 3 enddo do j = 1 , 10 e4 ( 1 , j , 1 , 1 ) =+ rdat % r07 ( j , 3 ) + rdat % r05 ( j , 5 ) * 6 + rdat % r03 ( j , 1 ) * 3 e4 ( 2 , j , 1 , 1 ) =+ rdat % r07 ( j , 4 ) + rdat % r05 ( j , 6 ) * 6 + rdat % r03 ( j , 2 ) * 3 enddo do j = 1 , 6 m = in6 ( j ) e3 ( 1 , j , 1 , 1 ) =+ rdat % r06 ( j , 9 ) + rdat % r04 ( j , 14 ) * 6 + rdat % r02 ( m , 1 ) * 3 e3 ( 2 , j , 1 , 1 ) =+ rdat % r06 ( j , 10 ) + rdat % r04 ( j , 15 ) * 6 + rdat % r02 ( m , 2 ) * 3 e3 ( 3 , j , 1 , 1 ) =+ rdat % r06 ( j , 11 ) + rdat % r04 ( j , 16 ) * 6 + rdat % r02 ( m , 3 ) * 3 e3 ( 4 , j , 1 , 1 ) =+ rdat % r06 ( j , 12 ) + rdat % r04 ( j , 17 ) * 6 + rdat % r02 ( m , 4 ) * 3 enddo do j = 1 , 3 e2 ( 1 , j , 1 , 1 ) =+ rdat % r05 ( j , 21 ) + rdat % r03 ( j , 27 ) * 6 + rdat % r01 ( j , 1 ) * 3 e2 ( 2 , j , 1 , 1 ) =+ rdat % r05 ( j , 22 ) + rdat % r03 ( j , 28 ) * 6 + rdat % r01 ( j , 2 ) * 3 e2 ( 3 , j , 1 , 1 ) =+ rdat % r05 ( j , 23 ) + rdat % r03 ( j , 29 ) * 6 + rdat % r01 ( j , 3 ) * 3 e2 ( 4 , j , 1 , 1 ) =+ rdat % r05 ( j , 24 ) + rdat % r03 ( j , 30 ) * 6 + rdat % r01 ( j , 4 ) * 3 enddo j = 1 do i = 1 , 5 e1 ( i , 1 , 1 ) =+ rdat % r04 ( j , i + 37 ) + rdat % r02 ( j , i + 36 ) * 6 + rdat % r00 ( i , 1 ) * 3 enddo do j = 1 , 15 k = ind ( j , 2 , 1 ) e5 ( j , 2 , 1 ) =+ rdat % r08 ( k ) + rdat % r06 ( k , 1 ) + rdat % r06 ( j , 1 ) + rdat % r04 ( j , 1 ) enddo do j = 1 , 10 k = ind ( j , 2 , 1 ) e4 ( 1 , j , 2 , 1 ) =+ rdat % r07 ( k , 3 ) + rdat % r05 ( k , 5 ) + rdat % r05 ( j , 5 ) + rdat % r03 ( j , 1 ) e4 ( 2 , j , 2 , 1 ) =+ rdat % r07 ( k , 4 ) + rdat % r05 ( k , 6 ) + rdat % r05 ( j , 6 ) + rdat % r03 ( j , 2 ) enddo do j = 1 , 6 k = ind ( j , 2 , 1 ) m = in6 ( j ) e3 ( 1 , j , 2 , 1 ) =+ rdat % r06 ( k , 9 ) + rdat % r04 ( k , 14 ) + rdat % r04 ( j , 14 ) + rdat % r02 ( m , 1 ) e3 ( 2 , j , 2 , 1 ) =+ rdat % r06 ( k , 10 ) + rdat % r04 ( k , 15 ) + rdat % r04 ( j , 15 ) + rdat % r02 ( m , 2 ) e3 ( 3 , j , 2 , 1 ) =+ rdat % r06 ( k , 11 ) + rdat % r04 ( k , 16 ) + rdat % r04 ( j , 16 ) + rdat % r02 ( m , 3 ) e3 ( 4 , j , 2 , 1 ) =+ rdat % r06 ( k , 12 ) + rdat % r04 ( k , 17 ) + rdat % r04 ( j , 17 ) + rdat % r02 ( m , 4 ) enddo do j = 1 , 3 k = ind ( j , 2 , 1 ) e2 ( 1 , j , 2 , 1 ) =+ rdat % r05 ( k , 21 ) + rdat % r03 ( k , 27 ) + rdat % r03 ( j , 27 ) + rdat % r01 ( j , 1 ) e2 ( 2 , j , 2 , 1 ) =+ rdat % r05 ( k , 22 ) + rdat % r03 ( k , 28 ) + rdat % r03 ( j , 28 ) + rdat % r01 ( j , 2 ) e2 ( 3 , j , 2 , 1 ) =+ rdat % r05 ( k , 23 ) + rdat % r03 ( k , 29 ) + rdat % r03 ( j , 29 ) + rdat % r01 ( j , 3 ) e2 ( 4 , j , 2 , 1 ) =+ rdat % r05 ( k , 24 ) + rdat % r03 ( k , 30 ) + rdat % r03 ( j , 30 ) + rdat % r01 ( j , 4 ) enddo j = 1 k = ind ( j , 2 , 1 ) m = in6 ( k ) do i = 1 , 5 e1 ( i , 2 , 1 ) =+ rdat % r04 ( k , i + 37 ) + rdat % r02 ( m , i + 36 ) + rdat % r02 ( j , i + 36 ) + rdat % r00 ( i , 1 ) enddo j = 0 do jj = 1 , 5 do ii = 1 , jj j = j + 1 k = ind ( j , 3 , 1 ) l = k - 2 - jj t531e5 ( j ) =+ rdat % r08 ( k ) - rdat % r07 ( l , 1 ) - rdat % r07 ( l , 2 ) + rdat % r06 ( j , 1 ) & & + rdat % r06 ( k , 1 ) - rdat % r05 ( l , 1 ) - rdat % r05 ( l , 2 ) + rdat % r04 ( j , 1 ) if ( jj > 4 ) cycle t531e4 ( 1 , j ) =+ rdat % r07 ( k , 3 ) - rdat % r06 ( l , 5 ) - rdat % r06 ( l , 7 ) + rdat % r05 ( j , 5 ) & & + rdat % r05 ( k , 5 ) - rdat % r04 ( l , 6 ) - rdat % r04 ( l , 8 ) + rdat % r03 ( j , 1 ) t531e4 ( 2 , j ) =+ rdat % r07 ( k , 4 ) - rdat % r06 ( l , 6 ) - rdat % r06 ( l , 8 ) + rdat % r05 ( j , 6 ) & & + rdat % r05 ( k , 6 ) - rdat % r04 ( l , 7 ) - rdat % r04 ( l , 9 ) + rdat % r03 ( j , 2 ) if ( jj > 3 ) cycle m = in6 ( j ) do i = 1 , 4 t531e3 ( i , j ) =+ rdat % r06 ( k , i + 8 ) - rdat % r05 ( l , i + 12 ) - rdat % r05 ( l , i + 16 ) + rdat % r04 ( j , i + 13 ) & & + rdat % r04 ( k , i + 13 ) - rdat % r03 ( l , i + 10 ) - rdat % r03 ( l , i + 14 ) + rdat % r02 ( m , i ) enddo if ( jj > 2 ) cycle m = in6 ( l ) do i = 1 , 4 t531e2 ( i , j ) =+ rdat % r05 ( k , i + 20 ) - rdat % r04 ( l , i + 29 ) - rdat % r04 ( l , i + 33 ) + rdat % r03 ( j , i + 26 ) & & + rdat % r03 ( k , i + 26 ) - rdat % r02 ( m , i + 20 ) - rdat % r02 ( m , i + 24 ) + rdat % r01 ( j , i ) enddo if ( jj > 1 ) cycle do i = 1 , 5 t531e1 ( i ) =+ rdat % r04 ( k , i + 37 ) - rdat % r03 ( l , i + 42 ) - rdat % r03 ( l , i + 47 ) + rdat % r02 ( j , i + 36 ) & & + rdat % r02 ( l , i + 36 ) - rdat % r01 ( l , i + 20 ) - rdat % r01 ( l , i + 25 ) + rdat % r00 ( i , 1 ) enddo enddo enddo do j1 = 2 , 4 do j = 1 , 15 u5e5 ( j , j1 ) = rdat % r06 ( j , j1 ) + rdat % r04 ( j , j1 ) enddo m1 = j1 + j1 + 2 do j = 1 , 10 u5e4 ( 1 , j , j1 ) = rdat % r05 ( j , 1 + m1 ) + rdat % r03 ( j , 1 + m1 - 4 ) u5e4 ( 2 , j , j1 ) = rdat % r05 ( j , 2 + m1 ) + rdat % r03 ( j , 2 + m1 - 4 ) enddo m1 = m1 + m1 + 5 do j = 1 , 6 m = in6 ( j ) do i = 1 , 4 u5e3 ( i , j , j1 ) =+ rdat % r04 ( j , i + m1 ) + rdat % r02 ( m , i + m1 - 13 ) enddo enddo m1 = m1 + 13 do j = 1 , 3 do i = 1 , 4 u5e2 ( i , j , j1 ) = rdat % r03 ( j , i + m1 ) + rdat % r01 ( j , i + m1 - 26 ) enddo enddo m1 = m1 + j1 + 9 do i = 1 , 5 u5e1 ( i , j1 ) = rdat % r02 ( 1 , i + m1 ) + rdat % r00 ( i , j1 ) enddo enddo j = 0 do jj = 1 , 5 do ii = 1 , jj j = j + 1 k = jnd1 ( j ) v531e5 ( j ) =+ rdat % r07 ( k , 1 ) - rdat % r07 ( k , 2 ) + rdat % r05 ( k , 1 ) - rdat % r05 ( k , 2 ) if ( jj > 4 ) cycle v531e4 ( 1 , j ) =+ rdat % r06 ( k , 5 ) - rdat % r06 ( k , 7 ) + rdat % r04 ( k , 6 ) - rdat % r04 ( k , 8 ) v531e4 ( 2 , j ) =+ rdat % r06 ( k , 6 ) - rdat % r06 ( k , 8 ) + rdat % r04 ( k , 7 ) - rdat % r04 ( k , 9 ) if ( jj > 3 ) cycle do i = 1 , 4 v531e3 ( i , j ) =+ rdat % r05 ( k , i + 12 ) - rdat % r05 ( k , i + 16 ) + rdat % r03 ( k , i + 10 ) - rdat % r03 ( k , i + 14 ) enddo if ( jj > 2 ) cycle m = in6 ( k ) do i = 1 , 4 v531e2 ( i , j ) =+ rdat % r04 ( k , i + 29 ) - rdat % r04 ( k , i + 33 ) + rdat % r02 ( m , i + 20 ) - rdat % r02 ( m , i + 24 ) enddo if ( jj > 1 ) cycle do i = 1 , 5 v531e1 ( i ) =+ rdat % r03 ( k , i + 42 ) - rdat % r03 ( k , i + 47 ) + rdat % r01 ( k , i + 20 ) - rdat % r01 ( k , i + 25 ) enddo enddo enddo j1 = 2 do j = 1 , 15 e5 ( j , 3 , 1 ) = t531e5 ( j ) + u5e5 ( j , j1 ) - v531e5 ( j ) enddo do j = 1 , 10 e4 ( 1 , j , 3 , 1 ) = t531e4 ( 1 , j ) + u5e4 ( 1 , j , j1 ) - v531e4 ( 1 , j ) e4 ( 2 , j , 3 , 1 ) = t531e4 ( 2 , j ) + u5e4 ( 2 , j , j1 ) - v531e4 ( 2 , j ) enddo do j = 1 , 6 e3 ( 1 , j , 3 , 1 ) = t531e3 ( 1 , j ) + u5e3 ( 1 , j , j1 ) - v531e3 ( 1 , j ) e3 ( 2 , j , 3 , 1 ) = t531e3 ( 2 , j ) + u5e3 ( 2 , j , j1 ) - v531e3 ( 2 , j ) e3 ( 3 , j , 3 , 1 ) = t531e3 ( 3 , j ) + u5e3 ( 3 , j , j1 ) - v531e3 ( 3 , j ) e3 ( 4 , j , 3 , 1 ) = t531e3 ( 4 , j ) + u5e3 ( 4 , j , j1 ) - v531e3 ( 4 , j ) enddo do j = 1 , 3 e2 ( 1 , j , 3 , 1 ) = t531e2 ( 1 , j ) + u5e2 ( 1 , j , j1 ) - v531e2 ( 1 , j ) e2 ( 2 , j , 3 , 1 ) = t531e2 ( 2 , j ) + u5e2 ( 2 , j , j1 ) - v531e2 ( 2 , j ) e2 ( 3 , j , 3 , 1 ) = t531e2 ( 3 , j ) + u5e2 ( 3 , j , j1 ) - v531e2 ( 3 , j ) e2 ( 4 , j , 3 , 1 ) = t531e2 ( 4 , j ) + u5e2 ( 4 , j , j1 ) - v531e2 ( 4 , j ) enddo do i = 1 , 5 e1 ( i , 3 , 1 ) = t531e1 ( i ) + u5e1 ( i , j1 ) - v531e1 ( i ) enddo do j = 1 , 15 k = ind ( j , 4 , 1 ) e5 ( j , 4 , 1 ) =+ rdat % r08 ( k ) + rdat % r06 ( k , 1 ) * 3 enddo do j = 1 , 10 k = ind ( j , 4 , 1 ) e4 ( 1 , j , 4 , 1 ) =+ rdat % r07 ( k , 3 ) + rdat % r05 ( k , 5 ) * 3 e4 ( 2 , j , 4 , 1 ) =+ rdat % r07 ( k , 4 ) + rdat % r05 ( k , 6 ) * 3 enddo do j = 1 , 6 k = ind ( j , 4 , 1 ) e3 ( 1 , j , 4 , 1 ) =+ rdat % r06 ( k , 9 ) + rdat % r04 ( k , 14 ) * 3 e3 ( 2 , j , 4 , 1 ) =+ rdat % r06 ( k , 10 ) + rdat % r04 ( k , 15 ) * 3 e3 ( 3 , j , 4 , 1 ) =+ rdat % r06 ( k , 11 ) + rdat % r04 ( k , 16 ) * 3 e3 ( 4 , j , 4 , 1 ) =+ rdat % r06 ( k , 12 ) + rdat % r04 ( k , 17 ) * 3 enddo do j = 1 , 3 k = ind ( j , 4 , 1 ) e2 ( 1 , j , 4 , 1 ) =+ rdat % r05 ( k , 21 ) + rdat % r03 ( k , 27 ) * 3 e2 ( 2 , j , 4 , 1 ) =+ rdat % r05 ( k , 22 ) + rdat % r03 ( k , 28 ) * 3 e2 ( 3 , j , 4 , 1 ) =+ rdat % r05 ( k , 23 ) + rdat % r03 ( k , 29 ) * 3 e2 ( 4 , j , 4 , 1 ) =+ rdat % r05 ( k , 24 ) + rdat % r03 ( k , 30 ) * 3 enddo j = 1 k = ind ( j , 4 , 1 ) m = in6 ( k ) do i = 1 , 5 e1 ( i , 4 , 1 ) =+ rdat % r04 ( k , i + 37 ) + rdat % r02 ( m , i + 36 ) * 3 enddo do j = 1 , 15 k = ind ( j , 5 , 1 ) e5 ( j , 5 , 1 ) =+ rdat % r08 ( k ) - rdat % r07 ( j , 1 ) + ( rdat % r06 ( k , 1 ) - rdat % r05 ( j , 1 )) * 3 enddo do j = 1 , 10 k = ind ( j , 5 , 1 ) e4 ( 1 , j , 5 , 1 ) =+ rdat % r07 ( k , 3 ) - rdat % r06 ( j , 5 ) + ( rdat % r05 ( k , 5 ) - rdat % r04 ( j , 6 )) * 3 e4 ( 2 , j , 5 , 1 ) =+ rdat % r07 ( k , 4 ) - rdat % r06 ( j , 6 ) + ( rdat % r05 ( k , 6 ) - rdat % r04 ( j , 7 )) * 3 enddo do j = 1 , 6 k = ind ( j , 5 , 1 ) e3 ( 1 , j , 5 , 1 ) =+ rdat % r06 ( k , 9 ) - rdat % r05 ( j , 13 ) + ( rdat % r04 ( k , 14 ) - rdat % r03 ( j , 11 )) * 3 e3 ( 2 , j , 5 , 1 ) =+ rdat % r06 ( k , 10 ) - rdat % r05 ( j , 14 ) + ( rdat % r04 ( k , 15 ) - rdat % r03 ( j , 12 )) * 3 e3 ( 3 , j , 5 , 1 ) =+ rdat % r06 ( k , 11 ) - rdat % r05 ( j , 15 ) + ( rdat % r04 ( k , 16 ) - rdat % r03 ( j , 13 )) * 3 e3 ( 4 , j , 5 , 1 ) =+ rdat % r06 ( k , 12 ) - rdat % r05 ( j , 16 ) + ( rdat % r04 ( k , 17 ) - rdat % r03 ( j , 14 )) * 3 enddo do j = 1 , 3 k = ind ( j , 5 , 1 ) m = in6 ( j ) e2 ( 1 , j , 5 , 1 ) =+ rdat % r05 ( k , 21 ) - rdat % r04 ( j , 30 ) + ( rdat % r03 ( k , 27 ) - rdat % r02 ( m , 21 )) * 3 e2 ( 2 , j , 5 , 1 ) =+ rdat % r05 ( k , 22 ) - rdat % r04 ( j , 31 ) + ( rdat % r03 ( k , 28 ) - rdat % r02 ( m , 22 )) * 3 e2 ( 3 , j , 5 , 1 ) =+ rdat % r05 ( k , 23 ) - rdat % r04 ( j , 32 ) + ( rdat % r03 ( k , 29 ) - rdat % r02 ( m , 23 )) * 3 e2 ( 4 , j , 5 , 1 ) =+ rdat % r05 ( k , 24 ) - rdat % r04 ( j , 33 ) + ( rdat % r03 ( k , 30 ) - rdat % r02 ( m , 24 )) * 3 enddo j = 1 k = ind ( j , 5 , 1 ) m = in6 ( k ) do i = 1 , 5 e1 ( i , 5 , 1 ) =+ rdat % r04 ( k , i + 37 ) - rdat % r03 ( j , i + 42 ) + ( rdat % r02 ( m , i + 36 ) - rdat % r01 ( j , i + 20 )) * 3 enddo j = 0 do jj = 1 , 5 do ii = 1 , jj j = j + 1 k = ind ( j , 6 , 1 ) l = k - 2 - jj e5 ( j , 6 , 1 ) =+ rdat % r08 ( k ) - rdat % r07 ( l , 1 ) + rdat % r06 ( k , 1 ) - rdat % r05 ( l , 1 ) if ( jj > 4 ) cycle e4 ( 1 , j , 6 , 1 ) =+ rdat % r07 ( k , 3 ) - rdat % r06 ( l , 5 ) + rdat % r05 ( k , 5 ) - rdat % r04 ( l , 6 ) e4 ( 2 , j , 6 , 1 ) =+ rdat % r07 ( k , 4 ) - rdat % r06 ( l , 6 ) + rdat % r05 ( k , 6 ) - rdat % r04 ( l , 7 ) if ( jj > 3 ) cycle do i = 1 , 4 e3 ( i , j , 6 , 1 ) =+ rdat % r06 ( k , i + 8 ) - rdat % r05 ( l , i + 12 ) + rdat % r04 ( k , i + 13 ) - rdat % r03 ( l , i + 10 ) enddo if ( jj > 2 ) cycle m = in6 ( l ) do i = 1 , 4 e2 ( i , j , 6 , 1 ) =+ rdat % r05 ( k , i + 20 ) - rdat % r04 ( l , i + 29 ) + rdat % r03 ( k , i + 26 ) - rdat % r02 ( m , i + 20 ) enddo if ( jj > 1 ) cycle m = in6 ( k ) do i = 1 , 5 e1 ( i , 6 , 1 ) =+ rdat % r04 ( k , i + 37 ) - rdat % r03 ( l , i + 42 ) + rdat % r02 ( m , i + 36 ) - rdat % r01 ( l , i + 20 ) enddo enddo enddo j = 0 do jj = 1 , 5 do ii = 1 , jj j = j + 1 k = ind ( j , 2 , 2 ) l = k - 5 - jj - jj e5 ( j , 2 , 2 ) =+ rdat % r08 ( k ) + rdat % r06 ( l , 1 ) * 6 + rdat % r04 ( j , 1 ) * 3 if ( jj > 4 ) cycle e4 ( 1 , j , 2 , 2 ) =+ rdat % r07 ( k , 3 ) + rdat % r05 ( l , 5 ) * 6 + rdat % r03 ( j , 1 ) * 3 e4 ( 2 , j , 2 , 2 ) =+ rdat % r07 ( k , 4 ) + rdat % r05 ( l , 6 ) * 6 + rdat % r03 ( j , 2 ) * 3 if ( jj > 3 ) cycle m = in6 ( j ) do i = 1 , 4 e3 ( i , j , 2 , 2 ) =+ rdat % r06 ( k , i + 8 ) + rdat % r04 ( l , i + 13 ) * 6 + rdat % r02 ( m , i ) * 3 enddo if ( jj > 2 ) cycle do i = 1 , 4 e2 ( i , j , 2 , 2 ) =+ rdat % r05 ( k , i + 20 ) + rdat % r03 ( l , i + 26 ) * 6 + rdat % r01 ( j , i ) * 3 enddo if ( jj > 1 ) cycle m = in6 ( l ) do i = 1 , 5 e1 ( i , 2 , 2 ) =+ rdat % r04 ( k , i + 37 ) + rdat % r02 ( m , i + 36 ) * 6 + rdat % r00 ( i , 1 ) * 3 enddo enddo enddo j = 0 do jj = 1 , 5 do ii = 1 , jj j = j + 1 k = ind ( j , 3 , 2 ) l = k - 4 - jj m = l - 3 - jj n = m - jj t632e5 ( j ) =+ rdat % r08 ( k ) - rdat % r07 ( l , 1 ) - rdat % r07 ( l , 2 ) + rdat % r06 ( m , 1 ) & & + rdat % r06 ( m + 2 , 1 ) - rdat % r05 ( n , 1 ) - rdat % r05 ( n , 2 ) + rdat % r04 ( j , 1 ) if ( jj > 4 ) cycle t632e4 ( 1 , j ) =+ rdat % r07 ( k , 3 ) - rdat % r06 ( l , 5 ) - rdat % r06 ( l , 7 ) + rdat % r05 ( m , 5 ) & & + rdat % r05 ( m + 2 , 5 ) - rdat % r04 ( n , 6 ) - rdat % r04 ( n , 8 ) + rdat % r03 ( j , 1 ) t632e4 ( 2 , j ) =+ rdat % r07 ( k , 4 ) - rdat % r06 ( l , 6 ) - rdat % r06 ( l , 8 ) + rdat % r05 ( m , 6 ) & & + rdat % r05 ( m + 2 , 6 ) - rdat % r04 ( n , 7 ) - rdat % r04 ( n , 9 ) + rdat % r03 ( j , 2 ) if ( jj > 3 ) cycle jn = in6 ( j ) do i = 1 , 4 t632e3 ( i , j ) =+ rdat % r06 ( k , i + 8 ) - rdat % r05 ( l , i + 12 ) - rdat % r05 ( l , i + 16 ) + rdat % r04 ( m , i + 13 ) & & + rdat % r04 ( m + 2 , i + 13 ) - rdat % r03 ( n , i + 10 ) - rdat % r03 ( n , i + 14 ) + rdat % r02 ( jn , i ) enddo if ( jj > 2 ) cycle n = in6 ( n ) do i = 1 , 4 t632e2 ( i , j ) =+ rdat % r05 ( k , i + 20 ) - rdat % r04 ( l , i + 29 ) - rdat % r04 ( l , i + 33 ) + rdat % r03 ( m , i + 26 ) & & + rdat % r03 ( m + 2 , i + 26 ) - rdat % r02 ( n , i + 20 ) - rdat % r02 ( n , i + 24 ) + rdat % r01 ( j , i ) enddo n = m - jj if ( jj > 1 ) cycle m = in6 ( m ) do i = 1 , 5 t632e1 ( i ) =+ rdat % r04 ( k , i + 37 ) - rdat % r03 ( l , i + 42 ) - rdat % r03 ( l , i + 47 ) + rdat % r02 ( m , i + 36 ) & & + rdat % r02 ( m + 1 , i + 36 ) - rdat % r01 ( n , i + 20 ) - rdat % r01 ( n , i + 25 ) + rdat % r00 ( i , 1 ) enddo enddo enddo do j1 = 2 , 4 do j = 1 , 15 k = jnd2 ( j ) u6e5 ( j , j1 ) =+ rdat % r06 ( k , j1 ) + rdat % r04 ( j , j1 ) enddo m1 = j1 + j1 + 2 do j = 1 , 10 k = jnd2 ( j ) u6e4 ( 1 , j , j1 ) =+ rdat % r05 ( k , 1 + m1 ) + rdat % r03 ( j , 1 + m1 - 4 ) u6e4 ( 2 , j , j1 ) =+ rdat % r05 ( k , 2 + m1 ) + rdat % r03 ( j , 2 + m1 - 4 ) enddo m1 = m1 + m1 + 5 do j = 1 , 6 k = jnd2 ( j ) m = in6 ( j ) do i = 1 , 4 u6e3 ( i , j , j1 ) =+ rdat % r04 ( k , i + m1 ) + rdat % r02 ( m , i + m1 - 13 ) enddo enddo m1 = m1 + 13 do j = 1 , 3 k = jnd2 ( j ) do i = 1 , 4 u6e2 ( i , j , j1 ) =+ rdat % r03 ( k , i + m1 ) + rdat % r01 ( j , i + m1 - 26 ) enddo enddo m1 = m1 + j1 + 9 do i = 1 , 5 u6e1 ( i , j1 ) =+ rdat % r02 ( 2 , i + m1 ) + rdat % r00 ( i , j1 ) enddo enddo j = 0 do jj = 1 , 5 do ii = 1 , jj j = j + 1 k = jnd3 ( j ) l = k - 3 - jj - jj v632e5 ( j ) =+ rdat % r07 ( k , 1 ) - rdat % r07 ( k , 2 ) + rdat % r05 ( l , 1 ) - rdat % r05 ( l , 2 ) if ( jj > 4 ) cycle v632e4 ( 1 , j ) =+ rdat % r06 ( k , 5 ) - rdat % r06 ( k , 7 ) + rdat % r04 ( l , 6 ) - rdat % r04 ( l , 8 ) v632e4 ( 2 , j ) =+ rdat % r06 ( k , 6 ) - rdat % r06 ( k , 8 ) + rdat % r04 ( l , 7 ) - rdat % r04 ( l , 9 ) if ( jj > 3 ) cycle do i = 1 , 4 v632e3 ( i , j ) =+ rdat % r05 ( k , i + 12 ) - rdat % r05 ( k , i + 16 ) + rdat % r03 ( l , i + 10 ) - rdat % r03 ( l , i + 14 ) enddo if ( jj > 2 ) cycle m = in6 ( l ) do i = 1 , 4 v632e2 ( i , j ) =+ rdat % r04 ( k , i + 29 ) - rdat % r04 ( k , i + 33 ) + rdat % r02 ( m , i + 20 ) - rdat % r02 ( m , i + 24 ) enddo if ( jj > 1 ) cycle do i = 1 , 5 v632e1 ( i ) =+ rdat % r03 ( k , i + 42 ) - rdat % r03 ( k , i + 47 ) + rdat % r01 ( l , i + 20 ) - rdat % r01 ( l , i + 25 ) enddo enddo enddo j1 = 2 do j = 1 , 15 e5 ( j , 3 , 2 ) = t632e5 ( j ) + u6e5 ( j , j1 ) - v632e5 ( j ) enddo do j = 1 , 10 e4 ( 1 , j , 3 , 2 ) = t632e4 ( 1 , j ) + u6e4 ( 1 , j , j1 ) - v632e4 ( 1 , j ) e4 ( 2 , j , 3 , 2 ) = t632e4 ( 2 , j ) + u6e4 ( 2 , j , j1 ) - v632e4 ( 2 , j ) enddo do j = 1 , 6 e3 ( 1 , j , 3 , 2 ) = t632e3 ( 1 , j ) + u6e3 ( 1 , j , j1 ) - v632e3 ( 1 , j ) e3 ( 2 , j , 3 , 2 ) = t632e3 ( 2 , j ) + u6e3 ( 2 , j , j1 ) - v632e3 ( 2 , j ) e3 ( 3 , j , 3 , 2 ) = t632e3 ( 3 , j ) + u6e3 ( 3 , j , j1 ) - v632e3 ( 3 , j ) e3 ( 4 , j , 3 , 2 ) = t632e3 ( 4 , j ) + u6e3 ( 4 , j , j1 ) - v632e3 ( 4 , j ) enddo do j = 1 , 3 e2 ( 1 , j , 3 , 2 ) = t632e2 ( 1 , j ) + u6e2 ( 1 , j , j1 ) - v632e2 ( 1 , j ) e2 ( 2 , j , 3 , 2 ) = t632e2 ( 2 , j ) + u6e2 ( 2 , j , j1 ) - v632e2 ( 2 , j ) e2 ( 3 , j , 3 , 2 ) = t632e2 ( 3 , j ) + u6e2 ( 3 , j , j1 ) - v632e2 ( 3 , j ) e2 ( 4 , j , 3 , 2 ) = t632e2 ( 4 , j ) + u6e2 ( 4 , j , j1 ) - v632e2 ( 4 , j ) enddo do i = 1 , 5 e1 ( i , 3 , 2 ) = t632e1 ( i ) + u6e1 ( i , j1 ) - v632e1 ( i ) enddo j = 0 do jj = 1 , 5 do ii = 1 , jj j = j + 1 k = ind ( j , 4 , 2 ) l = k - 3 - jj - jj e5 ( j , 4 , 2 ) =+ rdat % r08 ( k ) + rdat % r06 ( l , 1 ) * 3 if ( jj > 4 ) cycle e4 ( 1 , j , 4 , 2 ) =+ rdat % r07 ( k , 3 ) + rdat % r05 ( l , 5 ) * 3 e4 ( 2 , j , 4 , 2 ) =+ rdat % r07 ( k , 4 ) + rdat % r05 ( l , 6 ) * 3 if ( jj > 3 ) cycle do i = 1 , 4 e3 ( i , j , 4 , 2 ) =+ rdat % r06 ( k , i + 8 ) + rdat % r04 ( l , i + 13 ) * 3 enddo if ( jj > 2 ) cycle do i = 1 , 4 e2 ( i , j , 4 , 2 ) =+ rdat % r05 ( k , i + 20 ) + rdat % r03 ( l , i + 26 ) * 3 enddo if ( jj > 1 ) cycle m = in6 ( l ) do i = 1 , 5 e1 ( i , 4 , 2 ) =+ rdat % r04 ( k , i + 37 ) + rdat % r02 ( m , i + 36 ) * 3 enddo enddo enddo j = 0 do jj = 1 , 5 do ii = 1 , jj j = j + 1 k = ind ( j , 5 , 2 ) l = k - 3 - jj m = l - jj e5 ( j , 5 , 2 ) =+ rdat % r08 ( k ) - rdat % r07 ( l , 1 ) + rdat % r06 ( m , 1 ) - rdat % r05 ( j , 1 ) if ( jj > 4 ) cycle e4 ( 1 , j , 5 , 2 ) =+ rdat % r07 ( k , 3 ) - rdat % r06 ( l , 5 ) + rdat % r05 ( m , 5 ) - rdat % r04 ( j , 6 ) e4 ( 2 , j , 5 , 2 ) =+ rdat % r07 ( k , 4 ) - rdat % r06 ( l , 6 ) + rdat % r05 ( m , 6 ) - rdat % r04 ( j , 7 ) if ( jj > 3 ) cycle do i = 1 , 4 e3 ( i , j , 5 , 2 ) =+ rdat % r06 ( k , i + 8 ) - rdat % r05 ( l , i + 12 ) + rdat % r04 ( m , i + 13 ) - rdat % r03 ( j , i + 10 ) enddo if ( jj > 2 ) cycle n = in6 ( j ) do i = 1 , 4 e2 ( i , j , 5 , 2 ) =+ rdat % r05 ( k , i + 20 ) - rdat % r04 ( l , i + 29 ) + rdat % r03 ( m , i + 26 ) - rdat % r02 ( n , i + 20 ) enddo if ( jj > 1 ) cycle m = in6 ( m ) do i = 1 , 5 e1 ( i , 5 , 2 ) =+ rdat % r04 ( k , i + 37 ) - rdat % r03 ( l , i + 42 ) + rdat % r02 ( m , i + 36 ) - rdat % r01 ( j , i + 20 ) enddo enddo enddo j = 0 do jj = 1 , 5 do ii = 1 , jj j = j + 1 k = ind ( j , 6 , 2 ) l = k - 4 - jj m = l - 1 - jj n = m - 2 - jj e5 ( j , 6 , 2 ) =+ rdat % r08 ( k ) - rdat % r07 ( l , 1 ) + rdat % r06 ( m , 1 ) * 3 - rdat % r05 ( n , 1 ) * 3 if ( jj > 4 ) cycle e4 ( 1 , j , 6 , 2 ) =+ rdat % r07 ( k , 3 ) - rdat % r06 ( l , 5 ) + rdat % r05 ( m , 5 ) * 3 - rdat % r04 ( n , 6 ) * 3 e4 ( 2 , j , 6 , 2 ) =+ rdat % r07 ( k , 4 ) - rdat % r06 ( l , 6 ) + rdat % r05 ( m , 6 ) * 3 - rdat % r04 ( n , 7 ) * 3 if ( jj > 3 ) cycle do i = 1 , 4 i4 = i + 10 e3 ( i , j , 6 , 2 ) =+ rdat % r06 ( k , i + 8 ) - rdat % r05 ( l , i + 12 ) + rdat % r04 ( m , i + 13 ) * 3 - rdat % r03 ( n , i4 ) * 3 enddo if ( jj > 2 ) cycle n = in6 ( n ) do i = 1 , 4 i4 = i + 20 e2 ( i , j , 6 , 2 ) =+ rdat % r05 ( k , i + 20 ) - rdat % r04 ( l , i + 29 ) + rdat % r03 ( m , i + 26 ) * 3 - rdat % r02 ( n , i4 ) * 3 enddo n = m - 2 - jj if ( jj > 1 ) cycle m = in6 ( m ) do i = 1 , 5 i4 = i + 20 e1 ( i , 6 , 2 ) =+ rdat % r04 ( k , i + 37 ) - rdat % r03 ( l , i + 42 ) + rdat % r02 ( m , i + 36 ) * 3 - rdat % r01 ( n , i4 ) * 3 enddo enddo enddo j1 = 4 do j = 1 , 15 e5 ( j , 1 , 3 ) = t531e5 ( j ) + u5e5 ( j , j1 ) + v531e5 ( j ) enddo do j = 1 , 10 e4 ( 1 , j , 1 , 3 ) = t531e4 ( 1 , j ) + u5e4 ( 1 , j , j1 ) + v531e4 ( 1 , j ) e4 ( 2 , j , 1 , 3 ) = t531e4 ( 2 , j ) + u5e4 ( 2 , j , j1 ) + v531e4 ( 2 , j ) enddo do j = 1 , 6 e3 ( 1 , j , 1 , 3 ) = t531e3 ( 1 , j ) + u5e3 ( 1 , j , j1 ) + v531e3 ( 1 , j ) e3 ( 2 , j , 1 , 3 ) = t531e3 ( 2 , j ) + u5e3 ( 2 , j , j1 ) + v531e3 ( 2 , j ) e3 ( 3 , j , 1 , 3 ) = t531e3 ( 3 , j ) + u5e3 ( 3 , j , j1 ) + v531e3 ( 3 , j ) e3 ( 4 , j , 1 , 3 ) = t531e3 ( 4 , j ) + u5e3 ( 4 , j , j1 ) + v531e3 ( 4 , j ) enddo do j = 1 , 3 e2 ( 1 , j , 1 , 3 ) = t531e2 ( 1 , j ) + u5e2 ( 1 , j , j1 ) + v531e2 ( 1 , j ) e2 ( 2 , j , 1 , 3 ) = t531e2 ( 2 , j ) + u5e2 ( 2 , j , j1 ) + v531e2 ( 2 , j ) e2 ( 3 , j , 1 , 3 ) = t531e2 ( 3 , j ) + u5e2 ( 3 , j , j1 ) + v531e2 ( 3 , j ) e2 ( 4 , j , 1 , 3 ) = t531e2 ( 4 , j ) + u5e2 ( 4 , j , j1 ) + v531e2 ( 4 , j ) enddo do i = 1 , 5 e1 ( i , 1 , 3 ) = t531e1 ( i ) + u5e1 ( i , j1 ) + v531e1 ( i ) enddo j1 = 4 do j = 1 , 15 e5 ( j , 2 , 3 ) = t632e5 ( j ) + u6e5 ( j , j1 ) + v632e5 ( j ) enddo do j = 1 , 10 e4 ( 1 , j , 2 , 3 ) = t632e4 ( 1 , j ) + u6e4 ( 1 , j , j1 ) + v632e4 ( 1 , j ) e4 ( 2 , j , 2 , 3 ) = t632e4 ( 2 , j ) + u6e4 ( 2 , j , j1 ) + v632e4 ( 2 , j ) enddo do j = 1 , 6 e3 ( 1 , j , 2 , 3 ) = t632e3 ( 1 , j ) + u6e3 ( 1 , j , j1 ) + v632e3 ( 1 , j ) e3 ( 2 , j , 2 , 3 ) = t632e3 ( 2 , j ) + u6e3 ( 2 , j , j1 ) + v632e3 ( 2 , j ) e3 ( 3 , j , 2 , 3 ) = t632e3 ( 3 , j ) + u6e3 ( 3 , j , j1 ) + v632e3 ( 3 , j ) e3 ( 4 , j , 2 , 3 ) = t632e3 ( 4 , j ) + u6e3 ( 4 , j , j1 ) + v632e3 ( 4 , j ) enddo do j = 1 , 3 e2 ( 1 , j , 2 , 3 ) = t632e2 ( 1 , j ) + u6e2 ( 1 , j , j1 ) + v632e2 ( 1 , j ) e2 ( 2 , j , 2 , 3 ) = t632e2 ( 2 , j ) + u6e2 ( 2 , j , j1 ) + v632e2 ( 2 , j ) e2 ( 3 , j , 2 , 3 ) = t632e2 ( 3 , j ) + u6e2 ( 3 , j , j1 ) + v632e2 ( 3 , j ) e2 ( 4 , j , 2 , 3 ) = t632e2 ( 4 , j ) + u6e2 ( 4 , j , j1 ) + v632e2 ( 4 , j ) enddo do i = 1 , 5 e1 ( i , 2 , 3 ) = t632e1 ( i ) + u6e1 ( i , j1 ) + v632e1 ( i ) enddo j = 0 do jj = 1 , 5 do ii = 1 , jj j = j + 1 k = ind ( j , 3 , 3 ) l = k - 4 - jj m = l - 3 - jj n = m - 2 - jj e5 ( j , 3 , 3 ) = + rdat % r08 ( k ) - rdat % r07 ( l , 1 ) * 2 - rdat % r07 ( l , 2 ) * 2 & & + rdat % r06 ( m , 1 ) * 6 + rdat % r06 ( m , 2 ) + rdat % r06 ( m , 3 ) * 4 + rdat % r06 ( m , 4 ) + & & ( - rdat % r05 ( n , 1 ) * 3 - rdat % r05 ( n , 2 ) * 3 - rdat % r05 ( n , 3 ) - rdat % r05 ( n , 4 )) * 2 & & + rdat % r04 ( j , 1 ) * 3 + rdat % r04 ( j , 2 ) + rdat % r04 ( j , 3 ) * 4 + rdat % r04 ( j , 4 ) + rdat % r04 ( j , 5 ) if ( jj > 4 ) cycle do i = 1 , 2 i4 = i + 4 i5 = i + 5 e4 ( i , j , 3 , 3 ) = + rdat % r07 ( k , i + 2 ) - rdat % r06 ( l , i + 4 ) * 2 - rdat % r06 ( l , i + 6 ) * 2 & & + rdat % r05 ( m , i4 ) * 6 + rdat % r05 ( m , i4 + 2 ) + rdat % r05 ( m , i4 + 4 ) * 4 + rdat % r05 ( m , i4 + 6 ) + & & ( - rdat % r04 ( n , i5 ) * 3 - rdat % r04 ( n , i5 + 2 ) * 3 - rdat % r04 ( n , i5 + 4 ) - rdat % r04 ( n , i5 + 6 )) * 2 & & + rdat % r03 ( j , i ) * 3 + rdat % r03 ( j , i + 2 ) & & + rdat % r03 ( j , i + 4 ) * 4 + rdat % r03 ( j , i + 6 ) + rdat % r03 ( j , i + 8 ) enddo if ( jj > 3 ) cycle jn = in6 ( j ) do i = 1 , 4 i4 = i + 13 i5 = i + 10 e3 ( i , j , 3 , 3 ) = + rdat % r06 ( k , i + 8 ) - rdat % r05 ( l , i + 12 ) * 2 - rdat % r05 ( l , i + 16 ) * 2 & & + rdat % r04 ( m , i4 ) * 6 + rdat % r04 ( m , i4 + 4 ) + rdat % r04 ( m , i4 + 8 ) * 4 + rdat % r04 ( m , i4 + 12 ) + & & ( - rdat % r03 ( n , i5 ) * 3 - rdat % r03 ( n , i5 + 4 ) * 3 - rdat % r03 ( n , i5 + 8 ) - rdat % r03 ( n , i5 + 12 )) * 2 & & + rdat % r02 ( jn , i ) * 3 + rdat % r02 ( jn , i + 4 ) & & + rdat % r02 ( jn , i + 8 ) * 4 + rdat % r02 ( jn , i + 12 ) + rdat % r02 ( jn , i + 16 ) enddo if ( jj > 2 ) cycle n = in6 ( n ) do i = 1 , 4 i4 = i + 26 i5 = i + 20 e2 ( i , j , 3 , 3 ) = + rdat % r05 ( k , i + 20 ) - rdat % r04 ( l , i + 29 ) * 2 - rdat % r04 ( l , i + 33 ) * 2 & & + rdat % r03 ( m , i4 ) * 6 + rdat % r03 ( m , i4 + 4 ) + rdat % r03 ( m , i4 + 8 ) * 4 + rdat % r03 ( m , i4 + 12 ) + & & ( - rdat % r02 ( n , i5 ) * 3 - rdat % r02 ( n , i5 + 4 ) * 3 - rdat % r02 ( n , i5 + 8 ) - rdat % r02 ( n , i5 + 12 )) * 2 & & + rdat % r01 ( j , i ) * 3 + rdat % r01 ( j , i + 4 ) & & + rdat % r01 ( j , i + 8 ) * 4 + rdat % r01 ( j , i + 12 ) + rdat % r01 ( j , i + 16 ) enddo n = m - 2 - jj if ( jj > 1 ) cycle m = in6 ( m ) do i = 1 , 5 i4 = i + 36 i5 = i + 20 e1 ( i , 3 , 3 ) = + rdat % r04 ( k , i + 37 ) - rdat % r03 ( l , i + 42 ) * 2 - rdat % r03 ( l , i + 47 ) * 2 & & + rdat % r02 ( m , i4 ) * 6 + rdat % r02 ( m , i4 + 5 ) + rdat % r02 ( m , i4 + 10 ) * 4 + rdat % r02 ( m , i4 + 15 ) + & & ( - rdat % r01 ( n , i5 ) * 3 - rdat % r01 ( n , i5 + 5 ) * 3 - rdat % r01 ( n , i5 + 10 ) - rdat % r01 ( n , i5 + 15 )) * 2 & & + rdat % r00 ( i , 1 ) * 3 + rdat % r00 ( i , 2 ) + rdat % r00 ( i , 3 ) * 4 + rdat % r00 ( i , 4 ) + rdat % r00 ( i , 5 ) enddo enddo enddo j = 0 do jj = 1 , 5 do ii = 1 , jj j = j + 1 k = ind ( j , 4 , 3 ) l = k - 3 - jj m = l - 2 - jj e5 ( j , 4 , 3 ) =+ rdat % r08 ( k ) - rdat % r07 ( l , 2 ) * 2 + rdat % r06 ( m , 1 ) + rdat % r06 ( m , 4 ) if ( jj > 4 ) cycle e4 ( 1 , j , 4 , 3 ) =+ rdat % r07 ( k , 3 ) - rdat % r06 ( l , 7 ) * 2 + rdat % r05 ( m , 5 ) + rdat % r05 ( m , 11 ) e4 ( 2 , j , 4 , 3 ) =+ rdat % r07 ( k , 4 ) - rdat % r06 ( l , 8 ) * 2 + rdat % r05 ( m , 6 ) + rdat % r05 ( m , 12 ) if ( jj > 3 ) cycle do i = 1 , 4 e3 ( i , j , 4 , 3 ) =+ rdat % r06 ( k , i + 8 ) - rdat % r05 ( l , i + 16 ) * 2 + rdat % r04 ( m , i + 13 ) + rdat % r04 ( m , i + 25 ) enddo if ( jj > 2 ) cycle do i = 1 , 4 e2 ( i , j , 4 , 3 ) =+ rdat % r05 ( k , i + 20 ) - rdat % r04 ( l , i + 33 ) * 2 + rdat % r03 ( m , i + 26 ) + rdat % r03 ( m , i + 38 ) enddo if ( jj > 1 ) cycle m = in6 ( m ) do i = 1 , 5 e1 ( i , 4 , 3 ) =+ rdat % r04 ( k , i + 37 ) - rdat % r03 ( l , i + 47 ) * 2 + rdat % r02 ( m , i + 36 ) + rdat % r02 ( m , i + 51 ) enddo enddo enddo j = 0 do jj = 1 , 5 do ii = 1 , jj j = j + 1 k = ind ( j , 5 , 3 ) l = k - 3 - jj m = l - 2 - jj e5 ( j , 5 , 3 ) =+ rdat % r08 ( k ) - rdat % r07 ( l , 1 ) - rdat % r07 ( l , 2 ) * 2 & & + rdat % r06 ( m , 1 ) * 3 + rdat % r06 ( m , 3 ) * 2 + rdat % r06 ( m , 4 ) & & - rdat % r05 ( j , 1 ) - rdat % r05 ( j , 2 ) * 2 - rdat % r05 ( j , 4 ) if ( jj > 4 ) cycle do i = 1 , 2 e4 ( i , j , 5 , 3 ) =+ rdat % r07 ( k , i + 2 ) - rdat % r06 ( l , i + 4 ) - rdat % r06 ( l , i + 6 ) * 2 & & + rdat % r05 ( m , i + 4 ) * 3 + rdat % r05 ( m , i + 8 ) * 2 + rdat % r05 ( m , i + 10 ) & & - rdat % r04 ( j , i + 5 ) - rdat % r04 ( j , i + 7 ) * 2 - rdat % r04 ( j , i + 11 ) enddo if ( jj > 3 ) cycle do i = 1 , 4 e3 ( i , j , 5 , 3 ) =+ rdat % r06 ( k , i + 8 ) - rdat % r05 ( l , i + 12 ) - rdat % r05 ( l , i + 16 ) * 2 & & + rdat % r04 ( m , i + 13 ) * 3 + rdat % r04 ( m , i + 21 ) * 2 + rdat % r04 ( m , i + 25 ) & & - rdat % r03 ( j , i + 10 ) - rdat % r03 ( j , i + 14 ) * 2 - rdat % r03 ( j , i + 22 ) enddo if ( jj > 2 ) cycle n = in6 ( j ) do i = 1 , 4 e2 ( i , j , 5 , 3 ) =+ rdat % r05 ( k , i + 20 ) - rdat % r04 ( l , i + 29 ) - rdat % r04 ( l , i + 33 ) * 2 & & + rdat % r03 ( m , i + 26 ) * 3 + rdat % r03 ( m , i + 34 ) * 2 + rdat % r03 ( m , i + 38 ) & & - rdat % r02 ( n , i + 20 ) - rdat % r02 ( n , i + 24 ) * 2 - rdat % r02 ( n , i + 32 ) enddo if ( jj > 1 ) cycle m = in6 ( m ) do i = 1 , 5 e1 ( i , 5 , 3 ) =+ rdat % r04 ( k , i + 37 ) - rdat % r03 ( l , i + 42 ) - rdat % r03 ( l , i + 47 ) * 2 & & + rdat % r02 ( m , i + 36 ) * 3 + rdat % r02 ( m , i + 46 ) * 2 + rdat % r02 ( m , i + 51 ) & & - rdat % r01 ( j , i + 20 ) - rdat % r01 ( j , i + 25 ) * 2 - rdat % r01 ( j , i + 35 ) enddo enddo enddo j = 0 do jj = 1 , 5 do ii = 1 , jj j = j + 1 k = ind ( j , 6 , 3 ) l = k - 4 - jj m = l - 3 - jj n = m - 2 - jj if ( jj < 5 ) then e5 ( j , 6 , 3 ) = e5 ( j + jj , 5 , 3 ) else e5 ( j , 6 , 3 ) =+ rdat % r08 ( k ) - rdat % r07 ( l , 1 ) - rdat % r07 ( l , 2 ) * 2 & & + rdat % r06 ( m , 1 ) * 3 + rdat % r06 ( m , 3 ) * 2 + rdat % r06 ( m , 4 ) & & - rdat % r05 ( n , 1 ) - rdat % r05 ( n , 2 ) * 2 - rdat % r05 ( n , 4 ) endif if ( jj > 4 ) cycle if ( jj < 4 ) then e4 ( 1 , j , 6 , 3 ) = e4 ( 1 , j + jj , 5 , 3 ) e4 ( 2 , j , 6 , 3 ) = e4 ( 2 , j + jj , 5 , 3 ) else do i = 1 , 2 e4 ( i , j , 6 , 3 ) =+ rdat % r07 ( k , i + 2 ) - rdat % r06 ( l , i + 4 ) - rdat % r06 ( l , i + 6 ) * 2 & & + rdat % r05 ( m , i + 4 ) * 3 + rdat % r05 ( m , i + 8 ) * 2 + rdat % r05 ( m , i + 10 ) & & - rdat % r04 ( n , i + 5 ) - rdat % r04 ( n , i + 7 ) * 2 - rdat % r04 ( n , i + 11 ) enddo endif if ( jj > 3 ) cycle if ( jj < 3 ) then do i = 1 , 4 e3 ( i , j , 6 , 3 ) = e3 ( i , j + jj , 5 , 3 ) enddo else do i = 1 , 4 e3 ( i , j , 6 , 3 ) =+ rdat % r06 ( k , i + 8 ) - rdat % r05 ( l , i + 12 ) - rdat % r05 ( l , i + 16 ) * 2 & & + rdat % r04 ( m , i + 13 ) * 3 + rdat % r04 ( m , i + 21 ) * 2 + rdat % r04 ( m , i + 25 ) & & - rdat % r03 ( n , i + 10 ) - rdat % r03 ( n , i + 14 ) * 2 - rdat % r03 ( n , i + 22 ) enddo endif if ( jj > 2 ) cycle if ( jj < 2 ) then do i = 1 , 4 e2 ( i , j , 6 , 3 ) = e2 ( i , j + jj , 5 , 3 ) enddo else n = in6 ( n ) do i = 1 , 4 e2 ( i , j , 6 , 3 ) =+ rdat % r05 ( k , i + 20 ) - rdat % r04 ( l , i + 29 ) - rdat % r04 ( l , i + 33 ) * 2 & & + rdat % r03 ( m , i + 26 ) * 3 + rdat % r03 ( m , i + 34 ) * 2 + rdat % r03 ( m , i + 38 ) & & - rdat % r02 ( n , i + 20 ) - rdat % r02 ( n , i + 24 ) * 2 - rdat % r02 ( n , i + 32 ) enddo n = m - 2 - jj endif if ( jj > 1 ) cycle m = in6 ( m ) do i = 1 , 5 e1 ( i , 6 , 3 ) =+ rdat % r04 ( k , i + 37 ) - rdat % r03 ( l , i + 42 ) - rdat % r03 ( l , i + 47 ) * 2 & & + rdat % r02 ( m , i + 36 ) * 3 + rdat % r02 ( m , i + 46 ) * 2 + rdat % r02 ( m , i + 51 ) & & - rdat % r01 ( n , i + 20 ) - rdat % r01 ( n , i + 25 ) * 2 - rdat % r01 ( n , i + 35 ) enddo enddo enddo j = 0 do jj = 1 , 5 do ii = 1 , jj j = j + 1 k = ind ( j , 3 , 4 ) l = k - 3 - jj m = l - 2 - jj e5 ( j , 3 , 4 ) =+ rdat % r08 ( k ) - rdat % r07 ( l , 1 ) * 2 + rdat % r06 ( m , 1 ) + rdat % r06 ( m , 2 ) if ( jj > 4 ) cycle e4 ( 1 , j , 3 , 4 ) =+ rdat % r07 ( k , 3 ) - rdat % r06 ( l , 5 ) * 2 + rdat % r05 ( m , 5 ) + rdat % r05 ( m , 7 ) e4 ( 2 , j , 3 , 4 ) =+ rdat % r07 ( k , 4 ) - rdat % r06 ( l , 6 ) * 2 + rdat % r05 ( m , 6 ) + rdat % r05 ( m , 8 ) if ( jj > 3 ) cycle do i = 1 , 4 e3 ( i , j , 3 , 4 ) =+ rdat % r06 ( k , i + 8 ) - rdat % r05 ( l , i + 12 ) * 2 + rdat % r04 ( m , i + 13 ) + rdat % r04 ( m , i + 17 ) enddo if ( jj > 2 ) cycle do i = 1 , 4 e2 ( i , j , 3 , 4 ) =+ rdat % r05 ( k , i + 20 ) - rdat % r04 ( l , i + 29 ) * 2 + rdat % r03 ( m , i + 26 ) + rdat % r03 ( m , i + 30 ) enddo if ( jj > 1 ) cycle m = in6 ( m ) do i = 1 , 5 e1 ( i , 3 , 4 ) =+ rdat % r04 ( k , i + 37 ) - rdat % r03 ( l , i + 42 ) * 2 + rdat % r02 ( m , i + 36 ) + rdat % r02 ( m , i + 41 ) enddo enddo enddo do j = 1 , 15 k = ind ( j , 1 , 5 ) e5 ( j , 1 , 5 ) =+ rdat % r08 ( k ) - rdat % r07 ( j , 2 ) + ( rdat % r06 ( k , 1 ) - rdat % r05 ( j , 2 )) * 3 enddo do j = 1 , 10 k = ind ( j , 1 , 5 ) e4 ( 1 , j , 1 , 5 ) =+ rdat % r07 ( k , 3 ) - rdat % r06 ( j , 7 ) + ( rdat % r05 ( k , 5 ) - rdat % r04 ( j , 8 )) * 3 e4 ( 2 , j , 1 , 5 ) =+ rdat % r07 ( k , 4 ) - rdat % r06 ( j , 8 ) + ( rdat % r05 ( k , 6 ) - rdat % r04 ( j , 9 )) * 3 enddo do j = 1 , 6 k = ind ( j , 1 , 5 ) e3 ( 1 , j , 1 , 5 ) =+ rdat % r06 ( k , 9 ) - rdat % r05 ( j , 17 ) + ( rdat % r04 ( k , 14 ) - rdat % r03 ( j , 15 )) * 3 e3 ( 2 , j , 1 , 5 ) =+ rdat % r06 ( k , 10 ) - rdat % r05 ( j , 18 ) + ( rdat % r04 ( k , 15 ) - rdat % r03 ( j , 16 )) * 3 e3 ( 3 , j , 1 , 5 ) =+ rdat % r06 ( k , 11 ) - rdat % r05 ( j , 19 ) + ( rdat % r04 ( k , 16 ) - rdat % r03 ( j , 17 )) * 3 e3 ( 4 , j , 1 , 5 ) =+ rdat % r06 ( k , 12 ) - rdat % r05 ( j , 20 ) + ( rdat % r04 ( k , 17 ) - rdat % r03 ( j , 18 )) * 3 enddo do j = 1 , 3 k = ind ( j , 1 , 5 ) m = in6 ( j ) e2 ( 1 , j , 1 , 5 ) =+ rdat % r05 ( k , 21 ) - rdat % r04 ( j , 34 ) + ( rdat % r03 ( k , 27 ) - rdat % r02 ( m , 25 )) * 3 e2 ( 2 , j , 1 , 5 ) =+ rdat % r05 ( k , 22 ) - rdat % r04 ( j , 35 ) + ( rdat % r03 ( k , 28 ) - rdat % r02 ( m , 26 )) * 3 e2 ( 3 , j , 1 , 5 ) =+ rdat % r05 ( k , 23 ) - rdat % r04 ( j , 36 ) + ( rdat % r03 ( k , 29 ) - rdat % r02 ( m , 27 )) * 3 e2 ( 4 , j , 1 , 5 ) =+ rdat % r05 ( k , 24 ) - rdat % r04 ( j , 37 ) + ( rdat % r03 ( k , 30 ) - rdat % r02 ( m , 28 )) * 3 enddo j = 1 k = ind ( j , 1 , 5 ) m = in6 ( k ) do i = 1 , 5 e1 ( i , 1 , 5 ) =+ rdat % r04 ( k , i + 37 ) - rdat % r03 ( j , i + 47 ) + ( rdat % r02 ( m , i + 36 ) - rdat % r01 ( j , i + 25 )) * 3 enddo j = 0 do jj = 1 , 5 do ii = 1 , jj j = j + 1 k = ind ( j , 2 , 5 ) l = k - 3 - jj m = l - jj e5 ( j , 2 , 5 ) =+ rdat % r08 ( k ) - rdat % r07 ( l , 2 ) + rdat % r06 ( m , 1 ) - rdat % r05 ( j , 2 ) if ( jj > 4 ) cycle e4 ( 1 , j , 2 , 5 ) =+ rdat % r07 ( k , 3 ) - rdat % r06 ( l , 7 ) + rdat % r05 ( m , 5 ) - rdat % r04 ( j , 8 ) e4 ( 2 , j , 2 , 5 ) =+ rdat % r07 ( k , 4 ) - rdat % r06 ( l , 8 ) + rdat % r05 ( m , 6 ) - rdat % r04 ( j , 9 ) if ( jj > 3 ) cycle do i = 1 , 4 e3 ( i , j , 2 , 5 ) =+ rdat % r06 ( k , i + 8 ) - rdat % r05 ( l , i + 16 ) + rdat % r04 ( m , i + 13 ) - rdat % r03 ( j , i + 14 ) enddo if ( jj > 2 ) cycle n = in6 ( j ) do i = 1 , 4 e2 ( i , j , 2 , 5 ) =+ rdat % r05 ( k , i + 20 ) - rdat % r04 ( l , i + 33 ) + rdat % r03 ( m , i + 26 ) - rdat % r02 ( n , i + 24 ) enddo if ( jj > 1 ) cycle m = in6 ( m ) do i = 1 , 5 e1 ( i , 2 , 5 ) =+ rdat % r04 ( k , i + 37 ) - rdat % r03 ( l , i + 47 ) + rdat % r02 ( m , i + 36 ) - rdat % r01 ( j , i + 25 ) enddo enddo enddo j = 0 do jj = 1 , 5 do ii = 1 , jj j = j + 1 k = ind ( j , 3 , 5 ) l = k - 3 - jj m = l - 2 - jj e5 ( j , 3 , 5 ) =+ rdat % r08 ( k ) - rdat % r07 ( l , 1 ) * 2 - rdat % r07 ( l , 2 ) & & + rdat % r06 ( m , 1 ) * 3 + rdat % r06 ( m , 2 ) + rdat % r06 ( m , 3 ) * 2 & & - rdat % r05 ( j , 1 ) * 2 - rdat % r05 ( j , 2 ) - rdat % r05 ( j , 3 ) if ( jj > 4 ) cycle do i = 1 , 2 e4 ( i , j , 3 , 5 ) =+ rdat % r07 ( k , i + 2 ) - rdat % r06 ( l , i + 4 ) * 2 - rdat % r06 ( l , i + 6 ) & & + rdat % r05 ( m , i + 4 ) * 3 + rdat % r05 ( m , i + 6 ) + rdat % r05 ( m , i + 8 ) * 2 & & - rdat % r04 ( j , i + 5 ) * 2 - rdat % r04 ( j , i + 7 ) - rdat % r04 ( j , i + 9 ) enddo if ( jj > 3 ) cycle do i = 1 , 4 e3 ( i , j , 3 , 5 ) =+ rdat % r06 ( k , i + 8 ) - rdat % r05 ( l , i + 12 ) * 2 - rdat % r05 ( l , i + 16 ) & & + rdat % r04 ( m , i + 13 ) * 3 + rdat % r04 ( m , i + 17 ) + rdat % r04 ( m , i + 21 ) * 2 & & - rdat % r03 ( j , i + 10 ) * 2 - rdat % r03 ( j , i + 14 ) - rdat % r03 ( j , i + 18 ) enddo if ( jj > 2 ) cycle n = in6 ( j ) do i = 1 , 4 e2 ( i , j , 3 , 5 ) =+ rdat % r05 ( k , i + 20 ) - rdat % r04 ( l , i + 29 ) * 2 - rdat % r04 ( l , i + 33 ) & & + rdat % r03 ( m , i + 26 ) * 3 + rdat % r03 ( m , i + 30 ) + rdat % r03 ( m , i + 34 ) * 2 & & - rdat % r02 ( n , i + 20 ) * 2 - rdat % r02 ( n , i + 24 ) - rdat % r02 ( n , i + 28 ) enddo if ( jj > 1 ) cycle m = in6 ( m ) do i = 1 , 5 e1 ( i , 3 , 5 ) =+ rdat % r04 ( k , i + 37 ) - rdat % r03 ( l , i + 42 ) * 2 - rdat % r03 ( l , i + 47 ) & & + rdat % r02 ( m , i + 36 ) * 3 + rdat % r02 ( m , i + 41 ) + rdat % r02 ( m , i + 46 ) * 2 & & - rdat % r01 ( j , i + 20 ) * 2 - rdat % r01 ( j , i + 25 ) - rdat % r01 ( j , i + 30 ) enddo enddo enddo j = 0 do jj = 1 , 5 do ii = 1 , jj j = j + 1 k = ind ( j , 4 , 5 ) l = k - 2 - jj e5 ( j , 4 , 5 ) =+ rdat % r08 ( k ) - rdat % r07 ( l , 2 ) + rdat % r06 ( k , 1 ) - rdat % r05 ( l , 2 ) if ( jj > 4 ) cycle e4 ( 1 , j , 4 , 5 ) =+ rdat % r07 ( k , 3 ) - rdat % r06 ( l , 7 ) + rdat % r05 ( k , 5 ) - rdat % r04 ( l , 8 ) e4 ( 2 , j , 4 , 5 ) =+ rdat % r07 ( k , 4 ) - rdat % r06 ( l , 8 ) + rdat % r05 ( k , 6 ) - rdat % r04 ( l , 9 ) if ( jj > 3 ) cycle do i = 1 , 4 e3 ( i , j , 4 , 5 ) =+ rdat % r06 ( k , i + 8 ) - rdat % r05 ( l , i + 16 ) + rdat % r04 ( k , i + 13 ) - rdat % r03 ( l , i + 14 ) enddo if ( jj > 2 ) cycle m = in6 ( l ) do i = 1 , 4 e2 ( i , j , 4 , 5 ) =+ rdat % r05 ( k , i + 20 ) - rdat % r04 ( l , i + 33 ) + rdat % r03 ( k , i + 26 ) - rdat % r02 ( m , i + 24 ) enddo if ( jj > 1 ) cycle m = in6 ( k ) do i = 1 , 5 e1 ( i , 4 , 5 ) =+ rdat % r04 ( k , i + 37 ) - rdat % r03 ( l , i + 47 ) + rdat % r02 ( m , i + 36 ) - rdat % r01 ( l , i + 25 ) enddo enddo enddo j1 = 3 do j = 1 , 15 e5 ( j , 5 , 5 ) = t531e5 ( j ) + u5e5 ( j , j1 ) enddo do j = 1 , 10 e4 ( 1 , j , 5 , 5 ) = t531e4 ( 1 , j ) + u5e4 ( 1 , j , j1 ) e4 ( 2 , j , 5 , 5 ) = t531e4 ( 2 , j ) + u5e4 ( 2 , j , j1 ) enddo do j = 1 , 6 e3 ( 1 , j , 5 , 5 ) = t531e3 ( 1 , j ) + u5e3 ( 1 , j , j1 ) e3 ( 2 , j , 5 , 5 ) = t531e3 ( 2 , j ) + u5e3 ( 2 , j , j1 ) e3 ( 3 , j , 5 , 5 ) = t531e3 ( 3 , j ) + u5e3 ( 3 , j , j1 ) e3 ( 4 , j , 5 , 5 ) = t531e3 ( 4 , j ) + u5e3 ( 4 , j , j1 ) enddo do j = 1 , 3 e2 ( 1 , j , 5 , 5 ) = t531e2 ( 1 , j ) + u5e2 ( 1 , j , j1 ) e2 ( 2 , j , 5 , 5 ) = t531e2 ( 2 , j ) + u5e2 ( 2 , j , j1 ) e2 ( 3 , j , 5 , 5 ) = t531e2 ( 3 , j ) + u5e2 ( 3 , j , j1 ) e2 ( 4 , j , 5 , 5 ) = t531e2 ( 4 , j ) + u5e2 ( 4 , j , j1 ) enddo do i = 1 , 5 e1 ( i , 5 , 5 ) = t531e1 ( i ) + u5e1 ( i , j1 ) enddo j = 0 do jj = 1 , 5 do ii = 1 , jj j = j + 1 k = ind ( j , 6 , 5 ) l = k - 3 - jj m = l - 2 - jj e5 ( j , 6 , 5 ) =+ rdat % r08 ( k ) - rdat % r07 ( l , 1 ) - rdat % r07 ( l , 2 ) + rdat % r06 ( m , 1 ) + rdat % r06 ( m , 3 ) if ( jj > 4 ) cycle e4 ( 1 , j , 6 , 5 ) =+ rdat % r07 ( k , 3 ) - rdat % r06 ( l , 5 ) - rdat % r06 ( l , 7 ) + rdat % r05 ( m , 5 ) + rdat % r05 ( m , 9 ) e4 ( 2 , j , 6 , 5 ) =+ rdat % r07 ( k , 4 ) - rdat % r06 ( l , 6 ) - rdat % r06 ( l , 8 ) + rdat % r05 ( m , 6 ) + rdat % r05 ( m , 10 ) if ( jj > 3 ) cycle do i = 1 , 4 e3 ( i , j , 6 , 5 ) =+ rdat % r06 ( k , i + 8 ) - rdat % r05 ( l , i + 12 ) - rdat % r05 ( l , i + 16 ) & & + rdat % r04 ( m , i + 13 ) + rdat % r04 ( m , i + 21 ) enddo if ( jj > 2 ) cycle do i = 1 , 4 e2 ( i , j , 6 , 5 ) =+ rdat % r05 ( k , i + 20 ) - rdat % r04 ( l , i + 29 ) - rdat % r04 ( l , i + 33 ) & & + rdat % r03 ( m , i + 26 ) + rdat % r03 ( m , i + 34 ) enddo if ( jj > 1 ) cycle m = in6 ( m ) do i = 1 , 5 e1 ( i , 6 , 5 ) =+ rdat % r04 ( k , i + 37 ) - rdat % r03 ( l , i + 42 ) - rdat % r03 ( l , i + 47 ) & & + rdat % r02 ( m , i + 36 ) + rdat % r02 ( m , i + 46 ) enddo enddo enddo j = 0 do jj = 1 , 5 do ii = 1 , jj j = j + 1 k = ind ( j , 2 , 6 ) l = k - 4 - jj m = l - 1 - jj n = m - 2 - jj e5 ( j , 2 , 6 ) =+ rdat % r08 ( k ) - rdat % r07 ( l , 2 ) + rdat % r06 ( m , 1 ) * 3 - rdat % r05 ( n , 2 ) * 3 if ( jj > 4 ) cycle e4 ( 1 , j , 2 , 6 ) =+ rdat % r07 ( k , 3 ) - rdat % r06 ( l , 7 ) + rdat % r05 ( m , 5 ) * 3 - rdat % r04 ( n , 8 ) * 3 e4 ( 2 , j , 2 , 6 ) =+ rdat % r07 ( k , 4 ) - rdat % r06 ( l , 8 ) + rdat % r05 ( m , 6 ) * 3 - rdat % r04 ( n , 9 ) * 3 if ( jj > 3 ) cycle do i = 1 , 4 e3 ( i , j , 2 , 6 ) =+ rdat % r06 ( k , i + 8 ) - rdat % r05 ( l , i + 16 ) + rdat % r04 ( m , i + 13 ) * 3 - rdat % r03 ( n , i + 14 ) * 3 enddo if ( jj > 2 ) cycle n = in6 ( n ) do i = 1 , 4 i4 = i + 20 e2 ( i , j , 2 , 6 ) =+ rdat % r05 ( k , i4 ) - rdat % r04 ( l , i + 33 ) + rdat % r03 ( m , i + 26 ) * 3 - rdat % r02 ( n , i + 24 ) * 3 enddo n = m - 2 - jj if ( jj > 1 ) cycle m = in6 ( m ) do i = 1 , 5 i4 = i + 37 e1 ( i , 2 , 6 ) =+ rdat % r04 ( k , i4 ) - rdat % r03 ( l , i + 47 ) + rdat % r02 ( m , i + 36 ) * 3 - rdat % r01 ( n , i + 25 ) * 3 enddo enddo enddo j = 0 do jj = 1 , 5 do ii = 1 , jj j = j + 1 k = ind ( j , 3 , 6 ) l = k - 4 - jj m = l - 3 - jj n = m - 2 - jj if ( jj < 5 ) then e5 ( j , 3 , 6 ) = e5 ( j + jj , 3 , 5 ) else e5 ( j , 3 , 6 ) =+ rdat % r08 ( k ) - rdat % r07 ( l , 1 ) * 2 - rdat % r07 ( l , 2 ) & & + rdat % r06 ( m , 1 ) * 3 + rdat % r06 ( m , 2 ) + rdat % r06 ( m , 3 ) * 2 & & - rdat % r05 ( n , 1 ) * 2 - rdat % r05 ( n , 2 ) - rdat % r05 ( n , 3 ) endif if ( jj > 4 ) cycle if ( jj < 4 ) then e4 ( 1 , j , 3 , 6 ) = e4 ( 1 , j + jj , 3 , 5 ) e4 ( 2 , j , 3 , 6 ) = e4 ( 2 , j + jj , 3 , 5 ) else do i = 1 , 2 e4 ( i , j , 3 , 6 ) =+ rdat % r07 ( k , i + 2 ) - rdat % r06 ( l , i + 4 ) * 2 - rdat % r06 ( l , i + 6 ) & & + rdat % r05 ( m , i + 4 ) * 3 + rdat % r05 ( m , i + 6 ) + rdat % r05 ( m , i + 8 ) * 2 & & - rdat % r04 ( n , i + 5 ) * 2 - rdat % r04 ( n , i + 7 ) - rdat % r04 ( n , i + 9 ) enddo endif if ( jj > 3 ) cycle if ( jj < 3 ) then do i = 1 , 4 e3 ( i , j , 3 , 6 ) = e3 ( i , j + jj , 3 , 5 ) enddo else do i = 1 , 4 i4 = i + 10 e3 ( i , j , 3 , 6 ) =+ rdat % r06 ( k , i + 8 ) - rdat % r05 ( l , i + 12 ) * 2 - rdat % r05 ( l , i + 16 ) & & + rdat % r04 ( m , i + 13 ) * 3 + rdat % r04 ( m , i + 17 ) + rdat % r04 ( m , i + 21 ) * 2 & & - rdat % r03 ( n , i + 10 ) * 2 - rdat % r03 ( n , i + 14 ) - rdat % r03 ( n , i + 18 ) enddo endif if ( jj > 2 ) cycle if ( jj < 2 ) then do i = 1 , 4 e2 ( i , j , 3 , 6 ) = e2 ( i , j + jj , 3 , 5 ) enddo else n = in6 ( n ) do i = 1 , 4 e2 ( i , j , 3 , 6 ) =+ rdat % r05 ( k , i + 20 ) - rdat % r04 ( l , i + 29 ) * 2 - rdat % r04 ( l , i + 33 ) & & + rdat % r03 ( m , i + 26 ) * 3 + rdat % r03 ( m , i + 30 ) + rdat % r03 ( m , i + 34 ) * 2 & & - rdat % r02 ( n , i + 20 ) * 2 - rdat % r02 ( n , i + 24 ) - rdat % r02 ( n , i + 28 ) enddo n = m - 2 - jj endif if ( jj > 1 ) cycle m = in6 ( m ) do i = 1 , 5 e1 ( i , 3 , 6 ) =+ rdat % r04 ( k , i + 37 ) - rdat % r03 ( l , i + 42 ) * 2 - rdat % r03 ( l , i + 47 ) & & + rdat % r02 ( m , i + 36 ) * 3 + rdat % r02 ( m , i + 41 ) + rdat % r02 ( m , i + 46 ) * 2 & & - rdat % r01 ( n , i + 20 ) * 2 - rdat % r01 ( n , i + 25 ) - rdat % r01 ( n , i + 30 ) enddo enddo enddo j1 = 3 do j = 1 , 15 e5 ( j , 6 , 6 ) = t632e5 ( j ) + u6e5 ( j , j1 ) enddo do j = 1 , 10 e4 ( 1 , j , 6 , 6 ) = t632e4 ( 1 , j ) + u6e4 ( 1 , j , j1 ) e4 ( 2 , j , 6 , 6 ) = t632e4 ( 2 , j ) + u6e4 ( 2 , j , j1 ) enddo do j = 1 , 6 e3 ( 1 , j , 6 , 6 ) = t632e3 ( 1 , j ) + u6e3 ( 1 , j , j1 ) e3 ( 2 , j , 6 , 6 ) = t632e3 ( 2 , j ) + u6e3 ( 2 , j , j1 ) e3 ( 3 , j , 6 , 6 ) = t632e3 ( 3 , j ) + u6e3 ( 3 , j , j1 ) e3 ( 4 , j , 6 , 6 ) = t632e3 ( 4 , j ) + u6e3 ( 4 , j , j1 ) enddo do j = 1 , 3 e2 ( 1 , j , 6 , 6 ) = t632e2 ( 1 , j ) + u6e2 ( 1 , j , j1 ) e2 ( 2 , j , 6 , 6 ) = t632e2 ( 2 , j ) + u6e2 ( 2 , j , j1 ) e2 ( 3 , j , 6 , 6 ) = t632e2 ( 3 , j ) + u6e2 ( 3 , j , j1 ) e2 ( 4 , j , 6 , 6 ) = t632e2 ( 4 , j ) + u6e2 ( 4 , j , j1 ) enddo do i = 1 , 5 e1 ( i , 6 , 6 ) = t632e1 ( i ) + u6e1 ( i , j1 ) enddo xx = qx * qx zz = qz * qz xz = qx * qz xxx = xx * qx xxz = xx * qz xzz = zz * qx zzz = zz * qz xxxx = xx * xx xxxz = xx * xz xxzz = xx * zz xzzz = xz * zz zzzz = zz * zz qxd = qx + qx qzd = qz + qz xzd = xz + xz xxxd = xxx + xxx xxzd = xxz + xxz xzzd = xzz + xzz zzzd = zzz + zzz xzq = xz + xz + xz + xz do l = 1 , lx do k = 1 , kx if ( k == 1 . and . l == 2 ) cycle if ( k /= 3 . and . l == 4 ) cycle if ( k == 1 . and . l == 6 ) cycle if ( k == 4 . and . l == 6 ) cycle if ( k == 5 . and . l == 6 ) cycle f ( 1 , 1 , k , l ) = e5 ( 1 , k , l ) + e3 ( 1 , 1 , k , l ) * 6 + e1 ( 1 , k , l ) * 3 + ( + e4 ( 1 , 1 , k , l ) + e4 ( 2 , 1 , k , l ) + ( + e2 ( 1 , 1 , k , l ) + e2 ( 2 , 1 , k , l )) * 3 ) * qxd + ( + e3 ( 2 , 1 , k , l ) + e3 ( 3 , 1 , k , l ) * 4 + e3 ( 4 , 1 , k , l ) + e1 ( 2 , k , l ) + e1 ( 3 , k , l ) * 4 + e1 ( 4 , k , l )) * xx + ( + e2 ( 3 , 1 , k , l ) + e2 ( 4 , 1 , k , l )) * xxxd + e1 ( 5 , k , l ) * xxxx f ( 2 , 1 , k , l ) = e5 ( 4 , k , l ) + e3 ( 1 , 4 , k , l ) + e3 ( 1 , 1 , k , l ) + e1 ( 1 , k , l ) + ( + e4 ( 2 , 4 , k , l ) + e2 ( 2 , 1 , k , l )) * qxd + ( + e3 ( 4 , 4 , k , l ) + e1 ( 4 , k , l )) * xx f ( 3 , 1 , k , l ) = e5 ( 6 , k , l ) + e3 ( 1 , 6 , k , l ) + e3 ( 1 , 1 , k , l ) + e1 ( 1 , k , l ) + ( + e4 ( 2 , 6 , k , l ) + e2 ( 2 , 1 , k , l )) * qxd + ( + e4 ( 1 , 3 , k , l ) + e2 ( 1 , 3 , k , l )) * qzd + ( + e3 ( 4 , 6 , k , l ) + e1 ( 4 , k , l )) * xx + e3 ( 3 , 3 , k , l ) * xzq + ( + e3 ( 2 , 1 , k , l ) + e1 ( 2 , k , l )) * zz + e2 ( 4 , 3 , k , l ) * xxzd + e2 ( 3 , 1 , k , l ) * xzzd + e1 ( 5 , k , l ) * xxzz f ( 4 , 1 , k , l ) = e5 ( 2 , k , l ) + e3 ( 1 , 2 , k , l ) * 3 + ( + e4 ( 1 , 2 , k , l ) + e4 ( 2 , 2 , k , l ) * 2 + e2 ( 1 , 2 , k , l ) + e2 ( 2 , 2 , k , l ) * 2 ) * qx + ( + e3 ( 3 , 2 , k , l ) * 2 + e3 ( 4 , 2 , k , l )) * xx + e2 ( 4 , 2 , k , l ) * xxx f ( 5 , 1 , k , l ) = e5 ( 3 , k , l ) + e3 ( 1 , 3 , k , l ) * 3 + ( + e4 ( 1 , 3 , k , l ) + e4 ( 2 , 3 , k , l ) * 2 + e2 ( 1 , 3 , k , l ) + e2 ( 2 , 3 , k , l ) * 2 ) * qx + ( + e4 ( 1 , 1 , k , l ) + e2 ( 1 , 1 , k , l ) * 3 ) * qz + ( + e3 ( 3 , 3 , k , l ) * 2 + e3 ( 4 , 3 , k , l )) * xx + ( + e3 ( 2 , 1 , k , l ) + e3 ( 3 , 1 , k , l ) * 2 + e1 ( 2 , k , l ) + e1 ( 3 , k , l ) * 2 ) * xz + e2 ( 4 , 3 , k , l ) * xxx + ( + e2 ( 3 , 1 , k , l ) * 2 + e2 ( 4 , 1 , k , l )) * xxz + e1 ( 5 , k , l ) * xxxz f ( 6 , 1 , k , l ) = e5 ( 5 , k , l ) + e3 ( 1 , 5 , k , l ) + e4 ( 2 , 5 , k , l ) * qxd + ( + e4 ( 1 , 2 , k , l ) + e2 ( 1 , 2 , k , l )) * qz + e3 ( 4 , 5 , k , l ) * xx + e3 ( 3 , 2 , k , l ) * xzd + e2 ( 4 , 2 , k , l ) * xxz f ( 1 , 2 , k , l ) = e5 ( 4 , k , l ) + e3 ( 1 , 4 , k , l ) + e3 ( 1 , 1 , k , l ) + e1 ( 1 , k , l ) + ( + e4 ( 1 , 4 , k , l ) + e2 ( 1 , 1 , k , l )) * qxd + ( + e3 ( 2 , 4 , k , l ) + e1 ( 2 , k , l )) * xx f ( 2 , 2 , k , l ) = e5 ( 11 , k , l ) + e3 ( 1 , 4 , k , l ) * 6 + e1 ( 1 , k , l ) * 3 f ( 3 , 2 , k , l ) = e5 ( 13 , k , l ) + e3 ( 1 , 6 , k , l ) + e3 ( 1 , 4 , k , l ) + e1 ( 1 , k , l ) + ( + e4 ( 1 , 8 , k , l ) + e2 ( 1 , 3 , k , l )) * qzd + ( + e3 ( 2 , 4 , k , l ) + e1 ( 2 , k , l )) * zz f ( 4 , 2 , k , l ) = e5 ( 7 , k , l ) + e3 ( 1 , 2 , k , l ) * 3 + ( + e4 ( 1 , 7 , k , l ) + e2 ( 1 , 2 , k , l ) * 3 ) * qx f ( 5 , 2 , k , l ) = e5 ( 8 , k , l ) + e3 ( 1 , 3 , k , l ) + ( + e4 ( 1 , 8 , k , l ) + e2 ( 1 , 3 , k , l )) * qx + ( + e4 ( 1 , 4 , k , l ) + e2 ( 1 , 1 , k , l )) * qz + ( + e3 ( 2 , 4 , k , l ) + e1 ( 2 , k , l )) * xz f ( 6 , 2 , k , l ) = e5 ( 12 , k , l ) + e3 ( 1 , 5 , k , l ) * 3 + ( + e4 ( 1 , 7 , k , l ) + e2 ( 1 , 2 , k , l ) * 3 ) * qz f ( 1 , 3 , k , l ) = e5 ( 6 , k , l ) + e3 ( 1 , 6 , k , l ) + e3 ( 1 , 1 , k , l ) + e1 ( 1 , k , l ) + ( + e4 ( 1 , 6 , k , l ) + e2 ( 1 , 1 , k , l )) * qxd + ( + e4 ( 2 , 3 , k , l ) + e2 ( 2 , 3 , k , l )) * qzd + ( + e3 ( 2 , 6 , k , l ) + e1 ( 2 , k , l )) * xx + e3 ( 3 , 3 , k , l ) * xzq + ( + e3 ( 4 , 1 , k , l ) + e1 ( 4 , k , l )) * zz + e2 ( 3 , 3 , k , l ) * xxzd + e2 ( 4 , 1 , k , l ) * xzzd + e1 ( 5 , k , l ) * xxzz f ( 2 , 3 , k , l ) = e5 ( 13 , k , l ) + e3 ( 1 , 6 , k , l ) + e3 ( 1 , 4 , k , l ) + e1 ( 1 , k , l ) + ( + e4 ( 2 , 8 , k , l ) + e2 ( 2 , 3 , k , l )) * qzd + ( + e3 ( 4 , 4 , k , l ) + e1 ( 4 , k , l )) * zz f ( 3 , 3 , k , l ) = e5 ( 15 , k , l ) + e3 ( 1 , 6 , k , l ) * 6 + e1 ( 1 , k , l ) * 3 + ( + e4 ( 1 , 10 , k , l ) + e4 ( 2 , 10 , k , l ) + ( + e2 ( 1 , 3 , k , l ) + e2 ( 2 , 3 , k , l )) * 3 ) * qzd + ( + e3 ( 2 , 6 , k , l ) + e3 ( 3 , 6 , k , l ) * 4 + e3 ( 4 , 6 , k , l ) + e1 ( 2 , k , l ) + e1 ( 3 , k , l ) * 4 + e1 ( 4 , k , l )) * zz + ( + e2 ( 3 , 3 , k , l ) + e2 ( 4 , 3 , k , l )) * zzzd + e1 ( 5 , k , l ) * zzzz f ( 4 , 3 , k , l ) = e5 ( 9 , k , l ) + e3 ( 1 , 2 , k , l ) + ( + e4 ( 1 , 9 , k , l ) + e2 ( 1 , 2 , k , l )) * qx + e4 ( 2 , 5 , k , l ) * qzd + e3 ( 3 , 5 , k , l ) * xzd + e3 ( 4 , 2 , k , l ) * zz + e2 ( 4 , 2 , k , l ) * xzz f ( 5 , 3 , k , l ) = e5 ( 10 , k , l ) + e3 ( 1 , 3 , k , l ) * 3 + ( + e4 ( 1 , 10 , k , l ) + e2 ( 1 , 3 , k , l ) * 3 ) * qx + ( + e4 ( 1 , 6 , k , l ) + e4 ( 2 , 6 , k , l ) * 2 + e2 ( 1 , 1 , k , l ) + e2 ( 2 , 1 , k , l ) * 2 ) * qz + ( + e3 ( 2 , 6 , k , l ) + e3 ( 3 , 6 , k , l ) * 2 + e1 ( 2 , k , l ) + e1 ( 3 , k , l ) * 2 ) * xz + ( + e3 ( 3 , 3 , k , l ) * 2 + e3 ( 4 , 3 , k , l )) * zz + ( + e2 ( 3 , 3 , k , l ) * 2 + e2 ( 4 , 3 , k , l )) * xzz + e2 ( 4 , 1 , k , l ) * zzz + e1 ( 5 , k , l ) * xzzz f ( 6 , 3 , k , l ) = e5 ( 14 , k , l ) + e3 ( 1 , 5 , k , l ) * 3 + ( + e4 ( 1 , 9 , k , l ) + e4 ( 2 , 9 , k , l ) * 2 + e2 ( 1 , 2 , k , l ) + e2 ( 2 , 2 , k , l ) * 2 ) * qz + ( + e3 ( 3 , 5 , k , l ) * 2 + e3 ( 4 , 5 , k , l )) * zz + e2 ( 4 , 2 , k , l ) * zzz f ( 1 , 4 , k , l ) = e5 ( 2 , k , l ) + e3 ( 1 , 2 , k , l ) * 3 + ( + e4 ( 1 , 2 , k , l ) * 2 + e4 ( 2 , 2 , k , l ) + e2 ( 1 , 2 , k , l ) * 2 + e2 ( 2 , 2 , k , l )) * qx + ( + e3 ( 2 , 2 , k , l ) + e3 ( 3 , 2 , k , l ) * 2 ) * xx + e2 ( 3 , 2 , k , l ) * xxx f ( 2 , 4 , k , l ) = e5 ( 7 , k , l ) + e3 ( 1 , 2 , k , l ) * 3 + ( + e4 ( 2 , 7 , k , l ) + e2 ( 2 , 2 , k , l ) * 3 ) * qx f ( 3 , 4 , k , l ) = e5 ( 9 , k , l ) + e3 ( 1 , 2 , k , l ) + ( + e4 ( 2 , 9 , k , l ) + e2 ( 2 , 2 , k , l )) * qx + e4 ( 1 , 5 , k , l ) * qzd + e3 ( 3 , 5 , k , l ) * xzd + e3 ( 2 , 2 , k , l ) * zz + e2 ( 3 , 2 , k , l ) * xzz f ( 4 , 4 , k , l ) = e5 ( 4 , k , l ) + e3 ( 1 , 4 , k , l ) + e3 ( 1 , 1 , k , l ) + e1 ( 1 , k , l ) + ( + e4 ( 1 , 4 , k , l ) + e4 ( 2 , 4 , k , l ) + e2 ( 1 , 1 , k , l ) + e2 ( 2 , 1 , k , l )) * qx + ( + e3 ( 3 , 4 , k , l ) + e1 ( 3 , k , l )) * xx f ( 5 , 4 , k , l ) = e5 ( 5 , k , l ) + e3 ( 1 , 5 , k , l ) + ( + e4 ( 1 , 5 , k , l ) + e4 ( 2 , 5 , k , l )) * qx + ( + e4 ( 1 , 2 , k , l ) + e2 ( 1 , 2 , k , l )) * qz + e3 ( 3 , 5 , k , l ) * xx + ( + e3 ( 2 , 2 , k , l ) + e3 ( 3 , 2 , k , l )) * xz + e2 ( 3 , 2 , k , l ) * xxz f ( 6 , 4 , k , l ) = e5 ( 8 , k , l ) + e3 ( 1 , 3 , k , l ) + ( + e4 ( 2 , 8 , k , l ) + e2 ( 2 , 3 , k , l )) * qx + ( + e4 ( 1 , 4 , k , l ) + e2 ( 1 , 1 , k , l )) * qz + ( + e3 ( 3 , 4 , k , l ) + e1 ( 3 , k , l )) * xz f ( 1 , 5 , k , l ) = e5 ( 3 , k , l ) + e3 ( 1 , 3 , k , l ) * 3 + ( + e4 ( 1 , 3 , k , l ) * 2 + e4 ( 2 , 3 , k , l ) + e2 ( 1 , 3 , k , l ) * 2 + e2 ( 2 , 3 , k , l )) * qx + ( + e4 ( 2 , 1 , k , l ) + e2 ( 2 , 1 , k , l ) * 3 ) * qz + ( + e3 ( 2 , 3 , k , l ) + e3 ( 3 , 3 , k , l ) * 2 ) * xx + ( + e3 ( 3 , 1 , k , l ) * 2 + e3 ( 4 , 1 , k , l ) + e1 ( 3 , k , l ) * 2 + e1 ( 4 , k , l )) * xz + e2 ( 3 , 3 , k , l ) * xxx + ( + e2 ( 3 , 1 , k , l ) + e2 ( 4 , 1 , k , l ) * 2 ) * xxz + e1 ( 5 , k , l ) * xxxz f ( 2 , 5 , k , l ) = e5 ( 8 , k , l ) + e3 ( 1 , 3 , k , l ) + ( + e4 ( 2 , 8 , k , l ) + e2 ( 2 , 3 , k , l )) * qx + ( + e4 ( 2 , 4 , k , l ) + e2 ( 2 , 1 , k , l )) * qz + ( + e3 ( 4 , 4 , k , l ) + e1 ( 4 , k , l )) * xz f ( 3 , 5 , k , l ) = e5 ( 10 , k , l ) + e3 ( 1 , 3 , k , l ) * 3 + ( + e4 ( 2 , 10 , k , l ) + e2 ( 2 , 3 , k , l ) * 3 ) * qx + ( + e4 ( 1 , 6 , k , l ) * 2 + e4 ( 2 , 6 , k , l ) + e2 ( 1 , 1 , k , l ) * 2 + e2 ( 2 , 1 , k , l )) * qz + ( + e3 ( 3 , 6 , k , l ) * 2 + e3 ( 4 , 6 , k , l ) + e1 ( 3 , k , l ) * 2 + e1 ( 4 , k , l )) * xz + ( + e3 ( 2 , 3 , k , l ) + e3 ( 3 , 3 , k , l ) * 2 ) * zz + ( + e2 ( 3 , 3 , k , l ) + e2 ( 4 , 3 , k , l ) * 2 ) * xzz + e2 ( 3 , 1 , k , l ) * zzz + e1 ( 5 , k , l ) * xzzz f ( 4 , 5 , k , l ) = e5 ( 5 , k , l ) + e3 ( 1 , 5 , k , l ) + ( + e4 ( 1 , 5 , k , l ) + e4 ( 2 , 5 , k , l )) * qx + ( + e4 ( 2 , 2 , k , l ) + e2 ( 2 , 2 , k , l )) * qz + e3 ( 3 , 5 , k , l ) * xx + ( + e3 ( 3 , 2 , k , l ) + e3 ( 4 , 2 , k , l )) * xz + e2 ( 4 , 2 , k , l ) * xxz f ( 5 , 5 , k , l ) = e5 ( 6 , k , l ) + e3 ( 1 , 6 , k , l ) + e3 ( 1 , 1 , k , l ) + e1 ( 1 , k , l ) + ( + e4 ( 1 , 6 , k , l ) + e4 ( 2 , 6 , k , l ) + e2 ( 1 , 1 , k , l ) + e2 ( 2 , 1 , k , l )) * qx + ( + e4 ( 1 , 3 , k , l ) + e4 ( 2 , 3 , k , l ) + e2 ( 1 , 3 , k , l ) + e2 ( 2 , 3 , k , l )) * qz + ( + e3 ( 3 , 6 , k , l ) + e1 ( 3 , k , l )) * xx + ( + e3 ( 2 , 3 , k , l ) + e3 ( 3 , 3 , k , l ) * 2 + e3 ( 4 , 3 , k , l )) * xz + ( + e3 ( 3 , 1 , k , l ) + e1 ( 3 , k , l )) * zz + ( + e2 ( 3 , 3 , k , l ) + e2 ( 4 , 3 , k , l )) * xxz + ( + e2 ( 3 , 1 , k , l ) + e2 ( 4 , 1 , k , l )) * xzz + e1 ( 5 , k , l ) * xxzz f ( 6 , 5 , k , l ) = e5 ( 9 , k , l ) + e3 ( 1 , 2 , k , l ) + ( + e4 ( 2 , 9 , k , l ) + e2 ( 2 , 2 , k , l )) * qx + ( + e4 ( 1 , 5 , k , l ) + e4 ( 2 , 5 , k , l )) * qz + ( + e3 ( 3 , 5 , k , l ) + e3 ( 4 , 5 , k , l )) * xz + e3 ( 3 , 2 , k , l ) * zz + e2 ( 4 , 2 , k , l ) * xzz f ( 1 , 6 , k , l ) = e5 ( 5 , k , l ) + e3 ( 1 , 5 , k , l ) + e4 ( 1 , 5 , k , l ) * qxd + ( + e4 ( 2 , 2 , k , l ) + e2 ( 2 , 2 , k , l )) * qz + e3 ( 2 , 5 , k , l ) * xx + e3 ( 3 , 2 , k , l ) * xzd + e2 ( 3 , 2 , k , l ) * xxz f ( 2 , 6 , k , l ) = e5 ( 12 , k , l ) + e3 ( 1 , 5 , k , l ) * 3 + ( + e4 ( 2 , 7 , k , l ) + e2 ( 2 , 2 , k , l ) * 3 ) * qz f ( 3 , 6 , k , l ) = e5 ( 14 , k , l ) + e3 ( 1 , 5 , k , l ) * 3 + ( + e4 ( 1 , 9 , k , l ) * 2 + e4 ( 2 , 9 , k , l ) + e2 ( 1 , 2 , k , l ) * 2 + e2 ( 2 , 2 , k , l )) * qz + ( + e3 ( 2 , 5 , k , l ) + e3 ( 3 , 5 , k , l ) * 2 ) * zz + e2 ( 3 , 2 , k , l ) * zzz f ( 4 , 6 , k , l ) = e5 ( 8 , k , l ) + e3 ( 1 , 3 , k , l ) + ( + e4 ( 1 , 8 , k , l ) + e2 ( 1 , 3 , k , l )) * qx + ( + e4 ( 2 , 4 , k , l ) + e2 ( 2 , 1 , k , l )) * qz + ( + e3 ( 3 , 4 , k , l ) + e1 ( 3 , k , l )) * xz f ( 5 , 6 , k , l ) = e5 ( 9 , k , l ) + e3 ( 1 , 2 , k , l ) + ( + e4 ( 1 , 9 , k , l ) + e2 ( 1 , 2 , k , l )) * qx + ( + e4 ( 1 , 5 , k , l ) + e4 ( 2 , 5 , k , l )) * qz + ( + e3 ( 2 , 5 , k , l ) + e3 ( 3 , 5 , k , l )) * xz + e3 ( 3 , 2 , k , l ) * zz + e2 ( 3 , 2 , k , l ) * xzz f ( 6 , 6 , k , l ) = e5 ( 13 , k , l ) + e3 ( 1 , 6 , k , l ) + e3 ( 1 , 4 , k , l ) + e1 ( 1 , k , l ) + ( + e4 ( 1 , 8 , k , l ) + e4 ( 2 , 8 , k , l ) + e2 ( 1 , 3 , k , l ) + e2 ( 2 , 3 , k , l )) * qz + ( + e3 ( 3 , 4 , k , l ) + e1 ( 3 , k , l )) * zz enddo enddo f (:,:, 1 , 2 ) = f (:,:, 2 , 1 ) f (:,:, 1 , 4 ) = f (:,:, 4 , 1 ) f (:,:, 2 , 4 ) = f (:,:, 4 , 2 ) f (:,:, 4 , 4 ) = f (:,:, 2 , 1 ) f (:,:, 5 , 4 ) = f (:,:, 6 , 1 ) f (:,:, 6 , 4 ) = f (:,:, 5 , 2 ) f (:,:, 1 , 6 ) = f (:,:, 4 , 5 ) f (:,:, 4 , 6 ) = f (:,:, 2 , 5 ) f (:,:, 5 , 6 ) = f (:,:, 6 , 5 ) end subroutine mcdv_21 ! > ! >    @brief   auxiliary routine internal to rot.axis integrations ! > ! >    @details auxiliary routine internal to rot.axis integrations ! > subroutine fcufcc ( rdat , n , xmdt , fcu , fcc ) implicit none type ( rotaxis_data_t ) :: rdat integer :: n real ( kind = dp ) :: xmdt real ( kind = dp ) :: fcu ( 45 , 8 ), fcc ( 45 , 8 ) integer :: i , j , k real ( kind = dp ) :: xmdtx , xmdty , xmdtxy k = 1 do i = 1 , n k = k + i + 1 do j = 1 , k fcu ( j , i ) = 1.0_dp fcc ( j , i ) = xmdt enddo enddo xmdty =- xmdt * rdat % acy xmdtx =- xmdt * rdat % aqx xmdtxy = xmdt * rdat % aqxy fcu ( 1 , 1 ) =- rdat % aqx fcu ( 2 , 1 ) =- rdat % acy fcc ( 1 , 1 ) = xmdtx fcc ( 2 , 1 ) = xmdty ! If(n<=1) return fcu ( 4 , 2 ) = rdat % aqxy fcu ( 5 , 2 ) =- rdat % aqx fcu ( 6 , 2 ) =- rdat % acy fcc ( 4 , 2 ) = xmdtxy fcc ( 5 , 2 ) = xmdtx fcc ( 6 , 2 ) = xmdty ! If(n<=2) return fcu ( 1 , 3 ) =- rdat % aqx fcu ( 2 , 3 ) =- rdat % acy fcu ( 4 , 3 ) =- rdat % aqx fcu ( 5 , 3 ) = rdat % aqxy fcu ( 6 , 3 ) =- rdat % aqx fcu ( 7 , 3 ) =- rdat % acy fcu ( 9 , 3 ) =- rdat % acy fcc ( 1 , 3 ) = xmdtx fcc ( 2 , 3 ) = xmdty fcc ( 4 , 3 ) = xmdtx fcc ( 5 , 3 ) = xmdtxy fcc ( 6 , 3 ) = xmdtx fcc ( 7 , 3 ) = xmdty fcc ( 9 , 3 ) = xmdty ! If(n<=3) return fcu ( 2 , 4 ) = rdat % aqxy fcu ( 3 , 4 ) =- rdat % aqx fcu ( 5 , 4 ) =- rdat % acy fcu ( 7 , 4 ) = rdat % aqxy fcu ( 8 , 4 ) =- rdat % aqx fcu ( 9 , 4 ) = rdat % aqxy fcu ( 10 , 4 ) =- rdat % aqx fcu ( 12 , 4 ) =- rdat % acy fcu ( 14 , 4 ) =- rdat % acy fcc ( 2 , 4 ) = xmdtxy fcc ( 3 , 4 ) = xmdtx fcc ( 5 , 4 ) = xmdty fcc ( 7 , 4 ) = xmdtxy fcc ( 8 , 4 ) = xmdtx fcc ( 9 , 4 ) = xmdtxy fcc ( 10 , 4 ) = xmdtx fcc ( 12 , 4 ) = xmdty fcc ( 14 , 4 ) = xmdty ! If(n<=4) return do j = 1 , 10 fcu ( j , 5 ) = fcu ( j , 3 ) fcc ( j , 5 ) = fcc ( j , 3 ) enddo fcu ( 11 , 5 ) =- rdat % aqx fcu ( 12 , 5 ) = rdat % aqxy fcu ( 13 , 5 ) =- rdat % aqx fcu ( 14 , 5 ) = rdat % aqxy fcu ( 15 , 5 ) =- rdat % aqx fcu ( 16 , 5 ) =- rdat % acy fcu ( 18 , 5 ) =- rdat % acy fcu ( 20 , 5 ) =- rdat % acy fcc ( 11 , 5 ) = xmdtx fcc ( 12 , 5 ) = xmdtxy fcc ( 13 , 5 ) = xmdtx fcc ( 14 , 5 ) = xmdtxy fcc ( 15 , 5 ) = xmdtx fcc ( 16 , 5 ) = xmdty fcc ( 18 , 5 ) = xmdty fcc ( 20 , 5 ) = xmdty ! If(n<=5) return do j = 1 , 15 fcu ( j , 6 ) = fcu ( j , 4 ) fcc ( j , 6 ) = fcc ( j , 4 ) enddo fcu ( 16 , 6 ) = rdat % aqxy fcu ( 17 , 6 ) =- rdat % aqx fcu ( 18 , 6 ) = rdat % aqxy fcu ( 19 , 6 ) =- rdat % aqx fcu ( 20 , 6 ) = rdat % aqxy fcu ( 21 , 6 ) =- rdat % aqx fcu ( 23 , 6 ) =- rdat % acy fcu ( 25 , 6 ) =- rdat % acy fcu ( 27 , 6 ) =- rdat % acy fcc ( 16 , 6 ) = xmdtxy fcc ( 17 , 6 ) = xmdtx fcc ( 18 , 6 ) = xmdtxy fcc ( 19 , 6 ) = xmdtx fcc ( 20 , 6 ) = xmdtxy fcc ( 21 , 6 ) = xmdtx fcc ( 23 , 6 ) = xmdty fcc ( 25 , 6 ) = xmdty fcc ( 27 , 6 ) = xmdty if ( n <= 6 ) return do j = 1 , 21 fcu ( j , 7 ) = fcu ( j , 5 ) fcc ( j , 7 ) = fcc ( j , 5 ) enddo fcu ( 22 , 7 ) =- rdat % aqx fcu ( 23 , 7 ) = rdat % aqxy fcu ( 24 , 7 ) =- rdat % aqx fcu ( 25 , 7 ) = rdat % aqxy fcu ( 26 , 7 ) =- rdat % aqx fcu ( 27 , 7 ) = rdat % aqxy fcu ( 28 , 7 ) =- rdat % aqx fcu ( 29 , 7 ) =- rdat % acy fcu ( 31 , 7 ) =- rdat % acy fcu ( 33 , 7 ) =- rdat % acy fcu ( 35 , 7 ) =- rdat % acy fcc ( 22 , 7 ) = xmdtx fcc ( 23 , 7 ) = xmdtxy fcc ( 24 , 7 ) = xmdtx fcc ( 25 , 7 ) = xmdtxy fcc ( 26 , 7 ) = xmdtx fcc ( 27 , 7 ) = xmdtxy fcc ( 28 , 7 ) = xmdtx fcc ( 29 , 7 ) = xmdty fcc ( 31 , 7 ) = xmdty fcc ( 33 , 7 ) = xmdty fcc ( 35 , 7 ) = xmdty if ( n <= 7 ) return do j = 1 , 28 fcu ( j , 8 ) = fcu ( j , 6 ) fcc ( j , 8 ) = fcc ( j , 6 ) enddo fcu ( 29 , 8 ) = rdat % aqxy fcu ( 30 , 8 ) =- rdat % aqx fcu ( 31 , 8 ) = rdat % aqxy fcu ( 32 , 8 ) =- rdat % aqx fcu ( 33 , 8 ) = rdat % aqxy fcu ( 34 , 8 ) =- rdat % aqx fcu ( 35 , 8 ) = rdat % aqxy fcu ( 36 , 8 ) =- rdat % aqx fcu ( 38 , 8 ) =- rdat % acy fcu ( 40 , 8 ) =- rdat % acy fcu ( 42 , 8 ) =- rdat % acy fcu ( 44 , 8 ) =- rdat % acy fcc ( 29 , 8 ) = xmdtxy fcc ( 30 , 8 ) = xmdtx fcc ( 31 , 8 ) = xmdtxy fcc ( 32 , 8 ) = xmdtx fcc ( 33 , 8 ) = xmdtxy fcc ( 34 , 8 ) = xmdtx fcc ( 35 , 8 ) = xmdtxy fcc ( 36 , 8 ) = xmdtx fcc ( 38 , 8 ) = xmdty fcc ( 40 , 8 ) = xmdty fcc ( 42 , 8 ) = xmdty fcc ( 44 , 8 ) = xmdty end subroutine fcufcc ! > ! >    @brief   auxiliary routine of order 6 for rot.axis integrations ! > ! >    @details auxiliary routine of order 6 for rot.axis integrations ! > subroutine frikr6 ( rdat , i1 , i2 , wrk , qd6 , j0 , qd5 , k0 , qd4 , l0 , qd3 ) implicit none type ( rotaxis_data_t ) :: rdat integer :: i1 , i2 , j0 , k0 , l0 real ( kind = dp ) :: wrk ( 28 , * ), & qd6 ( 7 , * ), qd5 ( 6 , * ), qd4 ( 5 , * ), qd3 ( 4 , * ) integer :: i , j , k , l real ( kind = dp ) :: a11 , b11 , b13 , b22 , b23 , b33 , d11 , f31l03 , f31l15 , & f41k03 , f41k06 , f41k15 , f41k45 , f42k03 , f42k15 , f43k03 , & f43k06 , f43k45 , f51j03 , f51j06 , f51j10 , f51j15 , & f52j03 , f52j06 , f52j10 , f53j03 , f53j06 , & f54j03 , f54j10 , f55j15 , r11 , & s13 , s22 , s23 , s33 , u11 do i = i1 , i2 j = i + j0 k = i + k0 l = i + l0 f31l03 = qd3 ( 1 , l ) * 3 f31l15 = qd3 ( 1 , l ) * 15 f41k03 = qd4 ( 1 , k ) * 3 f41k06 = f41k03 + f41k03 f41k15 = qd4 ( 1 , k ) * 15 f41k45 = f41k15 * 3 f42k03 = qd4 ( 2 , k ) * 3 f42k15 = qd4 ( 2 , k ) * 15 f43k03 = qd4 ( 3 , k ) * 3 f43k06 = f43k03 + f43k03 f43k45 = f43k03 * 15 f51j03 = qd5 ( 1 , j ) * 3 f51j06 = f51j03 + f51j03 f51j10 = qd5 ( 1 , j ) * 10 f51j15 = qd5 ( 1 , j ) * 15 f52j03 = qd5 ( 2 , j ) * 3 f52j06 = f52j03 + f52j03 f52j10 = qd5 ( 2 , j ) * 10 f53j03 = qd5 ( 3 , j ) * 3 f53j06 = f53j03 + f53j03 f54j03 = qd5 ( 4 , j ) * 3 f54j10 = qd5 ( 4 , j ) * 10 f55j15 = qd5 ( 5 , j ) * 15 a11 = qd4 ( 1 , k ) * rdat % aqx2 - qd3 ( 1 , l ) r11 = f41k03 * rdat % acy2 - f31l03 b11 = qd5 ( 1 , j ) * rdat % aqx2 - qd4 ( 1 , k ) b13 = qd5 ( 1 , j ) * rdat % aqx2 - f41k03 b22 = f52j03 * rdat % aqx2 - f42k03 b23 = qd5 ( 2 , j ) * rdat % aqx2 - f42k03 b33 = qd5 ( 3 , j ) * rdat % aqx2 - qd4 ( 3 , k ) s13 = qd5 ( 1 , j ) * rdat % acy2 - f41k03 s22 = f52j03 * rdat % acy2 - f42k03 s23 = f52j03 * rdat % acy2 - f42k03 * 3 s33 = f53j06 * rdat % acy2 - f43k06 d11 = ( qd5 ( 1 , j ) * rdat % aqx2 - f41k06 ) * rdat % aqx2 + f31l03 u11 = ( qd5 ( 1 , j ) * rdat % acy2 - f41k06 ) * rdat % acy2 + f31l03 wrk ( 1 , i ) = (( qd6 ( 1 , i ) * rdat % aqx2 - f51j15 ) * rdat % aqx2 + f41k45 ) * rdat % aqx2 - f31l15 wrk ( 2 , i ) = ( qd6 ( 1 , i ) * rdat % aqx2 - f51j10 ) * rdat % aqx2 + f41k15 wrk ( 3 , i ) = ( qd6 ( 2 , i ) * rdat % aqx2 - f52j10 ) * rdat % aqx2 + f42k15 wrk ( 4 , i ) = (( qd6 ( 1 , i ) * rdat % aqx2 - f51j06 ) * rdat % aqx2 + f41k03 ) * rdat % acy2 - d11 wrk ( 5 , i ) = ( qd6 ( 2 , i ) * rdat % aqx2 - f52j06 ) * rdat % aqx2 + f42k03 wrk ( 6 , i ) = ( qd6 ( 3 , i ) * rdat % aqx2 - f53j06 ) * rdat % aqx2 + f43k03 - d11 wrk ( 7 , i ) = ( qd6 ( 1 , i ) * rdat % aqx2 - f51j03 ) * rdat % acy2 - b13 * 3 wrk ( 8 , i ) = ( qd6 ( 2 , i ) * rdat % aqx2 - f52j03 ) * rdat % acy2 - b23 wrk ( 9 , i ) = qd6 ( 3 , i ) * rdat % aqx2 - f53j03 - b13 wrk ( 10 , i ) = qd6 ( 4 , i ) * rdat % aqx2 - f54j03 - b23 * 3 wrk ( 11 , i ) = (( qd6 ( 1 , i ) * rdat % acy2 - f51j06 ) * rdat % acy2 + f41k03 ) * rdat % aqx2 - u11 wrk ( 12 , i ) = ( qd6 ( 2 , i ) * rdat % aqx2 - qd5 ( 2 , j )) * rdat % acy2 - b22 wrk ( 13 , i ) = ( qd6 ( 3 , i ) * rdat % aqx2 - qd5 ( 3 , j ) - b11 ) * rdat % acy2 - b33 + a11 wrk ( 14 , i ) = qd6 ( 4 , i ) * rdat % aqx2 - qd5 ( 4 , j ) - b22 wrk ( 15 , i ) = qd6 ( 5 , i ) * rdat % aqx2 - qd5 ( 5 , j ) - b33 * 6 + a11 * 3 wrk ( 16 , i ) = ( qd6 ( 1 , i ) * rdat % acy2 - f51j10 ) * rdat % acy2 + f41k15 wrk ( 17 , i ) = ( qd6 ( 2 , i ) * rdat % acy2 - f52j06 ) * rdat % acy2 + f42k03 wrk ( 18 , i ) = qd6 ( 3 , i ) * rdat % acy2 - f53j03 - s13 wrk ( 19 , i ) = qd6 ( 4 , i ) * rdat % acy2 - qd5 ( 4 , j ) - s22 wrk ( 20 , i ) = qd6 ( 5 , i ) - f53j06 + f41k03 wrk ( 21 , i ) = qd6 ( 6 , i ) - f54j10 + f42k15 wrk ( 22 , i ) = (( qd6 ( 1 , i ) * rdat % acy2 - f51j15 ) * rdat % acy2 + f41k45 ) * rdat % acy2 - f31l15 wrk ( 23 , i ) = ( qd6 ( 2 , i ) * rdat % acy2 - f52j10 ) * rdat % acy2 + f42k15 wrk ( 24 , i ) = ( qd6 ( 3 , i ) * rdat % acy2 - f53j06 ) * rdat % acy2 + f43k03 - u11 wrk ( 25 , i ) = qd6 ( 4 , i ) * rdat % acy2 - f54j03 - s23 wrk ( 26 , i ) = qd6 ( 5 , i ) * rdat % acy2 - qd5 ( 5 , j ) - s33 + r11 wrk ( 27 , i ) = qd6 ( 6 , i ) - f54j10 + f42k15 wrk ( 28 , i ) = qd6 ( 7 , i ) - f55j15 + f43k45 - f31l15 enddo end subroutine frikr6 ! > ! >    @brief   auxiliary routine of order 7 for rot.axis integrations ! > ! >    @details auxiliary routine of order 7 for rot.axis integrations ! > subroutine frikr7 ( rdat , i1 , i2 , wrk , qd7 , j0 , qd6 , k0 , qd5 , l0 , qd4 ) implicit none type ( rotaxis_data_t ) :: rdat integer :: i1 , i2 , j0 , k0 , l0 real ( kind = dp ) :: wrk ( 36 , * ), qd7 ( 8 , * ), qd6 ( 7 , * ), qd5 ( 6 , * ), qd4 ( 5 , * ) integer :: i , j , k , l real ( kind = dp ) :: a11 , a13 , a22 , b23 , b33 , b3t , b44 , d1s , d1t , d2s , & f41l03 , f41l15 , f41l1h , f42l03 , f42l15 , f42l1h , & f51k03 , f51k06 , f51k10 , f51k15 , f51k1h , f51k45 , & f52k03 , f52k06 , f52k09 , f52k15 , f52k45 , & f53k03 , f53k15 , f53k45 , f54k03 , f54k1h , & f61j06 , f61j10 , f61j15 , f61j21 , f62j03 , f62j06 , f62j10 , f62j15 , & f63j03 , f63j06 , f63j10 , f64j03 , f64j06 , f64j10 , & f65j03 , f65j15 , f66j21 , & r11 , r13 , r22 , s11 , s13 , s22 , s23 , s33 , s3t , s44 , u1s , u1t , u2s do i = i1 , i2 j = i + j0 k = i + k0 l = i + l0 f41l03 = qd4 ( 1 , l ) * 3 f41l15 = qd4 ( 1 , l ) * 15 f41l1h = f41l15 * 7 f42l03 = qd4 ( 2 , l ) * 3 f42l15 = qd4 ( 2 , l ) * 15 f42l1h = f42l15 * 7 f51k03 = qd5 ( 1 , k ) * 3 f51k06 = f51k03 + f51k03 f51k10 = qd5 ( 1 , k ) * 10 f51k15 = qd5 ( 1 , k ) * 15 f51k45 = f51k15 * 3 f51k1h = f51k15 * 7 f52k03 = qd5 ( 2 , k ) * 3 f52k06 = f52k03 + f52k03 f52k09 = f52k03 + f52k06 f52k15 = qd5 ( 2 , k ) * 15 f52k45 = f52k15 * 3 f53k03 = qd5 ( 3 , k ) * 3 f53k15 = qd5 ( 3 , k ) * 15 f53k45 = f53k15 * 3 f54k03 = qd5 ( 4 , k ) * 3 f54k1h = f54k03 * 5 * 7 f61j06 = qd6 ( 1 , j ) * 6 f61j10 = qd6 ( 1 , j ) * 10 f61j15 = qd6 ( 1 , j ) * 15 f61j21 = qd6 ( 1 , j ) * 21 f62j03 = qd6 ( 2 , j ) * 3 f62j06 = f62j03 + f62j03 f62j10 = qd6 ( 2 , j ) * 10 f62j15 = qd6 ( 2 , j ) * 15 f63j03 = qd6 ( 3 , j ) * 3 f63j06 = f63j03 + f63j03 f63j10 = qd6 ( 3 , j ) * 10 f64j03 = qd6 ( 4 , j ) * 3 f64j06 = f64j03 + f64j03 f64j10 = qd6 ( 4 , j ) * 10 f65j03 = qd6 ( 5 , j ) * 3 f65j15 = qd6 ( 5 , j ) * 15 f66j21 = qd6 ( 6 , j ) * 21 a11 = qd5 ( 1 , k ) * rdat % aqx2 - qd4 ( 1 , l ) a13 = qd5 ( 1 , k ) * rdat % aqx2 - f41l03 a22 = qd5 ( 2 , k ) * rdat % aqx2 - qd4 ( 2 , l ) r11 = f51k03 * rdat % acy2 - f41l03 r13 = qd5 ( 1 , k ) * rdat % acy2 - f41l03 r22 = f52k03 * rdat % acy2 - f42l03 b23 = f62j03 * rdat % aqx2 - f52k09 b33 = qd6 ( 3 , j ) * rdat % aqx2 - qd5 ( 3 , k ) b3t = qd6 ( 3 , j ) * rdat % aqx2 - f53k03 b44 = qd6 ( 4 , j ) * rdat % aqx2 - qd5 ( 4 , k ) s11 = qd6 ( 1 , j ) * rdat % acy2 - qd5 ( 1 , k ) s13 = qd6 ( 1 , j ) * rdat % acy2 - f51k03 s22 = f62j03 * rdat % acy2 - f52k03 s23 = f62j03 * rdat % acy2 - f52k09 s33 = f63j03 * rdat % acy2 - f53k03 s3t = qd6 ( 3 , j ) * rdat % acy2 - f53k03 s44 = qd6 ( 4 , j ) * rdat % acy2 - qd5 ( 4 , k ) d1s = ( qd6 ( 1 , j ) * rdat % aqx2 - f51k06 ) * rdat % aqx2 + f41l03 d1t = ( qd6 ( 1 , j ) * rdat % aqx2 - f51k10 ) * rdat % aqx2 + f41l15 d2s = ( qd6 ( 2 , j ) * rdat % aqx2 - f52k06 ) * rdat % aqx2 + f42l03 u1s = ( qd6 ( 1 , j ) * rdat % acy2 - f51k06 ) * rdat % acy2 + f41l03 u1t = ( qd6 ( 1 , j ) * rdat % acy2 - f51k10 ) * rdat % acy2 + f41l15 u2s = ( qd6 ( 2 , j ) * rdat % acy2 - f52k06 ) * rdat % acy2 + f42l03 wrk ( 1 , i ) = (( qd7 ( 1 , i ) * rdat % aqx2 - f61j21 ) * rdat % aqx2 + f51k1h ) * rdat % aqx2 - f41l1h wrk ( 2 , i ) = (( qd7 ( 1 , i ) * rdat % aqx2 - f61j15 ) * rdat % aqx2 + f51k45 ) * rdat % aqx2 - f41l15 wrk ( 3 , i ) = (( qd7 ( 2 , i ) * rdat % aqx2 - f62j15 ) * rdat % aqx2 + f52k45 ) * rdat % aqx2 - f42l15 wrk ( 4 , i ) = (( qd7 ( 1 , i ) * rdat % aqx2 - f61j10 ) * rdat % aqx2 + f51k15 ) * rdat % acy2 - d1t wrk ( 5 , i ) = ( qd7 ( 2 , i ) * rdat % aqx2 - f62j10 ) * rdat % aqx2 + f52k15 wrk ( 6 , i ) = ( qd7 ( 3 , i ) * rdat % aqx2 - f63j10 ) * rdat % aqx2 + f53k15 - d1t wrk ( 7 , i ) = (( qd7 ( 1 , i ) * rdat % aqx2 - f61j06 ) * rdat % aqx2 + f51k03 ) * rdat % acy2 - d1s * 3 wrk ( 8 , i ) = (( qd7 ( 2 , i ) * rdat % aqx2 - f62j06 ) * rdat % aqx2 + f52k03 ) * rdat % acy2 - d2s wrk ( 9 , i ) = ( qd7 ( 3 , i ) * rdat % aqx2 - f63j06 ) * rdat % aqx2 + f53k03 - d1s wrk ( 10 , i ) = ( qd7 ( 4 , i ) * rdat % aqx2 - f64j06 ) * rdat % aqx2 + f54k03 - d2s * 3 wrk ( 11 , i ) = (( qd7 ( 1 , i ) * rdat % acy2 - f61j06 ) * rdat % acy2 + f51k03 ) * rdat % aqx2 - u1s * 3 wrk ( 12 , i ) = ( qd7 ( 2 , i ) * rdat % acy2 - f62j03 ) * rdat % aqx2 - s23 wrk ( 13 , i ) = ( qd7 ( 3 , i ) * rdat % acy2 - qd6 ( 3 , j ) - s11 ) * rdat % aqx2 - s33 + r11 wrk ( 14 , i ) = qd7 ( 4 , i ) * rdat % aqx2 - f64j03 - b23 wrk ( 15 , i ) = qd7 ( 5 , i ) * rdat % aqx2 - f65j03 - b3t * 6 + a13 * 3 wrk ( 16 , i ) = (( qd7 ( 1 , i ) * rdat % acy2 - f61j10 ) * rdat % acy2 + f51k15 ) * rdat % aqx2 - u1t wrk ( 17 , i ) = (( qd7 ( 2 , i ) * rdat % acy2 - f62j06 ) * rdat % acy2 + f52k03 ) * rdat % aqx2 - u2s wrk ( 18 , i ) = ( qd7 ( 3 , i ) * rdat % acy2 - f63j03 - s13 ) * rdat % aqx2 - s3t + r13 wrk ( 19 , i ) = ( qd7 ( 4 , i ) * rdat % acy2 - qd6 ( 4 , j ) - s22 ) * rdat % aqx2 - s44 + r22 wrk ( 20 , i ) = qd7 ( 5 , i ) * rdat % aqx2 - qd6 ( 5 , j ) - b33 * 6 + a11 * 3 wrk ( 21 , i ) = qd7 ( 6 , i ) * rdat % aqx2 - qd6 ( 6 , j ) - b44 * 10 + a22 * 15 wrk ( 22 , i ) = (( qd7 ( 1 , i ) * rdat % acy2 - f61j15 ) * rdat % acy2 + f51k45 ) * rdat % acy2 - f41l15 wrk ( 23 , i ) = ( qd7 ( 2 , i ) * rdat % acy2 - f62j10 ) * rdat % acy2 + f52k15 wrk ( 24 , i ) = ( qd7 ( 3 , i ) * rdat % acy2 - f63j06 ) * rdat % acy2 + f53k03 - u1s wrk ( 25 , i ) = qd7 ( 4 , i ) * rdat % acy2 - f64j03 - s23 wrk ( 26 , i ) = qd7 ( 5 , i ) * rdat % acy2 - qd6 ( 5 , j ) - s33 - s33 + r11 wrk ( 27 , i ) = qd7 ( 6 , i ) - f64j10 + f52k15 wrk ( 28 , i ) = qd7 ( 7 , i ) - f65j15 + f53k45 - f41l15 wrk ( 29 , i ) = (( qd7 ( 1 , i ) * rdat % acy2 - f61j21 ) * rdat % acy2 + f51k1h ) * rdat % acy2 - f41l1h wrk ( 30 , i ) = (( qd7 ( 2 , i ) * rdat % acy2 - f62j15 ) * rdat % acy2 + f52k45 ) * rdat % acy2 - f42l15 wrk ( 31 , i ) = ( qd7 ( 3 , i ) * rdat % acy2 - f63j10 ) * rdat % acy2 + f53k15 - u1t wrk ( 32 , i ) = ( qd7 ( 4 , i ) * rdat % acy2 - f64j06 ) * rdat % acy2 + f54k03 - u2s * 3 wrk ( 33 , i ) = qd7 ( 5 , i ) * rdat % acy2 - f65j03 - s3t * 6 + r13 * 3 wrk ( 34 , i ) = qd7 ( 6 , i ) * rdat % acy2 - qd6 ( 6 , j ) - s44 * 10 + r22 * 5 wrk ( 35 , i ) = qd7 ( 7 , i ) - f65j15 + f53k45 - f41l15 wrk ( 36 , i ) = qd7 ( 8 , i ) - f66j21 + f54k1h - f42l1h enddo end subroutine frikr7 ! > ! >    @brief   auxiliary routine of order 8 for rot.axis integrations ! > ! >    @details auxiliary routine of order 8 for rot.axis integrations ! > subroutine frikr8 ( rdat , i1 , i2 , wrk , qd8 , j0 , qd7 , k0 , qd6 , l0 , qd5 , m0 , qd4 ) implicit none type ( rotaxis_data_t ) :: rdat integer :: i1 , i2 , j0 , k0 , l0 , m0 real ( kind = dp ) :: wrk ( 45 , * ), qd8 ( 9 , * ), qd7 ( 8 , * ), qd6 ( 7 , * ), qd5 ( 6 , * ), qd4 ( 5 , * ) integer :: i , j , k , l , m real ( kind = dp ) :: cy , qx real ( kind = dp ) :: a11 , b13 , b22 , b23 , b33 , c33 , c44 , c4t , c55 , & d11 , e16 , e1t , e26 , e2t , e36 , f41m03 , f41m15 , f41m1h , & f51l03 , f51l06 , f51l09 , f51l15 , f51l1h , f51l45 , f51l4h , & f52l03 , f52l15 , f52l1h , f53l03 , f53l15 , f53l4h , f61k03 , & f61k06 , f61k10 , f61k15 , f61k1h , f61k2h , f61k45 , f62k03 , & f62k06 , f62k09 , f62k10 , f62k15 , f62k1h , f62k45 , f63k03 , & f63k06 , f63k15 , f63k45 , f64k03 , f64k15 , f64k1h , f65k03 , & f65k2h , f71j06 , f71j10 , f71j15 , f71j21 , f71j28 , f72j03 , & f72j06 , f72j10 , f72j15 , f72j21 , f73j03 , f73j06 , f73j10 , & f73j15 , f74j03 , f74j06 , f74j10 , f75j03 , f75j06 , f75j15 , & f76j03 , f76j21 , f77j28 , g11 , r11 , s11 , s13 , s22 , s23 , & s33 , t13 , t22 , t23 , t33 , t3t , t43 , t44 , t4d , t55 , u11 , & v16 , v1t , v26 , v2t , v36 , w11 cy = rdat % acy2 qx = rdat % aqx2 do i = i1 , i2 j = i + j0 k = i + k0 l = i + l0 m = i + m0 f41m03 = qd4 ( 1 , m ) * 3 f41m15 = qd4 ( 1 , m ) * 15 f41m1h = f41m15 * 7 f51l03 = qd5 ( 1 , l ) * 3 f51l06 = f51l03 + f51l03 f51l09 = f51l03 + f51l06 f51l15 = qd5 ( 1 , l ) * 15 f51l45 = f51l15 * 3 f51l1h = f51l15 * 7 f51l4h = qd5 ( 1 , l ) * 420 f52l03 = qd5 ( 2 , l ) * 3 f52l15 = qd5 ( 2 , l ) * 15 f52l1h = f52l15 * 7 f53l03 = qd5 ( 3 , l ) * 3 f53l15 = qd5 ( 3 , l ) * 15 f53l4h = qd5 ( 3 , l ) * 420 f61k03 = qd6 ( 1 , k ) * 3 f61k06 = f61k03 + f61k03 f61k10 = qd6 ( 1 , k ) * 10 f61k15 = qd6 ( 1 , k ) * 15 f61k45 = f61k15 * 3 f61k1h = f61k15 * 7 f61k2h = qd6 ( 1 , k ) * 210 f62k03 = qd6 ( 2 , k ) * 3 f62k06 = f62k03 + f62k03 f62k09 = f62k03 + f62k06 f62k10 = qd6 ( 2 , k ) * 10 f62k15 = qd6 ( 2 , k ) * 15 f62k45 = f62k15 * 3 f62k1h = f62k15 * 7 f63k03 = qd6 ( 3 , k ) * 3 f63k06 = f63k03 + f63k03 f63k15 = qd6 ( 3 , k ) * 15 f63k45 = f63k15 * 3 f64k03 = qd6 ( 4 , k ) * 3 f64k15 = qd6 ( 4 , k ) * 15 f64k1h = f64k15 * 7 f65k03 = qd6 ( 5 , k ) * 3 f65k2h = qd6 ( 5 , k ) * 210 f71j06 = qd7 ( 1 , j ) * 6 f71j10 = qd7 ( 1 , j ) * 10 f71j15 = qd7 ( 1 , j ) * 15 f71j21 = qd7 ( 1 , j ) * 21 f71j28 = qd7 ( 1 , j ) * 28 f72j03 = qd7 ( 2 , j ) * 3 f72j06 = f72j03 + f72j03 f72j10 = qd7 ( 2 , j ) * 10 f72j15 = qd7 ( 2 , j ) * 15 f72j21 = qd7 ( 2 , j ) * 21 f73j03 = qd7 ( 3 , j ) * 3 f73j06 = f73j03 + f73j03 f73j10 = qd7 ( 3 , j ) * 10 f73j15 = qd7 ( 3 , j ) * 15 f74j03 = qd7 ( 4 , j ) * 3 f74j06 = f74j03 + f74j03 f74j10 = qd7 ( 4 , j ) * 10 f75j03 = qd7 ( 5 , j ) * 3 f75j06 = f75j03 + f75j03 f75j15 = qd7 ( 5 , j ) * 15 f76j03 = qd7 ( 6 , j ) * 3 f76j21 = qd7 ( 6 , j ) * 21 f77j28 = qd7 ( 7 , j ) * 28 a11 = qd5 ( 1 , l ) * qx - qd4 ( 1 , m ) r11 = qd5 ( 1 , l ) * cy - qd4 ( 1 , m ) b13 = f61k03 * qx - f51l09 b22 = f62k03 * qx - f52l03 b23 = f62k15 * qx - f52l15 * 3 b33 = f63k03 * qx - f53l03 s11 = f61k03 * cy - f51l03 s13 = f61k03 * cy - f51l09 s22 = f62k03 * cy - f52l03 s23 = f62k03 * cy - f52l03 * 3 s33 = f63k03 * cy - f53l03 c33 = f73j06 * qx - f63k03 * 6 c44 = qd7 ( 4 , j ) * qx - qd6 ( 4 , k ) c4t = f74j10 * qx - f64k03 * 10 c55 = qd7 ( 5 , j ) * qx - qd6 ( 5 , k ) t13 = qd7 ( 1 , j ) * cy - f61k03 t22 = f72j03 * cy - f62k03 t23 = f72j03 * cy - f62k09 t33 = qd7 ( 3 , j ) * cy - qd6 ( 3 , k ) t3t = qd7 ( 3 , j ) * cy - f63k03 t44 = qd7 ( 4 , j ) * cy - qd6 ( 4 , k ) t43 = qd7 ( 4 , j ) * cy - f64k03 t4d = f74j10 * cy - f64k03 * 10 t55 = qd7 ( 5 , j ) * cy - qd6 ( 5 , k ) d11 = ( qd6 ( 1 , k ) * qx - f51l06 ) * qx + f41m03 u11 = ( qd6 ( 1 , k ) * cy - f51l06 ) * cy + f41m03 e16 = ( qd7 ( 1 , j ) * qx - f61k06 ) * qx + f51l03 e1t = ( qd7 ( 1 , j ) * qx - f61k10 ) * qx + f51l15 e26 = (( qd7 ( 2 , j ) * qx - f62k06 ) * qx + f52l03 ) * 3 e2t = ( qd7 ( 2 , j ) * qx - f62k10 ) * qx + f52l15 e36 = ( qd7 ( 3 , j ) * qx - f63k06 ) * qx + f53l03 v16 = ( qd7 ( 1 , j ) * cy - f61k06 ) * cy + f51l03 v1t = ( qd7 ( 1 , j ) * cy - f61k10 ) * cy + f51l15 v26 = (( qd7 ( 2 , j ) * cy - f62k06 ) * cy + f52l03 ) * 3 v2t = ( qd7 ( 2 , j ) * cy - f62k10 ) * cy + f52l15 v36 = ( qd7 ( 3 , j ) * cy - f63k06 ) * cy + f53l03 g11 = (( qd7 ( 1 , j ) * qx - f61k15 ) * qx + f51l45 ) * qx - f41m15 w11 = (( qd7 ( 1 , j ) * cy - f61k15 ) * cy + f51l45 ) * cy - f41m15 wrk ( 1 , i ) = (( qd8 ( 1 , i ) * qx - f71j28 ) * qx + f61k2h ) * qx - f51l4h wrk ( 1 , i ) = wrk ( 1 , i ) * qx + f41m1h wrk ( 2 , i ) = (( qd8 ( 1 , i ) * qx - f71j21 ) * qx + f61k1h ) * qx - f51l1h wrk ( 3 , i ) = (( qd8 ( 2 , i ) * qx - f72j21 ) * qx + f62k1h ) * qx - f52l1h wrk ( 4 , i ) = (( qd8 ( 1 , i ) * qx - f71j15 ) * qx + f61k45 ) * qx - f51l15 wrk ( 4 , i ) = wrk ( 4 , i ) * cy - g11 wrk ( 5 , i ) = (( qd8 ( 2 , i ) * qx - f72j15 ) * qx + f62k45 ) * qx - f52l15 wrk ( 6 , i ) = (( qd8 ( 3 , i ) * qx - f73j15 ) * qx + f63k45 ) * qx - f53l15 - g11 wrk ( 7 , i ) = (( qd8 ( 1 , i ) * qx - f71j10 ) * qx + f61k15 ) * cy - e1t * 3 wrk ( 8 , i ) = (( qd8 ( 2 , i ) * qx - f72j10 ) * qx + f62k15 ) * cy - e2t wrk ( 9 , i ) = ( qd8 ( 3 , i ) * qx - f73j10 ) * qx + f63k15 - e1t wrk ( 10 , i ) = ( qd8 ( 4 , i ) * qx - f74j10 ) * qx + f64k15 - e2t * 3 wrk ( 11 , i ) = ( qd8 ( 1 , i ) * cy - f71j06 ) * cy + f61k03 wrk ( 11 , i ) = ( wrk ( 11 , i ) * qx - v16 * 6 ) * qx + u11 * 3 wrk ( 12 , i ) = (( qd8 ( 2 , i ) * qx - f72j06 ) * qx + f62k03 ) * cy - e26 wrk ( 13 , i ) = (( qd8 ( 3 , i ) * qx - f73j06 ) * qx + f63k03 - e16 ) * cy - e36 + d11 wrk ( 14 , i ) = ( qd8 ( 4 , i ) * qx - f74j06 ) * qx + f64k03 - e26 wrk ( 15 , i ) = ( qd8 ( 5 , i ) * qx - f75j06 ) * qx + f65k03 - e36 * 6 + d11 * 3 wrk ( 16 , i ) = (( qd8 ( 1 , i ) * cy - f71j10 ) * cy + f61k15 ) * qx - v1t * 3 wrk ( 17 , i ) = (( qd8 ( 2 , i ) * cy - f72j06 ) * cy + f62k03 ) * qx - v26 wrk ( 18 , i ) = ( qd8 ( 3 , i ) * cy - f73j03 - t13 ) * qx - t3t * 3 + s13 wrk ( 19 , i ) = ( qd8 ( 4 , i ) * cy - qd7 ( 4 , j ) - t22 ) * qx - t44 * 3 + s22 * 3 wrk ( 20 , i ) = qd8 ( 5 , i ) * qx - f75j03 - c33 + b13 wrk ( 21 , i ) = qd8 ( 6 , i ) * qx - f76j03 - c4t + b23 wrk ( 22 , i ) = (( qd8 ( 1 , i ) * cy - f71j15 ) * cy + f61k45 ) * cy - f51l15 wrk ( 22 , i ) = wrk ( 22 , i ) * qx - w11 wrk ( 23 , i ) = (( qd8 ( 2 , i ) * cy - f72j10 ) * cy + f62k15 ) * qx - v2t wrk ( 24 , i ) = (( qd8 ( 3 , i ) * cy - f73j06 ) * cy + f63k03 - v16 ) * qx - v36 + u11 wrk ( 25 , i ) = ( qd8 ( 4 , i ) * cy - f74j03 - t23 ) * qx - t43 + s23 wrk ( 26 , i ) = qd8 ( 5 , i ) * cy - qd7 ( 5 , j ) - t33 * 6 + s11 wrk ( 26 , i ) = wrk ( 26 , i ) * qx - ( t55 - s33 - s33 + r11 * 3 ) wrk ( 27 , i ) = qd8 ( 6 , i ) * qx - qd7 ( 6 , j ) - ( c44 * 10 - b22 * 5 ) wrk ( 28 , i ) = qd8 ( 7 , i ) * qx - qd7 ( 7 , j ) - ( c55 - b33 + a11 ) * 15 wrk ( 29 , i ) = (( qd8 ( 1 , i ) * cy - f71j21 ) * cy + f61k1h ) * cy - f51l1h wrk ( 30 , i ) = (( qd8 ( 2 , i ) * cy - f72j15 ) * cy + f62k45 ) * cy - f52l15 wrk ( 31 , i ) = ( qd8 ( 3 , i ) * cy - f73j10 ) * cy + f63k15 - v1t wrk ( 32 , i ) = ( qd8 ( 4 , i ) * cy - f74j06 ) * cy + f64k03 - v26 wrk ( 33 , i ) = qd8 ( 5 , i ) * cy - f75j03 - t3t * 6 + s13 wrk ( 34 , i ) = qd8 ( 6 , i ) * cy - qd7 ( 6 , j ) - t44 * 10 + s22 * 5 wrk ( 35 , i ) = qd8 ( 7 , i ) - f75j15 + f63k45 - f51l15 wrk ( 36 , i ) = qd8 ( 8 , i ) - f76j21 + f64k1h - f52l1h wrk ( 37 , i ) = (( qd8 ( 1 , i ) * cy - f71j28 ) * cy + f61k2h ) * cy - f51l4h wrk ( 37 , i ) = wrk ( 37 , i ) * cy + f41m1h wrk ( 38 , i ) = (( qd8 ( 2 , i ) * cy - f72j21 ) * cy + f62k1h ) * cy - f52l1h wrk ( 39 , i ) = (( qd8 ( 3 , i ) * cy - f73j15 ) * cy + f63k45 ) * cy - f53l15 - w11 wrk ( 40 , i ) = ( qd8 ( 4 , i ) * cy - f74j10 ) * cy + f64k15 - v2t * 3 wrk ( 41 , i ) = ( qd8 ( 5 , i ) * cy - f75j06 ) * cy + f65k03 - v36 * 6 + u11 * 3 wrk ( 42 , i ) = qd8 ( 6 , i ) * cy - f76j03 - t4d + s23 * 5 wrk ( 43 , i ) = qd8 ( 7 , i ) * cy - qd7 ( 7 , j ) - ( t55 - s33 + r11 ) * 15 wrk ( 44 , i ) = qd8 ( 8 , i ) - f76j21 + f64k1h - f52l1h wrk ( 45 , i ) = qd8 ( 9 , i ) - f77j28 + f65k2h - f53l4h + f41m1h enddo end subroutine frikr8 subroutine r30s1d_02 ( f , p ) implicit none real ( kind = dp ) :: f ( 3 , 1 , 1 , * ), p ( 3 , 3 ) real ( kind = dp ) :: t ( 6 ) t ( 1 : 3 ) = f ( 1 : 3 , 1 , 1 , 1 ) f ( 1 , 1 , 1 , 1 ) = t ( 1 ) * p ( 1 , 1 ) + t ( 2 ) * p ( 2 , 1 ) + t ( 3 ) * p ( 3 , 1 ) f ( 2 , 1 , 1 , 1 ) = t ( 1 ) * p ( 1 , 2 ) + t ( 2 ) * p ( 2 , 2 ) + t ( 3 ) * p ( 3 , 2 ) f ( 3 , 1 , 1 , 1 ) = t ( 1 ) * p ( 1 , 3 ) + t ( 2 ) * p ( 2 , 3 ) + t ( 3 ) * p ( 3 , 3 ) end subroutine r30s1d_02 subroutine r30s1d_03 ( f , p ) implicit none real ( kind = dp ) :: f ( 3 , 3 , 1 , * ), p ( 3 , 3 ) real ( kind = dp ) :: t ( 6 ) integer :: i , j , k , l do i = 1 , 3 t ( 1 ) = f ( i , 1 , 1 , 1 ) t ( 2 ) = f ( i , 2 , 1 , 1 ) t ( 3 ) = f ( i , 3 , 1 , 1 ) f ( i , 1 , 1 , 1 ) = t ( 1 ) * p ( 1 , 1 ) + t ( 2 ) * p ( 2 , 1 ) + t ( 3 ) * p ( 3 , 1 ) f ( i , 2 , 1 , 1 ) = t ( 1 ) * p ( 1 , 2 ) + t ( 2 ) * p ( 2 , 2 ) + t ( 3 ) * p ( 3 , 2 ) f ( i , 3 , 1 , 1 ) = t ( 1 ) * p ( 1 , 3 ) + t ( 2 ) * p ( 2 , 3 ) + t ( 3 ) * p ( 3 , 3 ) end do do j = 1 , 3 t ( 1 ) = f ( 1 , j , 1 , 1 ) t ( 2 ) = f ( 2 , j , 1 , 1 ) t ( 3 ) = f ( 3 , j , 1 , 1 ) f ( 1 , j , 1 , 1 ) = t ( 1 ) * p ( 1 , 1 ) + t ( 2 ) * p ( 2 , 1 ) + t ( 3 ) * p ( 3 , 1 ) f ( 2 , j , 1 , 1 ) = t ( 1 ) * p ( 1 , 2 ) + t ( 2 ) * p ( 2 , 2 ) + t ( 3 ) * p ( 3 , 2 ) f ( 3 , j , 1 , 1 ) = t ( 1 ) * p ( 1 , 3 ) + t ( 2 ) * p ( 2 , 3 ) + t ( 3 ) * p ( 3 , 3 ) end do end subroutine r30s1d_03 subroutine r30s1d_04 ( f , p ) implicit none real ( kind = dp ) :: f ( 3 , 1 , 3 , * ), p ( 3 , 3 ) real ( kind = dp ) :: t ( 6 ) integer :: i , j , k , l do i = 1 , 3 t ( 1 ) = f ( i , 1 , 1 , 1 ) t ( 2 ) = f ( i , 1 , 2 , 1 ) t ( 3 ) = f ( i , 1 , 3 , 1 ) f ( i , 1 , 1 , 1 ) = t ( 1 ) * p ( 1 , 1 ) + t ( 2 ) * p ( 2 , 1 ) + t ( 3 ) * p ( 3 , 1 ) f ( i , 1 , 2 , 1 ) = t ( 1 ) * p ( 1 , 2 ) + t ( 2 ) * p ( 2 , 2 ) + t ( 3 ) * p ( 3 , 2 ) f ( i , 1 , 3 , 1 ) = t ( 1 ) * p ( 1 , 3 ) + t ( 2 ) * p ( 2 , 3 ) + t ( 3 ) * p ( 3 , 3 ) end do do k = 1 , 3 t ( 1 ) = f ( 1 , 1 , k , 1 ) t ( 2 ) = f ( 2 , 1 , k , 1 ) t ( 3 ) = f ( 3 , 1 , k , 1 ) f ( 1 , 1 , k , 1 ) = t ( 1 ) * p ( 1 , 1 ) + t ( 2 ) * p ( 2 , 1 ) + t ( 3 ) * p ( 3 , 1 ) f ( 2 , 1 , k , 1 ) = t ( 1 ) * p ( 1 , 2 ) + t ( 2 ) * p ( 2 , 2 ) + t ( 3 ) * p ( 3 , 2 ) f ( 3 , 1 , k , 1 ) = t ( 1 ) * p ( 1 , 3 ) + t ( 2 ) * p ( 2 , 3 ) + t ( 3 ) * p ( 3 , 3 ) end do end subroutine r30s1d_04 subroutine r30s1d_05 ( f , p ) implicit none real ( kind = dp ) :: f ( 3 , 3 , 3 , * ), p ( 3 , 3 ) real ( kind = dp ) :: t ( 6 ) integer :: i , j , k , l do j = 1 , 3 do i = 1 , 3 t ( 1 ) = f ( i , j , 1 , 1 ) t ( 2 ) = f ( i , j , 2 , 1 ) t ( 3 ) = f ( i , j , 3 , 1 ) f ( i , j , 1 , 1 ) = t ( 1 ) * p ( 1 , 1 ) + t ( 2 ) * p ( 2 , 1 ) + t ( 3 ) * p ( 3 , 1 ) f ( i , j , 2 , 1 ) = t ( 1 ) * p ( 1 , 2 ) + t ( 2 ) * p ( 2 , 2 ) + t ( 3 ) * p ( 3 , 2 ) f ( i , j , 3 , 1 ) = t ( 1 ) * p ( 1 , 3 ) + t ( 2 ) * p ( 2 , 3 ) + t ( 3 ) * p ( 3 , 3 ) end do end do do k = 1 , 3 do i = 1 , 3 t ( 1 ) = f ( i , 1 , k , 1 ) t ( 2 ) = f ( i , 2 , k , 1 ) t ( 3 ) = f ( i , 3 , k , 1 ) f ( i , 1 , k , 1 ) = t ( 1 ) * p ( 1 , 1 ) + t ( 2 ) * p ( 2 , 1 ) + t ( 3 ) * p ( 3 , 1 ) f ( i , 2 , k , 1 ) = t ( 1 ) * p ( 1 , 2 ) + t ( 2 ) * p ( 2 , 2 ) + t ( 3 ) * p ( 3 , 2 ) f ( i , 3 , k , 1 ) = t ( 1 ) * p ( 1 , 3 ) + t ( 2 ) * p ( 2 , 3 ) + t ( 3 ) * p ( 3 , 3 ) end do end do do k = 1 , 3 do j = 1 , 3 t ( 1 ) = f ( 1 , j , k , 1 ) t ( 2 ) = f ( 2 , j , k , 1 ) t ( 3 ) = f ( 3 , j , k , 1 ) f ( 1 , j , k , 1 ) = t ( 1 ) * p ( 1 , 1 ) + t ( 2 ) * p ( 2 , 1 ) + t ( 3 ) * p ( 3 , 1 ) f ( 2 , j , k , 1 ) = t ( 1 ) * p ( 1 , 2 ) + t ( 2 ) * p ( 2 , 2 ) + t ( 3 ) * p ( 3 , 2 ) f ( 3 , j , k , 1 ) = t ( 1 ) * p ( 1 , 3 ) + t ( 2 ) * p ( 2 , 3 ) + t ( 3 ) * p ( 3 , 3 ) end do end do end subroutine r30s1d_05 subroutine r30s1d_06 ( f , p ) implicit none real ( kind = dp ) :: f ( 3 , 3 , 3 , * ), p ( 3 , 3 ) real ( kind = dp ) :: t ( 6 ) integer :: i , j , k , l do k = 1 , 3 do j = 1 , 3 do i = 1 , 3 t ( 1 ) = f ( i , j , k , 1 ) t ( 2 ) = f ( i , j , k , 2 ) t ( 3 ) = f ( i , j , k , 3 ) f ( i , j , k , 1 ) = t ( 1 ) * p ( 1 , 1 ) + t ( 2 ) * p ( 2 , 1 ) + t ( 3 ) * p ( 3 , 1 ) f ( i , j , k , 2 ) = t ( 1 ) * p ( 1 , 2 ) + t ( 2 ) * p ( 2 , 2 ) + t ( 3 ) * p ( 3 , 2 ) f ( i , j , k , 3 ) = t ( 1 ) * p ( 1 , 3 ) + t ( 2 ) * p ( 2 , 3 ) + t ( 3 ) * p ( 3 , 3 ) end do end do end do do l = 1 , 3 do j = 1 , 3 do i = 1 , 3 t ( 1 ) = f ( i , j , 1 , l ) t ( 2 ) = f ( i , j , 2 , l ) t ( 3 ) = f ( i , j , 3 , l ) f ( i , j , 1 , l ) = t ( 1 ) * p ( 1 , 1 ) + t ( 2 ) * p ( 2 , 1 ) + t ( 3 ) * p ( 3 , 1 ) f ( i , j , 2 , l ) = t ( 1 ) * p ( 1 , 2 ) + t ( 2 ) * p ( 2 , 2 ) + t ( 3 ) * p ( 3 , 2 ) f ( i , j , 3 , l ) = t ( 1 ) * p ( 1 , 3 ) + t ( 2 ) * p ( 2 , 3 ) + t ( 3 ) * p ( 3 , 3 ) end do end do end do do l = 1 , 3 do k = 1 , 3 do i = 1 , 3 t ( 1 ) = f ( i , 1 , k , l ) t ( 2 ) = f ( i , 2 , k , l ) t ( 3 ) = f ( i , 3 , k , l ) f ( i , 1 , k , l ) = t ( 1 ) * p ( 1 , 1 ) + t ( 2 ) * p ( 2 , 1 ) + t ( 3 ) * p ( 3 , 1 ) f ( i , 2 , k , l ) = t ( 1 ) * p ( 1 , 2 ) + t ( 2 ) * p ( 2 , 2 ) + t ( 3 ) * p ( 3 , 2 ) f ( i , 3 , k , l ) = t ( 1 ) * p ( 1 , 3 ) + t ( 2 ) * p ( 2 , 3 ) + t ( 3 ) * p ( 3 , 3 ) end do end do end do do l = 1 , 3 do k = 1 , 3 do j = 1 , 3 t ( 1 ) = f ( 1 , j , k , l ) t ( 2 ) = f ( 2 , j , k , l ) t ( 3 ) = f ( 3 , j , k , l ) f ( 1 , j , k , l ) = t ( 1 ) * p ( 1 , 1 ) + t ( 2 ) * p ( 2 , 1 ) + t ( 3 ) * p ( 3 , 1 ) f ( 2 , j , k , l ) = t ( 1 ) * p ( 1 , 2 ) + t ( 2 ) * p ( 2 , 2 ) + t ( 3 ) * p ( 3 , 2 ) f ( 3 , j , k , l ) = t ( 1 ) * p ( 1 , 3 ) + t ( 2 ) * p ( 2 , 3 ) + t ( 3 ) * p ( 3 , 3 ) end do end do end do end subroutine r30s1d_06 subroutine r30s1d_07 ( f , p ) implicit none real ( kind = dp ) :: f ( 6 , 1 , 1 , * ), p ( 3 , 3 ) real ( kind = dp ) :: t ( 6 ), q ( 6 , 6 ) integer :: i , j , k , l q ( 1 , 1 : 3 ) = p ( 1 , 1 : 3 ) * p ( 1 , 1 : 3 ) q ( 2 , 1 : 3 ) = p ( 2 , 1 : 3 ) * p ( 2 , 1 : 3 ) q ( 3 , 1 : 3 ) = p ( 3 , 1 : 3 ) * p ( 3 , 1 : 3 ) q ( 4 , 1 : 3 ) = p ( 1 , 1 : 3 ) * p ( 2 , 1 : 3 ) * 2.0_dp q ( 5 , 1 : 3 ) = p ( 1 , 1 : 3 ) * p ( 3 , 1 : 3 ) * 2.0_dp q ( 6 , 1 : 3 ) = p ( 2 , 1 : 3 ) * p ( 3 , 1 : 3 ) * 2.0_dp q ( 1 , 4 : 5 ) = sqrt3 * ( p ( 1 , 1 ) * p ( 1 , 2 : 3 ) ) q ( 2 , 4 : 5 ) = sqrt3 * ( p ( 2 , 1 ) * p ( 2 , 2 : 3 ) ) q ( 3 , 4 : 5 ) = sqrt3 * ( p ( 3 , 1 ) * p ( 3 , 2 : 3 ) ) q ( 4 , 4 : 5 ) = sqrt3 * ( p ( 1 , 1 ) * p ( 2 , 2 : 3 ) + p ( 2 , 1 ) * p ( 1 , 2 : 3 ) ) q ( 5 , 4 : 5 ) = sqrt3 * ( p ( 1 , 1 ) * p ( 3 , 2 : 3 ) + p ( 3 , 1 ) * p ( 1 , 2 : 3 ) ) q ( 6 , 4 : 5 ) = sqrt3 * ( p ( 2 , 1 ) * p ( 3 , 2 : 3 ) + p ( 3 , 1 ) * p ( 2 , 2 : 3 ) ) q ( 1 , 6 ) = sqrt3 * ( p ( 1 , 2 ) * p ( 1 , 3 )) q ( 2 , 6 ) = sqrt3 * ( p ( 2 , 2 ) * p ( 2 , 3 )) q ( 3 , 6 ) = sqrt3 * ( p ( 3 , 2 ) * p ( 3 , 3 )) q ( 4 , 6 ) = sqrt3 * ( p ( 1 , 2 ) * p ( 2 , 3 ) + p ( 2 , 2 ) * p ( 1 , 3 ) ) q ( 5 , 6 ) = sqrt3 * ( p ( 1 , 2 ) * p ( 3 , 3 ) + p ( 3 , 2 ) * p ( 1 , 3 ) ) q ( 6 , 6 ) = sqrt3 * ( p ( 2 , 2 ) * p ( 3 , 3 ) + p ( 3 , 2 ) * p ( 2 , 3 ) ) t ( 1 : 6 ) = f ( 1 : 6 , 1 , 1 , 1 ) do i = 1 , 6 f ( i , 1 , 1 , 1 ) = t ( 1 ) * q ( 1 , i ) + t ( 2 ) * q ( 2 , i ) + t ( 3 ) * q ( 3 , i ) & + t ( 4 ) * q ( 4 , i ) + t ( 5 ) * q ( 5 , i ) + t ( 6 ) * q ( 6 , i ) end do end subroutine r30s1d_07 subroutine r30s1d_08 ( f , p ) implicit none real ( kind = dp ) :: f ( 6 , 3 , 1 , * ), p ( 3 , 3 ) real ( kind = dp ) :: t ( 6 ), q ( 6 , 6 ) integer :: i , j , k , l q ( 1 , 1 : 3 ) = p ( 1 , 1 : 3 ) * p ( 1 , 1 : 3 ) q ( 2 , 1 : 3 ) = p ( 2 , 1 : 3 ) * p ( 2 , 1 : 3 ) q ( 3 , 1 : 3 ) = p ( 3 , 1 : 3 ) * p ( 3 , 1 : 3 ) q ( 4 , 1 : 3 ) = p ( 1 , 1 : 3 ) * p ( 2 , 1 : 3 ) * 2.0_dp q ( 5 , 1 : 3 ) = p ( 1 , 1 : 3 ) * p ( 3 , 1 : 3 ) * 2.0_dp q ( 6 , 1 : 3 ) = p ( 2 , 1 : 3 ) * p ( 3 , 1 : 3 ) * 2.0_dp q ( 1 , 4 : 5 ) = sqrt3 * ( p ( 1 , 1 ) * p ( 1 , 2 : 3 ) ) q ( 2 , 4 : 5 ) = sqrt3 * ( p ( 2 , 1 ) * p ( 2 , 2 : 3 ) ) q ( 3 , 4 : 5 ) = sqrt3 * ( p ( 3 , 1 ) * p ( 3 , 2 : 3 ) ) q ( 4 , 4 : 5 ) = sqrt3 * ( p ( 1 , 1 ) * p ( 2 , 2 : 3 ) + p ( 2 , 1 ) * p ( 1 , 2 : 3 ) ) q ( 5 , 4 : 5 ) = sqrt3 * ( p ( 1 , 1 ) * p ( 3 , 2 : 3 ) + p ( 3 , 1 ) * p ( 1 , 2 : 3 ) ) q ( 6 , 4 : 5 ) = sqrt3 * ( p ( 2 , 1 ) * p ( 3 , 2 : 3 ) + p ( 3 , 1 ) * p ( 2 , 2 : 3 ) ) q ( 1 , 6 ) = sqrt3 * ( p ( 1 , 2 ) * p ( 1 , 3 )) q ( 2 , 6 ) = sqrt3 * ( p ( 2 , 2 ) * p ( 2 , 3 )) q ( 3 , 6 ) = sqrt3 * ( p ( 3 , 2 ) * p ( 3 , 3 )) q ( 4 , 6 ) = sqrt3 * ( p ( 1 , 2 ) * p ( 2 , 3 ) + p ( 2 , 2 ) * p ( 1 , 3 ) ) q ( 5 , 6 ) = sqrt3 * ( p ( 1 , 2 ) * p ( 3 , 3 ) + p ( 3 , 2 ) * p ( 1 , 3 ) ) q ( 6 , 6 ) = sqrt3 * ( p ( 2 , 2 ) * p ( 3 , 3 ) + p ( 3 , 2 ) * p ( 2 , 3 ) ) do i = 1 , 6 t ( 1 ) = f ( i , 1 , 1 , 1 ) t ( 2 ) = f ( i , 2 , 1 , 1 ) t ( 3 ) = f ( i , 3 , 1 , 1 ) f ( i , 1 , 1 , 1 ) = t ( 1 ) * p ( 1 , 1 ) + t ( 2 ) * p ( 2 , 1 ) + t ( 3 ) * p ( 3 , 1 ) f ( i , 2 , 1 , 1 ) = t ( 1 ) * p ( 1 , 2 ) + t ( 2 ) * p ( 2 , 2 ) + t ( 3 ) * p ( 3 , 2 ) f ( i , 3 , 1 , 1 ) = t ( 1 ) * p ( 1 , 3 ) + t ( 2 ) * p ( 2 , 3 ) + t ( 3 ) * p ( 3 , 3 ) end do do j = 1 , 3 t ( 1 : 6 ) = f ( 1 : 6 , j , 1 , 1 ) do i = 1 , 6 f ( i , j , 1 , 1 ) = t ( 1 ) * q ( 1 , i ) + t ( 2 ) * q ( 2 , i ) + t ( 3 ) * q ( 3 , i ) & + t ( 4 ) * q ( 4 , i ) + t ( 5 ) * q ( 5 , i ) + t ( 6 ) * q ( 6 , i ) end do end do end subroutine r30s1d_08 subroutine r30s1d_09 ( f , p ) implicit none real ( kind = dp ) :: f ( 6 , 1 , 3 , * ), p ( 3 , 3 ) real ( kind = dp ) :: t ( 6 ), q ( 6 , 6 ) integer :: i , j , k , l q ( 1 , 1 : 3 ) = p ( 1 , 1 : 3 ) * p ( 1 , 1 : 3 ) q ( 2 , 1 : 3 ) = p ( 2 , 1 : 3 ) * p ( 2 , 1 : 3 ) q ( 3 , 1 : 3 ) = p ( 3 , 1 : 3 ) * p ( 3 , 1 : 3 ) q ( 4 , 1 : 3 ) = p ( 1 , 1 : 3 ) * p ( 2 , 1 : 3 ) * 2.0_dp q ( 5 , 1 : 3 ) = p ( 1 , 1 : 3 ) * p ( 3 , 1 : 3 ) * 2.0_dp q ( 6 , 1 : 3 ) = p ( 2 , 1 : 3 ) * p ( 3 , 1 : 3 ) * 2.0_dp q ( 1 , 4 : 5 ) = sqrt3 * ( p ( 1 , 1 ) * p ( 1 , 2 : 3 ) ) q ( 2 , 4 : 5 ) = sqrt3 * ( p ( 2 , 1 ) * p ( 2 , 2 : 3 ) ) q ( 3 , 4 : 5 ) = sqrt3 * ( p ( 3 , 1 ) * p ( 3 , 2 : 3 ) ) q ( 4 , 4 : 5 ) = sqrt3 * ( p ( 1 , 1 ) * p ( 2 , 2 : 3 ) + p ( 2 , 1 ) * p ( 1 , 2 : 3 ) ) q ( 5 , 4 : 5 ) = sqrt3 * ( p ( 1 , 1 ) * p ( 3 , 2 : 3 ) + p ( 3 , 1 ) * p ( 1 , 2 : 3 ) ) q ( 6 , 4 : 5 ) = sqrt3 * ( p ( 2 , 1 ) * p ( 3 , 2 : 3 ) + p ( 3 , 1 ) * p ( 2 , 2 : 3 ) ) q ( 1 , 6 ) = sqrt3 * ( p ( 1 , 2 ) * p ( 1 , 3 )) q ( 2 , 6 ) = sqrt3 * ( p ( 2 , 2 ) * p ( 2 , 3 )) q ( 3 , 6 ) = sqrt3 * ( p ( 3 , 2 ) * p ( 3 , 3 )) q ( 4 , 6 ) = sqrt3 * ( p ( 1 , 2 ) * p ( 2 , 3 ) + p ( 2 , 2 ) * p ( 1 , 3 ) ) q ( 5 , 6 ) = sqrt3 * ( p ( 1 , 2 ) * p ( 3 , 3 ) + p ( 3 , 2 ) * p ( 1 , 3 ) ) q ( 6 , 6 ) = sqrt3 * ( p ( 2 , 2 ) * p ( 3 , 3 ) + p ( 3 , 2 ) * p ( 2 , 3 ) ) do i = 1 , 6 t ( 1 ) = f ( i , 1 , 1 , 1 ) t ( 2 ) = f ( i , 1 , 2 , 1 ) t ( 3 ) = f ( i , 1 , 3 , 1 ) f ( i , 1 , 1 , 1 ) = t ( 1 ) * p ( 1 , 1 ) + t ( 2 ) * p ( 2 , 1 ) + t ( 3 ) * p ( 3 , 1 ) f ( i , 1 , 2 , 1 ) = t ( 1 ) * p ( 1 , 2 ) + t ( 2 ) * p ( 2 , 2 ) + t ( 3 ) * p ( 3 , 2 ) f ( i , 1 , 3 , 1 ) = t ( 1 ) * p ( 1 , 3 ) + t ( 2 ) * p ( 2 , 3 ) + t ( 3 ) * p ( 3 , 3 ) end do do j = 1 , 3 t ( 1 : 6 ) = f ( 1 : 6 , 1 , j , 1 ) do i = 1 , 6 f ( i , 1 , j , 1 ) = t ( 1 ) * q ( 1 , i ) + t ( 2 ) * q ( 2 , i ) + t ( 3 ) * q ( 3 , i ) & + t ( 4 ) * q ( 4 , i ) + t ( 5 ) * q ( 5 , i ) + t ( 6 ) * q ( 6 , i ) end do end do end subroutine r30s1d_09 subroutine r30s1d_10 ( f , p ) implicit none real ( kind = dp ) :: f ( 6 , 6 , 1 , * ), p ( 3 , 3 ) real ( kind = dp ) :: t ( 6 ), q ( 6 , 6 ) integer :: i , j , k , l q ( 1 , 1 : 3 ) = p ( 1 , 1 : 3 ) * p ( 1 , 1 : 3 ) q ( 2 , 1 : 3 ) = p ( 2 , 1 : 3 ) * p ( 2 , 1 : 3 ) q ( 3 , 1 : 3 ) = p ( 3 , 1 : 3 ) * p ( 3 , 1 : 3 ) q ( 4 , 1 : 3 ) = p ( 1 , 1 : 3 ) * p ( 2 , 1 : 3 ) * 2.0_dp q ( 5 , 1 : 3 ) = p ( 1 , 1 : 3 ) * p ( 3 , 1 : 3 ) * 2.0_dp q ( 6 , 1 : 3 ) = p ( 2 , 1 : 3 ) * p ( 3 , 1 : 3 ) * 2.0_dp q ( 1 , 4 : 5 ) = sqrt3 * ( p ( 1 , 1 ) * p ( 1 , 2 : 3 ) ) q ( 2 , 4 : 5 ) = sqrt3 * ( p ( 2 , 1 ) * p ( 2 , 2 : 3 ) ) q ( 3 , 4 : 5 ) = sqrt3 * ( p ( 3 , 1 ) * p ( 3 , 2 : 3 ) ) q ( 4 , 4 : 5 ) = sqrt3 * ( p ( 1 , 1 ) * p ( 2 , 2 : 3 ) + p ( 2 , 1 ) * p ( 1 , 2 : 3 ) ) q ( 5 , 4 : 5 ) = sqrt3 * ( p ( 1 , 1 ) * p ( 3 , 2 : 3 ) + p ( 3 , 1 ) * p ( 1 , 2 : 3 ) ) q ( 6 , 4 : 5 ) = sqrt3 * ( p ( 2 , 1 ) * p ( 3 , 2 : 3 ) + p ( 3 , 1 ) * p ( 2 , 2 : 3 ) ) q ( 1 , 6 ) = sqrt3 * ( p ( 1 , 2 ) * p ( 1 , 3 )) q ( 2 , 6 ) = sqrt3 * ( p ( 2 , 2 ) * p ( 2 , 3 )) q ( 3 , 6 ) = sqrt3 * ( p ( 3 , 2 ) * p ( 3 , 3 )) q ( 4 , 6 ) = sqrt3 * ( p ( 1 , 2 ) * p ( 2 , 3 ) + p ( 2 , 2 ) * p ( 1 , 3 ) ) q ( 5 , 6 ) = sqrt3 * ( p ( 1 , 2 ) * p ( 3 , 3 ) + p ( 3 , 2 ) * p ( 1 , 3 ) ) q ( 6 , 6 ) = sqrt3 * ( p ( 2 , 2 ) * p ( 3 , 3 ) + p ( 3 , 2 ) * p ( 2 , 3 ) ) do i = 1 , 6 t ( 1 : 6 ) = f ( i , 1 : 6 , 1 , 1 ) do j = 1 , 6 f ( i , j , 1 , 1 ) = t ( 1 ) * q ( 1 , j ) + t ( 2 ) * q ( 2 , j ) + t ( 3 ) * q ( 3 , j ) & + t ( 4 ) * q ( 4 , j ) + t ( 5 ) * q ( 5 , j ) + t ( 6 ) * q ( 6 , j ) end do end do do j = 1 , 6 t ( 1 : 6 ) = f ( 1 : 6 , j , 1 , 1 ) do i = 1 , 6 f ( i , j , 1 , 1 ) = t ( 1 ) * q ( 1 , i ) + t ( 2 ) * q ( 2 , i ) + t ( 3 ) * q ( 3 , i ) & + t ( 4 ) * q ( 4 , i ) + t ( 5 ) * q ( 5 , i ) + t ( 6 ) * q ( 6 , i ) end do end do end subroutine r30s1d_10 subroutine r30s1d_11 ( f , p ) implicit none real ( kind = dp ) :: f ( 6 , 3 , 3 , * ), p ( 3 , 3 ) real ( kind = dp ) :: t ( 6 ), q ( 6 , 6 ) integer :: i , j , k , l q ( 1 , 1 : 3 ) = p ( 1 , 1 : 3 ) * p ( 1 , 1 : 3 ) q ( 2 , 1 : 3 ) = p ( 2 , 1 : 3 ) * p ( 2 , 1 : 3 ) q ( 3 , 1 : 3 ) = p ( 3 , 1 : 3 ) * p ( 3 , 1 : 3 ) q ( 4 , 1 : 3 ) = p ( 1 , 1 : 3 ) * p ( 2 , 1 : 3 ) * 2.0_dp q ( 5 , 1 : 3 ) = p ( 1 , 1 : 3 ) * p ( 3 , 1 : 3 ) * 2.0_dp q ( 6 , 1 : 3 ) = p ( 2 , 1 : 3 ) * p ( 3 , 1 : 3 ) * 2.0_dp q ( 1 , 4 : 5 ) = sqrt3 * ( p ( 1 , 1 ) * p ( 1 , 2 : 3 ) ) q ( 2 , 4 : 5 ) = sqrt3 * ( p ( 2 , 1 ) * p ( 2 , 2 : 3 ) ) q ( 3 , 4 : 5 ) = sqrt3 * ( p ( 3 , 1 ) * p ( 3 , 2 : 3 ) ) q ( 4 , 4 : 5 ) = sqrt3 * ( p ( 1 , 1 ) * p ( 2 , 2 : 3 ) + p ( 2 , 1 ) * p ( 1 , 2 : 3 ) ) q ( 5 , 4 : 5 ) = sqrt3 * ( p ( 1 , 1 ) * p ( 3 , 2 : 3 ) + p ( 3 , 1 ) * p ( 1 , 2 : 3 ) ) q ( 6 , 4 : 5 ) = sqrt3 * ( p ( 2 , 1 ) * p ( 3 , 2 : 3 ) + p ( 3 , 1 ) * p ( 2 , 2 : 3 ) ) q ( 1 , 6 ) = sqrt3 * ( p ( 1 , 2 ) * p ( 1 , 3 )) q ( 2 , 6 ) = sqrt3 * ( p ( 2 , 2 ) * p ( 2 , 3 )) q ( 3 , 6 ) = sqrt3 * ( p ( 3 , 2 ) * p ( 3 , 3 )) q ( 4 , 6 ) = sqrt3 * ( p ( 1 , 2 ) * p ( 2 , 3 ) + p ( 2 , 2 ) * p ( 1 , 3 ) ) q ( 5 , 6 ) = sqrt3 * ( p ( 1 , 2 ) * p ( 3 , 3 ) + p ( 3 , 2 ) * p ( 1 , 3 ) ) q ( 6 , 6 ) = sqrt3 * ( p ( 2 , 2 ) * p ( 3 , 3 ) + p ( 3 , 2 ) * p ( 2 , 3 ) ) do j = 1 , 3 do i = 1 , 6 t ( 1 ) = f ( i , j , 1 , 1 ) t ( 2 ) = f ( i , j , 2 , 1 ) t ( 3 ) = f ( i , j , 3 , 1 ) f ( i , j , 1 , 1 ) = t ( 1 ) * p ( 1 , 1 ) + t ( 2 ) * p ( 2 , 1 ) + t ( 3 ) * p ( 3 , 1 ) f ( i , j , 2 , 1 ) = t ( 1 ) * p ( 1 , 2 ) + t ( 2 ) * p ( 2 , 2 ) + t ( 3 ) * p ( 3 , 2 ) f ( i , j , 3 , 1 ) = t ( 1 ) * p ( 1 , 3 ) + t ( 2 ) * p ( 2 , 3 ) + t ( 3 ) * p ( 3 , 3 ) end do end do do k = 1 , 3 do i = 1 , 6 t ( 1 ) = f ( i , 1 , k , 1 ) t ( 2 ) = f ( i , 2 , k , 1 ) t ( 3 ) = f ( i , 3 , k , 1 ) f ( i , 1 , k , 1 ) = t ( 1 ) * p ( 1 , 1 ) + t ( 2 ) * p ( 2 , 1 ) + t ( 3 ) * p ( 3 , 1 ) f ( i , 2 , k , 1 ) = t ( 1 ) * p ( 1 , 2 ) + t ( 2 ) * p ( 2 , 2 ) + t ( 3 ) * p ( 3 , 2 ) f ( i , 3 , k , 1 ) = t ( 1 ) * p ( 1 , 3 ) + t ( 2 ) * p ( 2 , 3 ) + t ( 3 ) * p ( 3 , 3 ) end do end do do k = 1 , 3 do j = 1 , 3 do i = 1 , 6 t ( i ) = f ( i , j , k , 1 ) end do do i = 1 , 6 f ( i , j , k , 1 ) = t ( 1 ) * q ( 1 , i ) + t ( 2 ) * q ( 2 , i ) + t ( 3 ) * q ( 3 , i ) & + t ( 4 ) * q ( 4 , i ) + t ( 5 ) * q ( 5 , i ) + t ( 6 ) * q ( 6 , i ) end do end do end do end subroutine r30s1d_11 subroutine r30s1d_12 ( f , p ) implicit none real ( kind = dp ) :: f ( 6 , 1 , 6 , * ), p ( 3 , 3 ) real ( kind = dp ) :: t ( 6 ), q ( 6 , 6 ) integer :: i , j , k , l q ( 1 , 1 : 3 ) = p ( 1 , 1 : 3 ) * p ( 1 , 1 : 3 ) q ( 2 , 1 : 3 ) = p ( 2 , 1 : 3 ) * p ( 2 , 1 : 3 ) q ( 3 , 1 : 3 ) = p ( 3 , 1 : 3 ) * p ( 3 , 1 : 3 ) q ( 4 , 1 : 3 ) = p ( 1 , 1 : 3 ) * p ( 2 , 1 : 3 ) * 2.0_dp q ( 5 , 1 : 3 ) = p ( 1 , 1 : 3 ) * p ( 3 , 1 : 3 ) * 2.0_dp q ( 6 , 1 : 3 ) = p ( 2 , 1 : 3 ) * p ( 3 , 1 : 3 ) * 2.0_dp q ( 1 , 4 : 5 ) = sqrt3 * ( p ( 1 , 1 ) * p ( 1 , 2 : 3 ) ) q ( 2 , 4 : 5 ) = sqrt3 * ( p ( 2 , 1 ) * p ( 2 , 2 : 3 ) ) q ( 3 , 4 : 5 ) = sqrt3 * ( p ( 3 , 1 ) * p ( 3 , 2 : 3 ) ) q ( 4 , 4 : 5 ) = sqrt3 * ( p ( 1 , 1 ) * p ( 2 , 2 : 3 ) + p ( 2 , 1 ) * p ( 1 , 2 : 3 ) ) q ( 5 , 4 : 5 ) = sqrt3 * ( p ( 1 , 1 ) * p ( 3 , 2 : 3 ) + p ( 3 , 1 ) * p ( 1 , 2 : 3 ) ) q ( 6 , 4 : 5 ) = sqrt3 * ( p ( 2 , 1 ) * p ( 3 , 2 : 3 ) + p ( 3 , 1 ) * p ( 2 , 2 : 3 ) ) q ( 1 , 6 ) = sqrt3 * ( p ( 1 , 2 ) * p ( 1 , 3 )) q ( 2 , 6 ) = sqrt3 * ( p ( 2 , 2 ) * p ( 2 , 3 )) q ( 3 , 6 ) = sqrt3 * ( p ( 3 , 2 ) * p ( 3 , 3 )) q ( 4 , 6 ) = sqrt3 * ( p ( 1 , 2 ) * p ( 2 , 3 ) + p ( 2 , 2 ) * p ( 1 , 3 ) ) q ( 5 , 6 ) = sqrt3 * ( p ( 1 , 2 ) * p ( 3 , 3 ) + p ( 3 , 2 ) * p ( 1 , 3 ) ) q ( 6 , 6 ) = sqrt3 * ( p ( 2 , 2 ) * p ( 3 , 3 ) + p ( 3 , 2 ) * p ( 2 , 3 ) ) do i = 1 , 6 do k = 1 , 6 t ( k ) = f ( i , 1 , k , 1 ) end do do k = 1 , 6 f ( i , 1 , k , 1 ) = t ( 1 ) * q ( 1 , k ) + t ( 2 ) * q ( 2 , k ) + t ( 3 ) * q ( 3 , k ) & + t ( 4 ) * q ( 4 , k ) + t ( 5 ) * q ( 5 , k ) + t ( 6 ) * q ( 6 , k ) end do end do do k = 1 , 6 do i = 1 , 6 t ( i ) = f ( i , 1 , k , 1 ) end do do i = 1 , 6 f ( i , 1 , k , 1 ) = t ( 1 ) * q ( 1 , i ) + t ( 2 ) * q ( 2 , i ) + t ( 3 ) * q ( 3 , i ) & + t ( 4 ) * q ( 4 , i ) + t ( 5 ) * q ( 5 , i ) + t ( 6 ) * q ( 6 , i ) end do end do end subroutine r30s1d_12 subroutine r30s1d_13 ( f , p ) implicit none real ( kind = dp ) :: f ( 6 , 1 , 3 , * ), p ( 3 , 3 ) real ( kind = dp ) :: t ( 6 ), q ( 6 , 6 ) integer :: i , j , k , l q ( 1 , 1 : 3 ) = p ( 1 , 1 : 3 ) * p ( 1 , 1 : 3 ) q ( 2 , 1 : 3 ) = p ( 2 , 1 : 3 ) * p ( 2 , 1 : 3 ) q ( 3 , 1 : 3 ) = p ( 3 , 1 : 3 ) * p ( 3 , 1 : 3 ) q ( 4 , 1 : 3 ) = p ( 1 , 1 : 3 ) * p ( 2 , 1 : 3 ) * 2.0_dp q ( 5 , 1 : 3 ) = p ( 1 , 1 : 3 ) * p ( 3 , 1 : 3 ) * 2.0_dp q ( 6 , 1 : 3 ) = p ( 2 , 1 : 3 ) * p ( 3 , 1 : 3 ) * 2.0_dp q ( 1 , 4 : 5 ) = sqrt3 * ( p ( 1 , 1 ) * p ( 1 , 2 : 3 ) ) q ( 2 , 4 : 5 ) = sqrt3 * ( p ( 2 , 1 ) * p ( 2 , 2 : 3 ) ) q ( 3 , 4 : 5 ) = sqrt3 * ( p ( 3 , 1 ) * p ( 3 , 2 : 3 ) ) q ( 4 , 4 : 5 ) = sqrt3 * ( p ( 1 , 1 ) * p ( 2 , 2 : 3 ) + p ( 2 , 1 ) * p ( 1 , 2 : 3 ) ) q ( 5 , 4 : 5 ) = sqrt3 * ( p ( 1 , 1 ) * p ( 3 , 2 : 3 ) + p ( 3 , 1 ) * p ( 1 , 2 : 3 ) ) q ( 6 , 4 : 5 ) = sqrt3 * ( p ( 2 , 1 ) * p ( 3 , 2 : 3 ) + p ( 3 , 1 ) * p ( 2 , 2 : 3 ) ) q ( 1 , 6 ) = sqrt3 * ( p ( 1 , 2 ) * p ( 1 , 3 )) q ( 2 , 6 ) = sqrt3 * ( p ( 2 , 2 ) * p ( 2 , 3 )) q ( 3 , 6 ) = sqrt3 * ( p ( 3 , 2 ) * p ( 3 , 3 )) q ( 4 , 6 ) = sqrt3 * ( p ( 1 , 2 ) * p ( 2 , 3 ) + p ( 2 , 2 ) * p ( 1 , 3 ) ) q ( 5 , 6 ) = sqrt3 * ( p ( 1 , 2 ) * p ( 3 , 3 ) + p ( 3 , 2 ) * p ( 1 , 3 ) ) q ( 6 , 6 ) = sqrt3 * ( p ( 2 , 2 ) * p ( 3 , 3 ) + p ( 3 , 2 ) * p ( 2 , 3 ) ) do k = 1 , 3 do i = 1 , 6 t ( 1 ) = f ( i , 1 , k , 1 ) t ( 2 ) = f ( i , 1 , k , 2 ) t ( 3 ) = f ( i , 1 , k , 3 ) f ( i , 1 , k , 1 ) = t ( 1 ) * p ( 1 , 1 ) + t ( 2 ) * p ( 2 , 1 ) + t ( 3 ) * p ( 3 , 1 ) f ( i , 1 , k , 2 ) = t ( 1 ) * p ( 1 , 2 ) + t ( 2 ) * p ( 2 , 2 ) + t ( 3 ) * p ( 3 , 2 ) f ( i , 1 , k , 3 ) = t ( 1 ) * p ( 1 , 3 ) + t ( 2 ) * p ( 2 , 3 ) + t ( 3 ) * p ( 3 , 3 ) end do end do do l = 1 , 3 do i = 1 , 6 t ( 1 ) = f ( i , 1 , 1 , l ) t ( 2 ) = f ( i , 1 , 2 , l ) t ( 3 ) = f ( i , 1 , 3 , l ) f ( i , 1 , 1 , l ) = t ( 1 ) * p ( 1 , 1 ) + t ( 2 ) * p ( 2 , 1 ) + t ( 3 ) * p ( 3 , 1 ) f ( i , 1 , 2 , l ) = t ( 1 ) * p ( 1 , 2 ) + t ( 2 ) * p ( 2 , 2 ) + t ( 3 ) * p ( 3 , 2 ) f ( i , 1 , 3 , l ) = t ( 1 ) * p ( 1 , 3 ) + t ( 2 ) * p ( 2 , 3 ) + t ( 3 ) * p ( 3 , 3 ) end do end do do l = 1 , 3 do k = 1 , 3 do i = 1 , 6 t ( i ) = f ( i , 1 , k , l ) end do do i = 1 , 6 f ( i , 1 , k , l ) = t ( 1 ) * q ( 1 , i ) + t ( 2 ) * q ( 2 , i ) + t ( 3 ) * q ( 3 , i ) & + t ( 4 ) * q ( 4 , i ) + t ( 5 ) * q ( 5 , i ) + t ( 6 ) * q ( 6 , i ) end do end do end do end subroutine r30s1d_13 subroutine r30s1d_14 ( f , p ) implicit none real ( kind = dp ) :: f ( 6 , 6 , 3 , * ), p ( 3 , 3 ) real ( kind = dp ) :: t ( 6 ), q ( 6 , 6 ) integer :: i , j , k , l q ( 1 , 1 : 3 ) = p ( 1 , 1 : 3 ) * p ( 1 , 1 : 3 ) q ( 2 , 1 : 3 ) = p ( 2 , 1 : 3 ) * p ( 2 , 1 : 3 ) q ( 3 , 1 : 3 ) = p ( 3 , 1 : 3 ) * p ( 3 , 1 : 3 ) q ( 4 , 1 : 3 ) = p ( 1 , 1 : 3 ) * p ( 2 , 1 : 3 ) * 2.0_dp q ( 5 , 1 : 3 ) = p ( 1 , 1 : 3 ) * p ( 3 , 1 : 3 ) * 2.0_dp q ( 6 , 1 : 3 ) = p ( 2 , 1 : 3 ) * p ( 3 , 1 : 3 ) * 2.0_dp q ( 1 , 4 : 5 ) = sqrt3 * ( p ( 1 , 1 ) * p ( 1 , 2 : 3 ) ) q ( 2 , 4 : 5 ) = sqrt3 * ( p ( 2 , 1 ) * p ( 2 , 2 : 3 ) ) q ( 3 , 4 : 5 ) = sqrt3 * ( p ( 3 , 1 ) * p ( 3 , 2 : 3 ) ) q ( 4 , 4 : 5 ) = sqrt3 * ( p ( 1 , 1 ) * p ( 2 , 2 : 3 ) + p ( 2 , 1 ) * p ( 1 , 2 : 3 ) ) q ( 5 , 4 : 5 ) = sqrt3 * ( p ( 1 , 1 ) * p ( 3 , 2 : 3 ) + p ( 3 , 1 ) * p ( 1 , 2 : 3 ) ) q ( 6 , 4 : 5 ) = sqrt3 * ( p ( 2 , 1 ) * p ( 3 , 2 : 3 ) + p ( 3 , 1 ) * p ( 2 , 2 : 3 ) ) q ( 1 , 6 ) = sqrt3 * ( p ( 1 , 2 ) * p ( 1 , 3 )) q ( 2 , 6 ) = sqrt3 * ( p ( 2 , 2 ) * p ( 2 , 3 )) q ( 3 , 6 ) = sqrt3 * ( p ( 3 , 2 ) * p ( 3 , 3 )) q ( 4 , 6 ) = sqrt3 * ( p ( 1 , 2 ) * p ( 2 , 3 ) + p ( 2 , 2 ) * p ( 1 , 3 ) ) q ( 5 , 6 ) = sqrt3 * ( p ( 1 , 2 ) * p ( 3 , 3 ) + p ( 3 , 2 ) * p ( 1 , 3 ) ) q ( 6 , 6 ) = sqrt3 * ( p ( 2 , 2 ) * p ( 3 , 3 ) + p ( 3 , 2 ) * p ( 2 , 3 ) ) do j = 1 , 6 do i = 1 , 6 t ( 1 ) = f ( i , j , 1 , 1 ) t ( 2 ) = f ( i , j , 2 , 1 ) t ( 3 ) = f ( i , j , 3 , 1 ) f ( i , j , 1 , 1 ) = t ( 1 ) * p ( 1 , 1 ) + t ( 2 ) * p ( 2 , 1 ) + t ( 3 ) * p ( 3 , 1 ) f ( i , j , 2 , 1 ) = t ( 1 ) * p ( 1 , 2 ) + t ( 2 ) * p ( 2 , 2 ) + t ( 3 ) * p ( 3 , 2 ) f ( i , j , 3 , 1 ) = t ( 1 ) * p ( 1 , 3 ) + t ( 2 ) * p ( 2 , 3 ) + t ( 3 ) * p ( 3 , 3 ) end do end do do k = 1 , 3 do i = 1 , 6 do j = 1 , 6 t ( j ) = f ( i , j , k , 1 ) end do do j = 1 , 6 f ( i , j , k , 1 ) = t ( 1 ) * q ( 1 , j ) + t ( 2 ) * q ( 2 , j ) + t ( 3 ) * q ( 3 , j ) & + t ( 4 ) * q ( 4 , j ) + t ( 5 ) * q ( 5 , j ) + t ( 6 ) * q ( 6 , j ) end do end do end do do k = 1 , 3 do j = 1 , 6 do i = 1 , 6 t ( i ) = f ( i , j , k , 1 ) end do do i = 1 , 6 f ( i , j , k , 1 ) = t ( 1 ) * q ( 1 , i ) + t ( 2 ) * q ( 2 , i ) + t ( 3 ) * q ( 3 , i ) & + t ( 4 ) * q ( 4 , i ) + t ( 5 ) * q ( 5 , i ) + t ( 6 ) * q ( 6 , i ) end do end do end do end subroutine r30s1d_14 subroutine r30s1d_15 ( f , p ) implicit none real ( kind = dp ) :: f ( 6 , 3 , 6 , * ), p ( 3 , 3 ) real ( kind = dp ) :: t ( 6 ), q ( 6 , 6 ) integer :: i , j , k , l q ( 1 , 1 : 3 ) = p ( 1 , 1 : 3 ) * p ( 1 , 1 : 3 ) q ( 2 , 1 : 3 ) = p ( 2 , 1 : 3 ) * p ( 2 , 1 : 3 ) q ( 3 , 1 : 3 ) = p ( 3 , 1 : 3 ) * p ( 3 , 1 : 3 ) q ( 4 , 1 : 3 ) = p ( 1 , 1 : 3 ) * p ( 2 , 1 : 3 ) * 2.0_dp q ( 5 , 1 : 3 ) = p ( 1 , 1 : 3 ) * p ( 3 , 1 : 3 ) * 2.0_dp q ( 6 , 1 : 3 ) = p ( 2 , 1 : 3 ) * p ( 3 , 1 : 3 ) * 2.0_dp q ( 1 , 4 : 5 ) = sqrt3 * ( p ( 1 , 1 ) * p ( 1 , 2 : 3 ) ) q ( 2 , 4 : 5 ) = sqrt3 * ( p ( 2 , 1 ) * p ( 2 , 2 : 3 ) ) q ( 3 , 4 : 5 ) = sqrt3 * ( p ( 3 , 1 ) * p ( 3 , 2 : 3 ) ) q ( 4 , 4 : 5 ) = sqrt3 * ( p ( 1 , 1 ) * p ( 2 , 2 : 3 ) + p ( 2 , 1 ) * p ( 1 , 2 : 3 ) ) q ( 5 , 4 : 5 ) = sqrt3 * ( p ( 1 , 1 ) * p ( 3 , 2 : 3 ) + p ( 3 , 1 ) * p ( 1 , 2 : 3 ) ) q ( 6 , 4 : 5 ) = sqrt3 * ( p ( 2 , 1 ) * p ( 3 , 2 : 3 ) + p ( 3 , 1 ) * p ( 2 , 2 : 3 ) ) q ( 1 , 6 ) = sqrt3 * ( p ( 1 , 2 ) * p ( 1 , 3 )) q ( 2 , 6 ) = sqrt3 * ( p ( 2 , 2 ) * p ( 2 , 3 )) q ( 3 , 6 ) = sqrt3 * ( p ( 3 , 2 ) * p ( 3 , 3 )) q ( 4 , 6 ) = sqrt3 * ( p ( 1 , 2 ) * p ( 2 , 3 ) + p ( 2 , 2 ) * p ( 1 , 3 ) ) q ( 5 , 6 ) = sqrt3 * ( p ( 1 , 2 ) * p ( 3 , 3 ) + p ( 3 , 2 ) * p ( 1 , 3 ) ) q ( 6 , 6 ) = sqrt3 * ( p ( 2 , 2 ) * p ( 3 , 3 ) + p ( 3 , 2 ) * p ( 2 , 3 ) ) do j = 1 , 3 do i = 1 , 6 do k = 1 , 6 t ( k ) = f ( i , j , k , 1 ) end do do k = 1 , 6 f ( i , j , k , 1 ) = t ( 1 ) * q ( 1 , k ) + t ( 2 ) * q ( 2 , k ) + t ( 3 ) * q ( 3 , k ) & + t ( 4 ) * q ( 4 , k ) + t ( 5 ) * q ( 5 , k ) + t ( 6 ) * q ( 6 , k ) end do end do end do do k = 1 , 6 do i = 1 , 6 t ( 1 ) = f ( i , 1 , k , 1 ) t ( 2 ) = f ( i , 2 , k , 1 ) t ( 3 ) = f ( i , 3 , k , 1 ) f ( i , 1 , k , 1 ) = t ( 1 ) * p ( 1 , 1 ) + t ( 2 ) * p ( 2 , 1 ) + t ( 3 ) * p ( 3 , 1 ) f ( i , 2 , k , 1 ) = t ( 1 ) * p ( 1 , 2 ) + t ( 2 ) * p ( 2 , 2 ) + t ( 3 ) * p ( 3 , 2 ) f ( i , 3 , k , 1 ) = t ( 1 ) * p ( 1 , 3 ) + t ( 2 ) * p ( 2 , 3 ) + t ( 3 ) * p ( 3 , 3 ) end do end do do k = 1 , 6 do j = 1 , 3 do i = 1 , 6 t ( i ) = f ( i , j , k , 1 ) end do do i = 1 , 6 f ( i , j , k , 1 ) = t ( 1 ) * q ( 1 , i ) + t ( 2 ) * q ( 2 , i ) + t ( 3 ) * q ( 3 , i ) & + t ( 4 ) * q ( 4 , i ) + t ( 5 ) * q ( 5 , i ) + t ( 6 ) * q ( 6 , i ) end do end do end do end subroutine r30s1d_15 subroutine r30s1d_16 ( f , p ) implicit none real ( kind = dp ) :: f ( 6 , 3 , 3 , * ), p ( 3 , 3 ) real ( kind = dp ) :: t ( 6 ), q ( 6 , 6 ) integer :: i , j , k , l q ( 1 , 1 : 3 ) = p ( 1 , 1 : 3 ) * p ( 1 , 1 : 3 ) q ( 2 , 1 : 3 ) = p ( 2 , 1 : 3 ) * p ( 2 , 1 : 3 ) q ( 3 , 1 : 3 ) = p ( 3 , 1 : 3 ) * p ( 3 , 1 : 3 ) q ( 4 , 1 : 3 ) = p ( 1 , 1 : 3 ) * p ( 2 , 1 : 3 ) * 2.0_dp q ( 5 , 1 : 3 ) = p ( 1 , 1 : 3 ) * p ( 3 , 1 : 3 ) * 2.0_dp q ( 6 , 1 : 3 ) = p ( 2 , 1 : 3 ) * p ( 3 , 1 : 3 ) * 2.0_dp q ( 1 , 4 : 5 ) = sqrt3 * ( p ( 1 , 1 ) * p ( 1 , 2 : 3 ) ) q ( 2 , 4 : 5 ) = sqrt3 * ( p ( 2 , 1 ) * p ( 2 , 2 : 3 ) ) q ( 3 , 4 : 5 ) = sqrt3 * ( p ( 3 , 1 ) * p ( 3 , 2 : 3 ) ) q ( 4 , 4 : 5 ) = sqrt3 * ( p ( 1 , 1 ) * p ( 2 , 2 : 3 ) + p ( 2 , 1 ) * p ( 1 , 2 : 3 ) ) q ( 5 , 4 : 5 ) = sqrt3 * ( p ( 1 , 1 ) * p ( 3 , 2 : 3 ) + p ( 3 , 1 ) * p ( 1 , 2 : 3 ) ) q ( 6 , 4 : 5 ) = sqrt3 * ( p ( 2 , 1 ) * p ( 3 , 2 : 3 ) + p ( 3 , 1 ) * p ( 2 , 2 : 3 ) ) q ( 1 , 6 ) = sqrt3 * ( p ( 1 , 2 ) * p ( 1 , 3 )) q ( 2 , 6 ) = sqrt3 * ( p ( 2 , 2 ) * p ( 2 , 3 )) q ( 3 , 6 ) = sqrt3 * ( p ( 3 , 2 ) * p ( 3 , 3 )) q ( 4 , 6 ) = sqrt3 * ( p ( 1 , 2 ) * p ( 2 , 3 ) + p ( 2 , 2 ) * p ( 1 , 3 ) ) q ( 5 , 6 ) = sqrt3 * ( p ( 1 , 2 ) * p ( 3 , 3 ) + p ( 3 , 2 ) * p ( 1 , 3 ) ) q ( 6 , 6 ) = sqrt3 * ( p ( 2 , 2 ) * p ( 3 , 3 ) + p ( 3 , 2 ) * p ( 2 , 3 ) ) do k = 1 , 3 do j = 1 , 3 do i = 1 , 6 t ( 1 ) = f ( i , j , k , 1 ) t ( 2 ) = f ( i , j , k , 2 ) t ( 3 ) = f ( i , j , k , 3 ) f ( i , j , k , 1 ) = t ( 1 ) * p ( 1 , 1 ) + t ( 2 ) * p ( 2 , 1 ) + t ( 3 ) * p ( 3 , 1 ) f ( i , j , k , 2 ) = t ( 1 ) * p ( 1 , 2 ) + t ( 2 ) * p ( 2 , 2 ) + t ( 3 ) * p ( 3 , 2 ) f ( i , j , k , 3 ) = t ( 1 ) * p ( 1 , 3 ) + t ( 2 ) * p ( 2 , 3 ) + t ( 3 ) * p ( 3 , 3 ) end do end do end do do l = 1 , 3 do j = 1 , 3 do i = 1 , 6 t ( 1 ) = f ( i , j , 1 , l ) t ( 2 ) = f ( i , j , 2 , l ) t ( 3 ) = f ( i , j , 3 , l ) f ( i , j , 1 , l ) = t ( 1 ) * p ( 1 , 1 ) + t ( 2 ) * p ( 2 , 1 ) + t ( 3 ) * p ( 3 , 1 ) f ( i , j , 2 , l ) = t ( 1 ) * p ( 1 , 2 ) + t ( 2 ) * p ( 2 , 2 ) + t ( 3 ) * p ( 3 , 2 ) f ( i , j , 3 , l ) = t ( 1 ) * p ( 1 , 3 ) + t ( 2 ) * p ( 2 , 3 ) + t ( 3 ) * p ( 3 , 3 ) end do end do end do do l = 1 , 3 do k = 1 , 3 do i = 1 , 6 t ( 1 ) = f ( i , 1 , k , l ) t ( 2 ) = f ( i , 2 , k , l ) t ( 3 ) = f ( i , 3 , k , l ) f ( i , 1 , k , l ) = t ( 1 ) * p ( 1 , 1 ) + t ( 2 ) * p ( 2 , 1 ) + t ( 3 ) * p ( 3 , 1 ) f ( i , 2 , k , l ) = t ( 1 ) * p ( 1 , 2 ) + t ( 2 ) * p ( 2 , 2 ) + t ( 3 ) * p ( 3 , 2 ) f ( i , 3 , k , l ) = t ( 1 ) * p ( 1 , 3 ) + t ( 2 ) * p ( 2 , 3 ) + t ( 3 ) * p ( 3 , 3 ) end do end do end do do l = 1 , 3 do k = 1 , 3 do j = 1 , 3 do i = 1 , 6 t ( i ) = f ( i , j , k , l ) end do do i = 1 , 6 f ( i , j , k , l ) = t ( 1 ) * q ( 1 , i ) + t ( 2 ) * q ( 2 , i ) + t ( 3 ) * q ( 3 , i ) & + t ( 4 ) * q ( 4 , i ) + t ( 5 ) * q ( 5 , i ) + t ( 6 ) * q ( 6 , i ) end do end do end do end do end subroutine r30s1d_16 subroutine r30s1d_17 ( f , p ) implicit none real ( kind = dp ) :: f ( 6 , 6 , 6 , * ), p ( 3 , 3 ) real ( kind = dp ) :: t ( 6 ), q ( 6 , 6 ) integer :: i , j , k , l q ( 1 , 1 : 3 ) = p ( 1 , 1 : 3 ) * p ( 1 , 1 : 3 ) q ( 2 , 1 : 3 ) = p ( 2 , 1 : 3 ) * p ( 2 , 1 : 3 ) q ( 3 , 1 : 3 ) = p ( 3 , 1 : 3 ) * p ( 3 , 1 : 3 ) q ( 4 , 1 : 3 ) = p ( 1 , 1 : 3 ) * p ( 2 , 1 : 3 ) * 2.0_dp q ( 5 , 1 : 3 ) = p ( 1 , 1 : 3 ) * p ( 3 , 1 : 3 ) * 2.0_dp q ( 6 , 1 : 3 ) = p ( 2 , 1 : 3 ) * p ( 3 , 1 : 3 ) * 2.0_dp q ( 1 , 4 : 5 ) = sqrt3 * ( p ( 1 , 1 ) * p ( 1 , 2 : 3 ) ) q ( 2 , 4 : 5 ) = sqrt3 * ( p ( 2 , 1 ) * p ( 2 , 2 : 3 ) ) q ( 3 , 4 : 5 ) = sqrt3 * ( p ( 3 , 1 ) * p ( 3 , 2 : 3 ) ) q ( 4 , 4 : 5 ) = sqrt3 * ( p ( 1 , 1 ) * p ( 2 , 2 : 3 ) + p ( 2 , 1 ) * p ( 1 , 2 : 3 ) ) q ( 5 , 4 : 5 ) = sqrt3 * ( p ( 1 , 1 ) * p ( 3 , 2 : 3 ) + p ( 3 , 1 ) * p ( 1 , 2 : 3 ) ) q ( 6 , 4 : 5 ) = sqrt3 * ( p ( 2 , 1 ) * p ( 3 , 2 : 3 ) + p ( 3 , 1 ) * p ( 2 , 2 : 3 ) ) q ( 1 , 6 ) = sqrt3 * ( p ( 1 , 2 ) * p ( 1 , 3 )) q ( 2 , 6 ) = sqrt3 * ( p ( 2 , 2 ) * p ( 2 , 3 )) q ( 3 , 6 ) = sqrt3 * ( p ( 3 , 2 ) * p ( 3 , 3 )) q ( 4 , 6 ) = sqrt3 * ( p ( 1 , 2 ) * p ( 2 , 3 ) + p ( 2 , 2 ) * p ( 1 , 3 ) ) q ( 5 , 6 ) = sqrt3 * ( p ( 1 , 2 ) * p ( 3 , 3 ) + p ( 3 , 2 ) * p ( 1 , 3 ) ) q ( 6 , 6 ) = sqrt3 * ( p ( 2 , 2 ) * p ( 3 , 3 ) + p ( 3 , 2 ) * p ( 2 , 3 ) ) do j = 1 , 6 do i = 1 , 6 do k = 1 , 6 t ( k ) = f ( i , j , k , 1 ) end do do k = 1 , 6 f ( i , j , k , 1 ) = t ( 1 ) * q ( 1 , k ) + t ( 2 ) * q ( 2 , k ) + t ( 3 ) * q ( 3 , k ) & + t ( 4 ) * q ( 4 , k ) + t ( 5 ) * q ( 5 , k ) + t ( 6 ) * q ( 6 , k ) end do end do end do do k = 1 , 6 do i = 1 , 6 do j = 1 , 6 t ( j ) = f ( i , j , k , 1 ) end do do j = 1 , 6 f ( i , j , k , 1 ) = t ( 1 ) * q ( 1 , j ) + t ( 2 ) * q ( 2 , j ) + t ( 3 ) * q ( 3 , j ) & + t ( 4 ) * q ( 4 , j ) + t ( 5 ) * q ( 5 , j ) + t ( 6 ) * q ( 6 , j ) end do end do end do do k = 1 , 6 do j = 1 , 6 do i = 1 , 6 t ( i ) = f ( i , j , k , 1 ) end do do i = 1 , 6 f ( i , j , k , 1 ) = t ( 1 ) * q ( 1 , i ) + t ( 2 ) * q ( 2 , i ) + t ( 3 ) * q ( 3 , i ) & + t ( 4 ) * q ( 4 , i ) + t ( 5 ) * q ( 5 , i ) + t ( 6 ) * q ( 6 , i ) end do end do end do end subroutine r30s1d_17 subroutine r30s1d_18 ( f , p ) implicit none real ( kind = dp ) :: f ( 6 , 6 , 3 , * ), p ( 3 , 3 ) real ( kind = dp ) :: t ( 6 ), q ( 6 , 6 ) integer :: i , j , k , l q ( 1 , 1 : 3 ) = p ( 1 , 1 : 3 ) * p ( 1 , 1 : 3 ) q ( 2 , 1 : 3 ) = p ( 2 , 1 : 3 ) * p ( 2 , 1 : 3 ) q ( 3 , 1 : 3 ) = p ( 3 , 1 : 3 ) * p ( 3 , 1 : 3 ) q ( 4 , 1 : 3 ) = p ( 1 , 1 : 3 ) * p ( 2 , 1 : 3 ) * 2.0_dp q ( 5 , 1 : 3 ) = p ( 1 , 1 : 3 ) * p ( 3 , 1 : 3 ) * 2.0_dp q ( 6 , 1 : 3 ) = p ( 2 , 1 : 3 ) * p ( 3 , 1 : 3 ) * 2.0_dp q ( 1 , 4 : 5 ) = sqrt3 * ( p ( 1 , 1 ) * p ( 1 , 2 : 3 ) ) q ( 2 , 4 : 5 ) = sqrt3 * ( p ( 2 , 1 ) * p ( 2 , 2 : 3 ) ) q ( 3 , 4 : 5 ) = sqrt3 * ( p ( 3 , 1 ) * p ( 3 , 2 : 3 ) ) q ( 4 , 4 : 5 ) = sqrt3 * ( p ( 1 , 1 ) * p ( 2 , 2 : 3 ) + p ( 2 , 1 ) * p ( 1 , 2 : 3 ) ) q ( 5 , 4 : 5 ) = sqrt3 * ( p ( 1 , 1 ) * p ( 3 , 2 : 3 ) + p ( 3 , 1 ) * p ( 1 , 2 : 3 ) ) q ( 6 , 4 : 5 ) = sqrt3 * ( p ( 2 , 1 ) * p ( 3 , 2 : 3 ) + p ( 3 , 1 ) * p ( 2 , 2 : 3 ) ) q ( 1 , 6 ) = sqrt3 * ( p ( 1 , 2 ) * p ( 1 , 3 )) q ( 2 , 6 ) = sqrt3 * ( p ( 2 , 2 ) * p ( 2 , 3 )) q ( 3 , 6 ) = sqrt3 * ( p ( 3 , 2 ) * p ( 3 , 3 )) q ( 4 , 6 ) = sqrt3 * ( p ( 1 , 2 ) * p ( 2 , 3 ) + p ( 2 , 2 ) * p ( 1 , 3 ) ) q ( 5 , 6 ) = sqrt3 * ( p ( 1 , 2 ) * p ( 3 , 3 ) + p ( 3 , 2 ) * p ( 1 , 3 ) ) q ( 6 , 6 ) = sqrt3 * ( p ( 2 , 2 ) * p ( 3 , 3 ) + p ( 3 , 2 ) * p ( 2 , 3 ) ) do k = 1 , 3 do j = 1 , 6 do i = 1 , 6 t ( 1 ) = f ( i , j , k , 1 ) t ( 2 ) = f ( i , j , k , 2 ) t ( 3 ) = f ( i , j , k , 3 ) f ( i , j , k , 1 ) = t ( 1 ) * p ( 1 , 1 ) + t ( 2 ) * p ( 2 , 1 ) + t ( 3 ) * p ( 3 , 1 ) f ( i , j , k , 2 ) = t ( 1 ) * p ( 1 , 2 ) + t ( 2 ) * p ( 2 , 2 ) + t ( 3 ) * p ( 3 , 2 ) f ( i , j , k , 3 ) = t ( 1 ) * p ( 1 , 3 ) + t ( 2 ) * p ( 2 , 3 ) + t ( 3 ) * p ( 3 , 3 ) end do end do end do do l = 1 , 3 do j = 1 , 6 do i = 1 , 6 t ( 1 ) = f ( i , j , 1 , l ) t ( 2 ) = f ( i , j , 2 , l ) t ( 3 ) = f ( i , j , 3 , l ) f ( i , j , 1 , l ) = t ( 1 ) * p ( 1 , 1 ) + t ( 2 ) * p ( 2 , 1 ) + t ( 3 ) * p ( 3 , 1 ) f ( i , j , 2 , l ) = t ( 1 ) * p ( 1 , 2 ) + t ( 2 ) * p ( 2 , 2 ) + t ( 3 ) * p ( 3 , 2 ) f ( i , j , 3 , l ) = t ( 1 ) * p ( 1 , 3 ) + t ( 2 ) * p ( 2 , 3 ) + t ( 3 ) * p ( 3 , 3 ) end do end do end do do l = 1 , 3 do k = 1 , 3 do i = 1 , 6 do j = 1 , 6 t ( j ) = f ( i , j , k , l ) end do do j = 1 , 6 f ( i , j , k , l ) = t ( 1 ) * q ( 1 , j ) + t ( 2 ) * q ( 2 , j ) + t ( 3 ) * q ( 3 , j ) & + t ( 4 ) * q ( 4 , j ) + t ( 5 ) * q ( 5 , j ) + t ( 6 ) * q ( 6 , j ) end do end do end do end do do l = 1 , 3 do k = 1 , 3 do j = 1 , 6 do i = 1 , 6 t ( i ) = f ( i , j , k , l ) end do do i = 1 , 6 f ( i , j , k , l ) = t ( 1 ) * q ( 1 , i ) + t ( 2 ) * q ( 2 , i ) + t ( 3 ) * q ( 3 , i ) & + t ( 4 ) * q ( 4 , i ) + t ( 5 ) * q ( 5 , i ) + t ( 6 ) * q ( 6 , i ) end do end do end do end do end subroutine r30s1d_18 subroutine r30s1d_19 ( f , p ) implicit none real ( kind = dp ) :: f ( 6 , 3 , 6 , * ), p ( 3 , 3 ) real ( kind = dp ) :: t ( 6 ), q ( 6 , 6 ) integer :: i , j , k , l q ( 1 , 1 : 3 ) = p ( 1 , 1 : 3 ) * p ( 1 , 1 : 3 ) q ( 2 , 1 : 3 ) = p ( 2 , 1 : 3 ) * p ( 2 , 1 : 3 ) q ( 3 , 1 : 3 ) = p ( 3 , 1 : 3 ) * p ( 3 , 1 : 3 ) q ( 4 , 1 : 3 ) = p ( 1 , 1 : 3 ) * p ( 2 , 1 : 3 ) * 2.0_dp q ( 5 , 1 : 3 ) = p ( 1 , 1 : 3 ) * p ( 3 , 1 : 3 ) * 2.0_dp q ( 6 , 1 : 3 ) = p ( 2 , 1 : 3 ) * p ( 3 , 1 : 3 ) * 2.0_dp q ( 1 , 4 : 5 ) = sqrt3 * ( p ( 1 , 1 ) * p ( 1 , 2 : 3 ) ) q ( 2 , 4 : 5 ) = sqrt3 * ( p ( 2 , 1 ) * p ( 2 , 2 : 3 ) ) q ( 3 , 4 : 5 ) = sqrt3 * ( p ( 3 , 1 ) * p ( 3 , 2 : 3 ) ) q ( 4 , 4 : 5 ) = sqrt3 * ( p ( 1 , 1 ) * p ( 2 , 2 : 3 ) + p ( 2 , 1 ) * p ( 1 , 2 : 3 ) ) q ( 5 , 4 : 5 ) = sqrt3 * ( p ( 1 , 1 ) * p ( 3 , 2 : 3 ) + p ( 3 , 1 ) * p ( 1 , 2 : 3 ) ) q ( 6 , 4 : 5 ) = sqrt3 * ( p ( 2 , 1 ) * p ( 3 , 2 : 3 ) + p ( 3 , 1 ) * p ( 2 , 2 : 3 ) ) q ( 1 , 6 ) = sqrt3 * ( p ( 1 , 2 ) * p ( 1 , 3 )) q ( 2 , 6 ) = sqrt3 * ( p ( 2 , 2 ) * p ( 2 , 3 )) q ( 3 , 6 ) = sqrt3 * ( p ( 3 , 2 ) * p ( 3 , 3 )) q ( 4 , 6 ) = sqrt3 * ( p ( 1 , 2 ) * p ( 2 , 3 ) + p ( 2 , 2 ) * p ( 1 , 3 ) ) q ( 5 , 6 ) = sqrt3 * ( p ( 1 , 2 ) * p ( 3 , 3 ) + p ( 3 , 2 ) * p ( 1 , 3 ) ) q ( 6 , 6 ) = sqrt3 * ( p ( 2 , 2 ) * p ( 3 , 3 ) + p ( 3 , 2 ) * p ( 2 , 3 ) ) do k = 1 , 6 do j = 1 , 3 do i = 1 , 6 t ( 1 ) = f ( i , j , k , 1 ) t ( 2 ) = f ( i , j , k , 2 ) t ( 3 ) = f ( i , j , k , 3 ) f ( i , j , k , 1 ) = t ( 1 ) * p ( 1 , 1 ) + t ( 2 ) * p ( 2 , 1 ) + t ( 3 ) * p ( 3 , 1 ) f ( i , j , k , 2 ) = t ( 1 ) * p ( 1 , 2 ) + t ( 2 ) * p ( 2 , 2 ) + t ( 3 ) * p ( 3 , 2 ) f ( i , j , k , 3 ) = t ( 1 ) * p ( 1 , 3 ) + t ( 2 ) * p ( 2 , 3 ) + t ( 3 ) * p ( 3 , 3 ) end do end do end do do l = 1 , 3 do j = 1 , 3 do i = 1 , 6 do k = 1 , 6 t ( k ) = f ( i , j , k , l ) end do do k = 1 , 6 f ( i , j , k , l ) = t ( 1 ) * q ( 1 , k ) + t ( 2 ) * q ( 2 , k ) + t ( 3 ) * q ( 3 , k ) & + t ( 4 ) * q ( 4 , k ) + t ( 5 ) * q ( 5 , k ) + t ( 6 ) * q ( 6 , k ) end do end do end do end do do l = 1 , 3 do k = 1 , 6 do i = 1 , 6 t ( 1 ) = f ( i , 1 , k , l ) t ( 2 ) = f ( i , 2 , k , l ) t ( 3 ) = f ( i , 3 , k , l ) f ( i , 1 , k , l ) = t ( 1 ) * p ( 1 , 1 ) + t ( 2 ) * p ( 2 , 1 ) + t ( 3 ) * p ( 3 , 1 ) f ( i , 2 , k , l ) = t ( 1 ) * p ( 1 , 2 ) + t ( 2 ) * p ( 2 , 2 ) + t ( 3 ) * p ( 3 , 2 ) f ( i , 3 , k , l ) = t ( 1 ) * p ( 1 , 3 ) + t ( 2 ) * p ( 2 , 3 ) + t ( 3 ) * p ( 3 , 3 ) end do end do end do do l = 1 , 3 do k = 1 , 6 do j = 1 , 3 do i = 1 , 6 t ( i ) = f ( i , j , k , l ) end do do i = 1 , 6 f ( i , j , k , l ) = t ( 1 ) * q ( 1 , i ) + t ( 2 ) * q ( 2 , i ) + t ( 3 ) * q ( 3 , i ) & + t ( 4 ) * q ( 4 , i ) + t ( 5 ) * q ( 5 , i ) + t ( 6 ) * q ( 6 , i ) end do end do end do end do end subroutine r30s1d_19 subroutine r30s1d_20 ( f , p ) implicit none real ( kind = dp ) :: f ( 6 , 6 , 6 , * ), p ( 3 , 3 ) real ( kind = dp ) :: t ( 6 ), q ( 6 , 6 ) integer :: i , j , k , l q ( 1 , 1 : 3 ) = p ( 1 , 1 : 3 ) * p ( 1 , 1 : 3 ) q ( 2 , 1 : 3 ) = p ( 2 , 1 : 3 ) * p ( 2 , 1 : 3 ) q ( 3 , 1 : 3 ) = p ( 3 , 1 : 3 ) * p ( 3 , 1 : 3 ) q ( 4 , 1 : 3 ) = p ( 1 , 1 : 3 ) * p ( 2 , 1 : 3 ) * 2.0_dp q ( 5 , 1 : 3 ) = p ( 1 , 1 : 3 ) * p ( 3 , 1 : 3 ) * 2.0_dp q ( 6 , 1 : 3 ) = p ( 2 , 1 : 3 ) * p ( 3 , 1 : 3 ) * 2.0_dp q ( 1 , 4 : 5 ) = sqrt3 * ( p ( 1 , 1 ) * p ( 1 , 2 : 3 ) ) q ( 2 , 4 : 5 ) = sqrt3 * ( p ( 2 , 1 ) * p ( 2 , 2 : 3 ) ) q ( 3 , 4 : 5 ) = sqrt3 * ( p ( 3 , 1 ) * p ( 3 , 2 : 3 ) ) q ( 4 , 4 : 5 ) = sqrt3 * ( p ( 1 , 1 ) * p ( 2 , 2 : 3 ) + p ( 2 , 1 ) * p ( 1 , 2 : 3 ) ) q ( 5 , 4 : 5 ) = sqrt3 * ( p ( 1 , 1 ) * p ( 3 , 2 : 3 ) + p ( 3 , 1 ) * p ( 1 , 2 : 3 ) ) q ( 6 , 4 : 5 ) = sqrt3 * ( p ( 2 , 1 ) * p ( 3 , 2 : 3 ) + p ( 3 , 1 ) * p ( 2 , 2 : 3 ) ) q ( 1 , 6 ) = sqrt3 * ( p ( 1 , 2 ) * p ( 1 , 3 )) q ( 2 , 6 ) = sqrt3 * ( p ( 2 , 2 ) * p ( 2 , 3 )) q ( 3 , 6 ) = sqrt3 * ( p ( 3 , 2 ) * p ( 3 , 3 )) q ( 4 , 6 ) = sqrt3 * ( p ( 1 , 2 ) * p ( 2 , 3 ) + p ( 2 , 2 ) * p ( 1 , 3 ) ) q ( 5 , 6 ) = sqrt3 * ( p ( 1 , 2 ) * p ( 3 , 3 ) + p ( 3 , 2 ) * p ( 1 , 3 ) ) q ( 6 , 6 ) = sqrt3 * ( p ( 2 , 2 ) * p ( 3 , 3 ) + p ( 3 , 2 ) * p ( 2 , 3 ) ) do k = 1 , 6 do j = 1 , 6 do i = 1 , 6 t ( 1 ) = f ( i , j , k , 1 ) t ( 2 ) = f ( i , j , k , 2 ) t ( 3 ) = f ( i , j , k , 3 ) f ( i , j , k , 1 ) = t ( 1 ) * p ( 1 , 1 ) + t ( 2 ) * p ( 2 , 1 ) + t ( 3 ) * p ( 3 , 1 ) f ( i , j , k , 2 ) = t ( 1 ) * p ( 1 , 2 ) + t ( 2 ) * p ( 2 , 2 ) + t ( 3 ) * p ( 3 , 2 ) f ( i , j , k , 3 ) = t ( 1 ) * p ( 1 , 3 ) + t ( 2 ) * p ( 2 , 3 ) + t ( 3 ) * p ( 3 , 3 ) end do end do end do do l = 1 , 3 do j = 1 , 6 do i = 1 , 6 do k = 1 , 6 t ( k ) = f ( i , j , k , l ) end do do k = 1 , 6 f ( i , j , k , l ) = t ( 1 ) * q ( 1 , k ) + t ( 2 ) * q ( 2 , k ) + t ( 3 ) * q ( 3 , k ) & + t ( 4 ) * q ( 4 , k ) + t ( 5 ) * q ( 5 , k ) + t ( 6 ) * q ( 6 , k ) end do end do end do end do do l = 1 , 3 do k = 1 , 6 do i = 1 , 6 do j = 1 , 6 t ( j ) = f ( i , j , k , l ) end do do j = 1 , 6 f ( i , j , k , l ) = t ( 1 ) * q ( 1 , j ) + t ( 2 ) * q ( 2 , j ) + t ( 3 ) * q ( 3 , j ) & + t ( 4 ) * q ( 4 , j ) + t ( 5 ) * q ( 5 , j ) + t ( 6 ) * q ( 6 , j ) end do end do end do end do do l = 1 , 3 do k = 1 , 6 do j = 1 , 6 do i = 1 , 6 t ( i ) = f ( i , j , k , l ) end do do i = 1 , 6 f ( i , j , k , l ) = t ( 1 ) * q ( 1 , i ) + t ( 2 ) * q ( 2 , i ) + t ( 3 ) * q ( 3 , i ) & + t ( 4 ) * q ( 4 , i ) + t ( 5 ) * q ( 5 , i ) + t ( 6 ) * q ( 6 , i ) end do end do end do end do end subroutine r30s1d_20 subroutine r30s1d_21 ( f , p ) implicit none real ( kind = dp ) :: f ( 6 , 6 , 6 , * ), p ( 3 , 3 ) real ( kind = dp ) :: t ( 6 ), q ( 6 , 6 ) integer :: i , j , k , l q ( 1 , 1 : 3 ) = p ( 1 , 1 : 3 ) * p ( 1 , 1 : 3 ) q ( 2 , 1 : 3 ) = p ( 2 , 1 : 3 ) * p ( 2 , 1 : 3 ) q ( 3 , 1 : 3 ) = p ( 3 , 1 : 3 ) * p ( 3 , 1 : 3 ) q ( 4 , 1 : 3 ) = p ( 1 , 1 : 3 ) * p ( 2 , 1 : 3 ) * 2.0_dp q ( 5 , 1 : 3 ) = p ( 1 , 1 : 3 ) * p ( 3 , 1 : 3 ) * 2.0_dp q ( 6 , 1 : 3 ) = p ( 2 , 1 : 3 ) * p ( 3 , 1 : 3 ) * 2.0_dp q ( 1 , 4 : 5 ) = sqrt3 * ( p ( 1 , 1 ) * p ( 1 , 2 : 3 ) ) q ( 2 , 4 : 5 ) = sqrt3 * ( p ( 2 , 1 ) * p ( 2 , 2 : 3 ) ) q ( 3 , 4 : 5 ) = sqrt3 * ( p ( 3 , 1 ) * p ( 3 , 2 : 3 ) ) q ( 4 , 4 : 5 ) = sqrt3 * ( p ( 1 , 1 ) * p ( 2 , 2 : 3 ) + p ( 2 , 1 ) * p ( 1 , 2 : 3 ) ) q ( 5 , 4 : 5 ) = sqrt3 * ( p ( 1 , 1 ) * p ( 3 , 2 : 3 ) + p ( 3 , 1 ) * p ( 1 , 2 : 3 ) ) q ( 6 , 4 : 5 ) = sqrt3 * ( p ( 2 , 1 ) * p ( 3 , 2 : 3 ) + p ( 3 , 1 ) * p ( 2 , 2 : 3 ) ) q ( 1 , 6 ) = sqrt3 * ( p ( 1 , 2 ) * p ( 1 , 3 )) q ( 2 , 6 ) = sqrt3 * ( p ( 2 , 2 ) * p ( 2 , 3 )) q ( 3 , 6 ) = sqrt3 * ( p ( 3 , 2 ) * p ( 3 , 3 )) q ( 4 , 6 ) = sqrt3 * ( p ( 1 , 2 ) * p ( 2 , 3 ) + p ( 2 , 2 ) * p ( 1 , 3 ) ) q ( 5 , 6 ) = sqrt3 * ( p ( 1 , 2 ) * p ( 3 , 3 ) + p ( 3 , 2 ) * p ( 1 , 3 ) ) q ( 6 , 6 ) = sqrt3 * ( p ( 2 , 2 ) * p ( 3 , 3 ) + p ( 3 , 2 ) * p ( 2 , 3 ) ) do k = 1 , 6 do j = 1 , 6 do i = 1 , 6 do l = 1 , 6 t ( l ) = f ( i , j , k , l ) end do do l = 1 , 6 f ( i , j , k , l ) = t ( 1 ) * q ( 1 , l ) + t ( 2 ) * q ( 2 , l ) + t ( 3 ) * q ( 3 , l ) & + t ( 4 ) * q ( 4 , l ) + t ( 5 ) * q ( 5 , l ) + t ( 6 ) * q ( 6 , l ) end do end do end do end do do l = 1 , 6 do j = 1 , 6 do i = 1 , 6 do k = 1 , 6 t ( k ) = f ( i , j , k , l ) end do do k = 1 , 6 f ( i , j , k , l ) = t ( 1 ) * q ( 1 , k ) + t ( 2 ) * q ( 2 , k ) + t ( 3 ) * q ( 3 , k ) & + t ( 4 ) * q ( 4 , k ) + t ( 5 ) * q ( 5 , k ) + t ( 6 ) * q ( 6 , k ) end do end do end do end do do l = 1 , 6 do k = 1 , 6 do i = 1 , 6 do j = 1 , 6 t ( j ) = f ( i , j , k , l ) end do do j = 1 , 6 f ( i , j , k , l ) = t ( 1 ) * q ( 1 , j ) + t ( 2 ) * q ( 2 , j ) + t ( 3 ) * q ( 3 , j ) & + t ( 4 ) * q ( 4 , j ) + t ( 5 ) * q ( 5 , j ) + t ( 6 ) * q ( 6 , j ) end do end do end do end do do l = 1 , 6 do k = 1 , 6 do j = 1 , 6 do i = 1 , 6 t ( i ) = f ( i , j , k , l ) end do do i = 1 , 6 f ( i , j , k , l ) = t ( 1 ) * q ( 1 , i ) + t ( 2 ) * q ( 2 , i ) + t ( 3 ) * q ( 3 , i ) & + t ( 4 ) * q ( 4 , i ) + t ( 5 ) * q ( 5 , i ) + t ( 6 ) * q ( 6 , i ) end do end do end do end do end subroutine r30s1d_21 end module","tags":"","url":"sourcefile/int_rotaxis.f90.html"},{"title":"basis_projection.F90 – OpenQP Fortran API","text":"Module: basis_projection_mod Description:\n   This module provides routines to project molecular orbitals (MO) and\n   density matrices (DM) from a primary basis set to an alternative\n   (initial) basis set. The module includes:\n     - A C-binding wrapper subroutine (proj_dm_newbas_C) to interface with\n       C codes.\n     - The main projection routine (proj_dm_newbas) that performs the MO and\n       DM projection, including orthogonalization and density matrix computation.\n     - A utility function (itoa) to convert integers to character strings. Source Code !********************************************************************** !> Module: basis_projection_mod !> !> Description: !>   This module provides routines to project molecular orbitals (MO) and !>   density matrices (DM) from a primary basis set to an alternative !>   (initial) basis set. !> !>   The module includes: !>     - A C-binding wrapper subroutine (proj_dm_newbas_C) to interface with !>       C codes. !>     - The main projection routine (proj_dm_newbas) that performs the MO and !>       DM projection, including orthogonalization and density matrix computation. !>     - A utility function (itoa) to convert integers to character strings. !********************************************************************** module basis_projection_mod implicit none character ( len =* ), parameter :: module_name = \"basis_projection_mod\" contains !********************************************************************** !> C-binding wrapper for the MO/DM projection routine. !********************************************************************** subroutine proj_dm_newbas_C ( c_handle ) bind ( C , name = \"proj_dm_newbas\" ) use c_interop , only : oqp_handle_t , oqp_handle_get_info use types , only : information type ( oqp_handle_t ) :: c_handle type ( information ), pointer :: inf inf => oqp_handle_get_info ( c_handle ) call proj_dm_newbas ( inf ) end subroutine proj_dm_newbas_C !********************************************************************** !> Main subroutine for MO and DM projection between basis sets. !> !> This routine projects molecular orbitals (MO) and density matrices (DM) !> from a primary basis set to an alternative (initial) basis set. It performs: !>   - Overlap matrix computation and normalization, !>   - Corresponding orbital projection, !>   - Orbital orthogonalization, !>   - Density matrix calculation (for both RHF and ROHF/UHF cases), !> !> Input Data: !>   - OQP::VEC_MO_A, OQP::DM_A for the alpha !>   - OQP::VEC_MO_B, OQP::DM_B for the beta (if applicable). !> !> Output Data: !>   - OQP::VEC_MO_A_tmp, OQP::DM_A_tmp for the alpha spin channel. !>   - OQP::VEC_MO_B_tmp, OQP::DM_B_tmp for the beta spin channel (if applicable). !> !> @param[in,out] infos Information structure containing basis sets, atomic data, !>                        molecular properties, and control parameters. !********************************************************************** subroutine proj_dm_newbas ( infos ) use precision , only : dp use types , only : information use io_constants , only : IW use oqp_tagarray_driver use basis_tools , only : basis_set use mathlib , only : matrix_invsqrt use util , only : measure_time use messages , only : show_message , WITH_ABORT use printing , only : print_module_info use constants , only : tol_int use int1 , only : basis_overlap use iso_c_binding , only : c_char use parallel , only : par_env_t use guess , only : get_ab_initio_density , corresponding_orbital_projection use huckel , only : orthogonalize_orbitals use messages , only : show_message , with_abort implicit none character ( len =* ), parameter :: subroutine_name = \"proj_dm_newbas\" type ( information ), target , intent ( inout ) :: infos integer :: i , j , nbf , nbf2 , nbf_alt , nbf2_alt , nat , nact , ndoc , nproj , l0 type ( basis_set ), pointer :: basis type ( basis_set ), pointer :: alt_basis character ( len = :), allocatable :: basis_file logical :: err integer , parameter :: root = 0 type ( par_env_t ) :: pe real ( kind = dp ), allocatable :: sco (:,:) real ( kind = dp ), contiguous , pointer :: & Smat (:), q (:,:), & dmat_a (:), mo_a (:,:), mo_energy_a (:), & dmat_b (:), mo_b (:,:), mo_energy_b (:) real ( kind = dp ), contiguous , pointer :: & Smat_alt (:), & dmat_a_alt (:), mo_a_alt (:,:), mo_energy_a_alt (:), & dmat_b_alt (:), mo_b_alt (:,:), mo_energy_b_alt (:) ! tagarray character ( len =* ), parameter :: tags_alpha ( 3 ) = ( / character ( len = 80 ) :: & OQP_DM_A , OQP_E_MO_A , OQP_VEC_MO_A / ) character ( len =* ), parameter :: tags_alpha_tmp ( 3 ) = ( / character ( len = 80 ) :: & \"OQP::DM_A_tmp\" , \"OQP::E_MO_A_tmp\" , \"OQP::VEC_MO_A_tmp\" / ) character ( len =* ), parameter :: tags_beta ( 3 ) = ( / character ( len = 80 ) :: & OQP_DM_B , OQP_E_MO_B , OQP_VEC_MO_B / ) character ( len =* ), parameter :: tags_beta_tmp ( 3 ) = ( / character ( len = 80 ) :: & \"OQP::DM_B_tmp\" , \"OQP::E_MO_B_tmp\" , \"OQP::VEC_MO_B_tmp\" / ) character ( len =* ), parameter :: tags_general ( 1 ) = ( / character ( len = 80 ) :: & OQP_SM / ) character ( len = 1 , kind = c_char ), contiguous , pointer :: basis_filename (:) ! Files open ! 1. XYZ: Read : Geometric data, ATOMS ! 3. LOG: Read Write: Main output file ! open ( unit = IW , file = infos % log_filename , position = \"append\" ) call print_module_info ( 'Basis Projection' , \"Projecting MOs and DMs from\" & // new_line ( '' ) // & \"initial to primary basis\" ) ! Readings ! load basis set basis => infos % basis alt_basis => infos % alt_basis call pe % init ( infos % mpiinfo % comm , infos % mpiinfo % usempi ) alt_basis % atoms => infos % atoms basis % atoms => infos % atoms nbf = basis % nbf nbf2 = nbf * ( nbf + 1 ) / 2 nat = infos % mol_prop % natom nbf_alt = alt_basis % nbf nbf2_alt = nbf_alt * ( nbf_alt + 1 ) / 2 if ( nbf_alt > nbf ) then call show_message ( \"Warning: The initial basis set (\" // trim ( adjustl ( itoa ( nbf_alt ))) // \" functions) \" // & \"exceeds the primary basis (\" // trim ( adjustl ( itoa ( nbf ))) // \"). \" // & \"Please select a smaller initial basis set.\" , WITH_ABORT ) end if call data_has_tags ( infos % dat , tags_general , module_name , subroutine_name , WITH_ABORT ) call tagarray_get_data ( infos % dat , OQP_SM , smat ) allocate ( sco ( nbf_alt , nbf ), & mo_a ( nbf , nbf ), & mo_b ( nbf , nbf ), & q ( nbf , nbf ), & Dmat_a ( nbf2 ), & Dmat_b ( nbf2 )) ! Load the converged initial-basis orbitals/densities. These are INPUTS -- ! the projection source, read below through the *_alt pointers -- so they ! must be retrieved, NOT reallocated (alloc_or_die would erase them). call data_has_tags ( infos % dat , tags_alpha , module_name , subroutine_name , WITH_ABORT ) call tagarray_get_data ( infos % dat , OQP_DM_A , dmat_a_alt ) call tagarray_get_data ( infos % dat , OQP_E_MO_A , mo_energy_a_alt ) call tagarray_get_data ( infos % dat , OQP_VEC_MO_A , mo_a_alt ) call data_has_tags ( infos % dat , tags_beta , module_name , subroutine_name , WITH_ABORT ) call tagarray_get_data ( infos % dat , OQP_DM_B , dmat_b_alt ) call tagarray_get_data ( infos % dat , OQP_E_MO_B , mo_energy_b_alt ) call tagarray_get_data ( infos % dat , OQP_VEC_MO_B , mo_b_alt ) ! allocate alpha_tmp call infos % dat % alloc_or_die ( \"OQP::DM_A_tmp\" , ( / nbf2 / ), dmat_a , description = OQP_DM_A_comment ) call infos % dat % alloc_or_die ( \"OQP::E_MO_A_tmp\" , ( / nbf / ), mo_energy_a , description = OQP_E_MO_A_comment ) call infos % dat % alloc_or_die ( \"OQP::VEC_MO_A_tmp\" , ( / nbf , nbf / ), mo_a , description = OQP_VEC_MO_A_comment ) ! allocate beta_tmp call infos % dat % alloc_or_die ( \"OQP::DM_B_tmp\" , ( / nbf2 / ), dmat_b , description = OQP_DM_B_comment ) call infos % dat % alloc_or_die ( \"OQP::E_MO_B_tmp\" , ( / nbf / ), mo_energy_b , description = OQP_E_MO_B_comment ) call infos % dat % alloc_or_die ( \"OQP::VEC_MO_B_tmp\" , ( / nbf , nbf / ), mo_b , description = OQP_VEC_MO_B_comment ) ! Dmat_b = 0_dp Dmat_a = 0_dp mo_b = 0_dp mo_a = 0_dp mo_energy_a = 0_dp mo_energy_b = 0_dp call basis_overlap ( sco , infos % basis , infos % alt_basis , tol = log ( 1 0.0d0 ) * tol_int ) do i = 1 , nbf sco (:, i ) = sco (:, i ) * basis % bfnrm ( i ) * alt_basis % bfnrm (:) end do if ( infos % control % scftype == 1 ) then ndoc = infos % mol_prop % nelec / 2 nact = 0 else if ( infos % control % scftype >= 2 ) then ndoc = infos % mol_prop % nelec_b nact = infos % mol_prop % nelec_a - infos % mol_prop % nelec_b end if nproj = nbf_alt l0 = nbf call matrix_invsqrt ( smat , q , nbf , qrnk = l0 ) mo_a ( 1 : nbf , 1 : nbf ) = q ( 1 : nbf , 1 : nbf ) call corresponding_orbital_projection ( mo_a_alt , sco , mo_a , ndoc , nact , nproj , nbf , nbf_alt , l0 ) call orthogonalize_orbitals ( q , smat , mo_a , nproj , l0 , nbf , nbf ) if ( infos % control % scftype >= 2 ) then mo_b ( 1 : nbf , 1 : nbf ) = q ( 1 : nbf , 1 : nbf ) call corresponding_orbital_projection ( mo_b_alt , sco , mo_b , ndoc , nact , nproj , nbf , nbf_alt , l0 ) call orthogonalize_orbitals ( q , smat , mo_b , nproj , l0 , nbf , nbf ) else mo_b = mo_a end if ! Calculate Density Matrix if ( pe % rank == root ) then ! RHF if ( infos % control % scftype == 1 ) then call get_ab_initio_density ( Dmat_A , MO_A , infos = infos , basis = basis ) ! ROHF/UHF else call get_ab_initio_density ( Dmat_A , MO_A , Dmat_B , MO_B , infos , infos % basis ) endif endif ! Broadcast MO and density matrices to all processes call pe % bcast ( MO_A , nbf * nbf ) if ( infos % control % scftype >= 2 ) then call pe % bcast ( MO_B , nbf * nbf ) endif ! Broadcast the density matrices to all processes if ( infos % control % scftype == 1 ) then call pe % bcast ( Dmat_A , nbf2 ) else call pe % bcast ( Dmat_A , nbf2 ) call pe % bcast ( Dmat_B , nbf2 ) endif call pe % barrier () write ( IW , '(/,a,/)' ) \"...... Completed Basis Projection Computation ......\" call measure_time ( print_total = 1 , log_unit = iw ) close ( iw ) end subroutine proj_dm_newbas pure function itoa ( num ) result ( str ) integer , intent ( in ) :: num character ( len = 16 ) :: str write ( str , '(I0)' ) num end function itoa end module basis_projection_mod","tags":"","url":"sourcefile/basis_projection.f90.html"},{"title":"libxc.F90 – OpenQP Fortran API","text":"Source Code !> @brief  MODULE libxc !> @brief  The head of libxc driver !> @author Igor S. Gerasimov !> @date   July, 2019 - Initial release - !> @date   July, 2021 Making internal subroutines private !> @todo   add LC-, CAM- free coefficient functionals !> @todo   add meta-GGA functionals with laplacian of electron density module libxc use xc_f03_lib_m use xc_f03_funcs_m use functionals , only : functional_t use precision , only : fp implicit none private character ( len =* ), parameter :: ABORTING = \"Aborting from LibXC interface...\" public :: libxc_input , libxc_destroy contains !> @brief  setting up of using libxc functionals !>         (Analog of INPGDFT) !> @detail !          For adding a new functional: !           1) search code of interested functional that is a part of LibXC (like PBEX has code 101 and PBEC has code 130) !           2) Determine coefficients of each needed coefficients (as for example PBE-0.1: 0.1HF + 0.9PBEX + 1.0PBEC) !           3) Create a name of your functional (like PBEH). It can has any symbol excepting newline and space. !           4) Do not forget to set flag needtau=.true. if your functional need it. ! !           the example of code: !             case(\"PBEH\", \"PBE-0.1\") !two variant of names !                 HFEX = 0.10_fp !0.1HF exchange !                 call functional%add_functional(XC_GGA_X_PBE,0.9_fp) !PBE_X*0.9 !                 call functional%add_functional(XC_GGA_C_PBE,1.0_fp) !PBE_C*1.0 !> @author Igor S. Gerasimov !> @date   July, 2019 - Initial release - !> @date   July, 2021 Using messages module !>                    Adding optional arguments !> @date   Dec,  2022 Pass functional instead of using global !> @params functional_name (in) functional's name !> @param  infos           (inout)  info datatype !> @param  functional      (inout)  constructing functional subroutine libxc_input ( functional_name , dft_params , tddft_params , functional ) use messages , only : show_message , WITH_ABORT use types , only : dft_parameters , tddft_parameters character ( len =* ), intent ( in ) :: functional_name type ( dft_parameters ), intent ( inout ) :: dft_params type ( tddft_parameters ), intent ( inout ) :: tddft_params type ( functional_t ), intent ( inout ) :: functional ! Functional names character ( len = :), allocatable :: funcname ! LibXC strings character ( len = 1024 ) :: LibXC_DOI , LibXC_reference , LibXC_version real ( kind = fp ) :: HFEX , MP2 real ( kind = fp ) :: chf , c2opp , c2same HFEX = 0.0_fp chf = 0.0_fp c2opp = 0.0_fp c2same = 0.0_fp call xc_f03_reference ( LibXC_reference ) call xc_f03_reference_doi ( LibXC_DOI ) call xc_f03_version_string ( LibXC_version ) call show_message ( \" \" ) !empty line call show_message ( \" The LibXC \" // trim ( LibXC_version ) // \" version is used.\" ) call show_message ( \" \" // trim ( LibXC_reference )) call show_message ( \" The libXC interfaces are described in the following article:\" ) call show_message ( \" Igor S. Gerasimov, Federico Zahariev, Sarom S. Leang, Anton Tesliuk, Mark S. Gordon, Michael G. Medvedev,\" ) call show_message ( \" Introducing LibXC into GAMESS (US),\" ) call show_message ( \" Mendeleev Commun., 2021, 31, 302–305\" ) call show_message ( \" \" ) !empty line call show_message ( \" The information about selected functionals:\" ) funcname = functional_name select case ( funcname ) case ( \"HFEX\" ) HFEX = 1.00_fp case ( \"SLATER\" ) call functional % add_functional ( XC_LDA_X , 1.00_fp ) !SLATER_X case ( \"TETER\" ) call functional % add_functional ( XC_LDA_XC_TETER93 , 1.00_fp ) !TETER93_XC case ( \"KSDT\" ) call functional % add_functional ( XC_LDA_XC_KSDT , 1.00_fp ) !KSDT_XC case ( \"CORRKSDT\" ) call functional % add_functional ( XC_LDA_XC_CORRKSDT , 1.00_fp ) case ( \"GDSMFB\" ) call functional % add_functional ( XC_LDA_XC_GDSMFB , 1.00_fp ) !GDSMFB_XC case ( \"ZLP-20\" ) call functional % add_functional ( XC_LDA_XC_ZLP , 1.00_fp ) !ZLP_XC (LDA) case ( \"PBE\" , \"PBEPBE\" ) call functional % add_functional ( XC_GGA_X_PBE , 1.00_fp ) !PBE_X call functional % add_functional ( XC_GGA_C_PBE , 1.00_fp ) !PBE_C case ( \"REVPBE\" ) call functional % add_functional ( XC_GGA_X_PBE_R , 1.00_fp ) !PBE_R_X call functional % add_functional ( XC_GGA_C_PBE , 1.00_fp ) !PBE_C case ( \"RPBE\" ) call functional % add_functional ( XC_GGA_X_RPBE , 1.00_fp ) !RPBE_X call functional % add_functional ( XC_GGA_C_PBE , 1.00_fp ) !PBE_C case ( \"PW91\" ) call functional % add_functional ( XC_GGA_X_PW91 , 1.00_fp ) call functional % add_functional ( XC_GGA_C_PW91 , 1.00_fp ) case ( \"AM05\" ) call functional % add_functional ( XC_GGA_X_AM05 , 1.00_fp ) call functional % add_functional ( XC_GGA_C_AM05 , 1.00_fp ) case ( \"PBESOL\" ) call functional % add_functional ( XC_GGA_X_PBE_SOL , 1.00_fp ) !PBEsol_X call functional % add_functional ( XC_GGA_C_PBE_SOL , 1.00_fp ) !PBEsol_C case ( \"WC\" ) call functional % add_functional ( XC_GGA_X_WC , 1.00_fp ) call functional % add_functional ( XC_GGA_C_PBE , 1.00_fp ) case ( \"CHACHIYO\" ) call functional % add_functional ( XC_GGA_X_CHACHIYO , 1.00_fp ) call functional % add_functional ( XC_GGA_C_CHACHIYO , 1.00_fp ) case ( \"BLYP\" ) call functional % add_functional ( XC_GGA_X_B88 , 1.00_fp ) call functional % add_functional ( XC_GGA_C_LYP , 1.00_fp ) case ( \"OLYP\" ) call functional % add_functional ( XC_GGA_X_OPTX , 1.00_fp ) call functional % add_functional ( XC_GGA_C_LYP , 1.00_fp ) case ( \"XLYP\" ) call functional % add_functional ( XC_GGA_XC_XLYP , 1.00_fp ) case ( \"KT1\" ) call functional % add_functional ( XC_GGA_XC_KT1 , 1.00_fp ) case ( \"KT2\" ) call functional % add_functional ( XC_GGA_XC_KT2 , 1.00_fp ) case ( \"KT3\" ) call functional % add_functional ( XC_GGA_XC_KT3 , 1.00_fp ) case ( \"TH1\" ) call functional % add_functional ( XC_GGA_XC_TH1 , 1.00_fp ) case ( \"TH2\" ) call functional % add_functional ( XC_GGA_XC_TH2 , 1.00_fp ) case ( \"TH3\" ) call functional % add_functional ( XC_GGA_XC_TH3 , 1.00_fp ) case ( \"TH4\" ) call functional % add_functional ( XC_GGA_XC_TH4 , 1.00_fp ) case ( \"HCTH93\" ) call functional % add_functional ( XC_GGA_XC_HCTH_93 , 1.00_fp ) case ( \"HCTH120\" ) call functional % add_functional ( XC_GGA_XC_HCTH_120 , 1.00_fp ) case ( \"HCTH147\" ) call functional % add_functional ( XC_GGA_XC_HCTH_147 , 1.00_fp ) case ( \"HCTH407\" ) call functional % add_functional ( XC_GGA_XC_HCTH_407 , 1.00_fp ) case ( \"HCTH407+\" , \"HCTH407P\" ) call functional % add_functional ( XC_GGA_XC_HCTH_407P , 1.00_fp ) case ( \"HCTH-A\" ) call functional % add_functional ( XC_GGA_X_HCTH_A , 1.00_fp ) call functional % add_functional ( XC_GGA_C_HCTH_A , 1.00_fp ) case ( \"HCTH-P14\" ) call functional % add_functional ( XC_GGA_XC_HCTH_P14 , 1.00_fp ) case ( \"HCTH-P76\" ) call functional % add_functional ( XC_GGA_XC_HCTH_P76 , 1.00_fp ) case ( \"PBE1W\" ) call functional % add_functional ( XC_GGA_XC_PBE1W , 1.00_fp ) case ( \"MPWLYP1W\" ) call functional % add_functional ( XC_GGA_XC_MPWLYP1W , 1.00_fp ) case ( \"PBELYP1W\" ) call functional % add_functional ( XC_GGA_XC_PBELYP1W , 1.00_fp ) case ( \"GAM\" ) call functional % add_functional ( XC_GGA_X_GAM , 1.00_fp ) call functional % add_functional ( XC_GGA_C_GAM , 1.00_fp ) case ( \"MOHLYP\" ) call functional % add_functional ( XC_GGA_XC_MOHLYP , 1.00_fp ) case ( \"MOHLYP-2\" , \"MOHLYP2\" ) call functional % add_functional ( XC_GGA_XC_MOHLYP2 , 1.00_fp ) case ( \"SOGGA11\" ) call functional % add_functional ( XC_GGA_X_SOGGA11 , 1.00_fp ) call functional % add_functional ( XC_GGA_C_SOGGA11 , 1.00_fp ) case ( \"N12\" ) call functional % add_functional ( XC_GGA_C_N12 , 1.00_fp ) call functional % add_functional ( XC_GGA_X_N12 , 1.00_fp ) case ( \"HLE16\" ) call functional % add_functional ( XC_GGA_XC_HLE16 , 1.00_fp ) case ( \"EDF1\" ) call functional % add_functional ( XC_GGA_XC_EDF1 , 1.00_fp ) case ( \"LB07\" ) dft_params % cam_flag = . true . call functional % add_functional ( XC_HYB_GGA_XC_LB07 , 1.00_fp ,& alpha = dft_params % cam_alpha , & beta = dft_params % cam_beta , omega = dft_params % cam_mu ) case ( \"NCAP\" ) call functional % add_functional ( XC_GGA_XC_NCAP , 1.00_fp ) case ( \"HTBS\" ) call functional % add_functional ( XC_GGA_X_HTBS , 1.00_fp ) call functional % add_functional ( XC_GGA_C_PBE , 1.00_fp ) case ( \"PKZB\" ) call functional % add_functional ( XC_MGGA_X_PKZB , 1.00_fp ) call functional % add_functional ( XC_MGGA_C_PKZB , 1.00_fp ) case ( \"TPSS\" ) call functional % add_functional ( XC_MGGA_X_TPSS , 1.00_fp ) call functional % add_functional ( XC_MGGA_C_TPSS , 1.00_fp ) case ( \"REVTPSS\" ) call functional % add_functional ( XC_MGGA_X_REVTPSS , 1.00_fp ) call functional % add_functional ( XC_MGGA_C_REVTPSS , 1.00_fp ) case ( \"MODTPSS\" ) call functional % add_functional ( XC_MGGA_X_MODTPSS , 1.00_fp ) call functional % add_functional ( XC_MGGA_C_TPSS , 1.00_fp ) case ( \"TPSSLOC\" , \"TPSS-LOC\" ) call functional % add_functional ( XC_MGGA_X_TPSS , 1.00_fp ) call functional % add_functional ( XC_MGGA_C_TPSSLOC , 1.00_fp ) case ( \"RTPSS\" ) call functional % add_functional ( XC_MGGA_X_RTPSS , 1.00_fp ) call functional % add_functional ( XC_GGA_C_REGTPSS , 1.00_fp ) case ( \"REGTPSS\" ) call functional % add_functional ( XC_MGGA_X_REGTPSS , 1.00_fp ) call functional % add_functional ( XC_GGA_C_REGTPSS , 1.00_fp ) case ( \"MVS\" ) call functional % add_functional ( XC_MGGA_X_MVS , 1.00_fp ) call functional % add_functional ( XC_GGA_C_PBE , 1.00_fp ) case ( \"MVSB\" ) call functional % add_functional ( XC_MGGA_X_MVSB , 1.00_fp ) call functional % add_functional ( XC_GGA_C_PBE , 1.00_fp ) case ( \"MVSB*\" , \"MVSBS\" ) call functional % add_functional ( XC_MGGA_X_MVSBS , 1.00_fp ) call functional % add_functional ( XC_GGA_C_PBE , 1.00_fp ) case ( \"MS0\" ) call functional % add_functional ( XC_MGGA_X_MS0 , 1.00_fp ) call functional % add_functional ( XC_GGA_C_PBE , 1.00_fp ) case ( \"MS1\" ) call functional % add_functional ( XC_MGGA_X_MS1 , 1.00_fp ) call functional % add_functional ( XC_GGA_C_PBE , 1.00_fp ) case ( \"MS2\" ) call functional % add_functional ( XC_MGGA_X_MS2 , 1.00_fp ) call functional % add_functional ( XC_GGA_C_PBE , 1.00_fp ) case ( \"MS2B\" ) call functional % add_functional ( XC_MGGA_X_MS2B , 1.00_fp ) call functional % add_functional ( XC_GGA_C_PBE , 1.00_fp ) case ( \"MS2B*\" , \"MS2BS\" ) call functional % add_functional ( XC_MGGA_X_MS2BS , 1.00_fp ) call functional % add_functional ( XC_GGA_C_PBE , 1.00_fp ) case ( \"SCAN\" ) call functional % add_functional ( XC_MGGA_X_SCAN , 1.00_fp ) call functional % add_functional ( XC_MGGA_C_SCAN , 1.00_fp ) case ( \"RSCAN\" , \"REGSCAN\" ) call functional % add_functional ( XC_MGGA_X_RSCAN , 1.00_fp ) call functional % add_functional ( XC_MGGA_C_RSCAN , 1.00_fp ) case ( \"RPPSCAN\" , \"R++SCAN\" ) call functional % add_functional ( XC_MGGA_X_RPPSCAN , 1.00_fp ) call functional % add_functional ( XC_MGGA_C_RPPSCAN , 1.00_fp ) case ( \"R2SCAN\" ) call functional % add_functional ( XC_MGGA_X_R2SCAN , 1.00_fp ) call functional % add_functional ( XC_MGGA_C_R2SCAN , 1.00_fp ) case ( \"R2SCAN01\" ) call functional % add_functional ( XC_MGGA_X_R2SCAN01 , 1.00_fp ) call functional % add_functional ( XC_MGGA_C_R2SCAN01 , 1.00_fp ) case ( \"R4SCAN\" ) call functional % add_functional ( XC_MGGA_X_R4SCAN , 1.00_fp ) call functional % add_functional ( XC_MGGA_C_R2SCAN , 1.00_fp ) case ( \"REVSCAN\" ) call functional % add_functional ( XC_MGGA_X_REVSCAN , 1.00_fp ) call functional % add_functional ( XC_MGGA_C_REVSCAN , 1.00_fp ) case ( \"TASK\" ) call functional % add_functional ( XC_MGGA_X_TASK , 1.00_fp ) call functional % add_functional ( XC_LDA_C_PW , 1.00_fp ) case ( \"TM\" ) call functional % add_functional ( XC_MGGA_X_TM , 1.00_fp ) call functional % add_functional ( XC_MGGA_C_TM , 1.00_fp ) case ( \"REVTM\" ) call functional % add_functional ( XC_MGGA_X_REVTM , 1.00_fp ) call functional % add_functional ( XC_MGGA_C_REVTM , 1.00_fp ) case ( \"REGTM\" ) call functional % add_functional ( XC_MGGA_X_REGTM , 1.00_fp ) call functional % add_functional ( XC_MGGA_C_TM , 1.00_fp ) case ( \"RREGTM\" ) call functional % add_functional ( XC_MGGA_X_REGTM , 1.00_fp ) call functional % add_functional ( XC_MGGA_C_RREGTM , 1.00_fp ) case ( \"MGGAC\" ) call functional % add_functional ( XC_MGGA_X_MGGAC , 1.00_fp ) call functional % add_functional ( XC_GGA_C_MGGAC , 1.00_fp ) case ( \"RMGGAC\" ) call functional % add_functional ( XC_MGGA_X_MGGAC , 1.00_fp ) call functional % add_functional ( XC_MGGA_C_RMGGAC , 1.00_fp ) case ( \"TAUHCTH\" , \"THCTH\" ) call functional % add_functional ( XC_MGGA_X_TAU_HCTH , 1.00_fp ) call functional % add_functional ( XC_GGA_C_TAU_HCTH , 1.00_fp ) case ( \"VSXC\" ) call functional % add_functional ( XC_MGGA_X_GVT4 , 1.00_fp ) call functional % add_functional ( XC_MGGA_C_VSXC , 1.00_fp ) case ( \"TPSSLYP1W\" ) call functional % add_functional ( XC_MGGA_XC_TPSSLYP1W , 1.00_fp ) case ( \"M06-L\" , \"M06L\" ) call functional % add_functional ( XC_MGGA_X_M06_L , 1.00_fp ) call functional % add_functional ( XC_MGGA_C_M06_L , 1.00_fp ) case ( \"REVM06-L\" , \"REVM06L\" ) call functional % add_functional ( XC_MGGA_X_REVM06_L , 1.00_fp ) call functional % add_functional ( XC_MGGA_C_REVM06_L , 1.00_fp ) case ( \"M11-L\" , \"M11L\" ) dft_params % cam_flag = . true . call functional % add_functional ( XC_MGGA_X_M11_L , 1.00_fp , & alpha = dft_params % cam_alpha , & beta = dft_params % cam_beta , & omega = dft_params % cam_mu ) call functional % add_functional ( XC_MGGA_C_M11_L , 1.00_fp ) case ( \"MN12-L\" , \"MN12L\" ) call functional % add_functional ( XC_MGGA_X_MN12_L , 1.00_fp ) call functional % add_functional ( XC_MGGA_C_MN12_L , 1.00_fp ) case ( \"MN15-L\" , \"MN15L\" ) call functional % add_functional ( XC_MGGA_X_MN15_L , 1.00_fp ) call functional % add_functional ( XC_MGGA_C_MN15_L , 1.00_fp ) case ( \"HLE17\" ) call functional % add_functional ( XC_MGGA_XC_HLE17 , 1.00_fp ) case ( \"HLTA\" ) call functional % add_functional ( XC_MGGA_X_HLTA , 1.00_fp ) call functional % add_functional ( XC_MGGA_C_HLTAPW , 1.00_fp ) case ( \"LDA0\" ) call functional % add_functional ( XC_HYB_LDA_XC_LDA0 , 1.00_fp , hfex = HFEX ) !LDA0_hXC case ( \"CAM-LDA0\" ) ! The energy of He in 3-21G basis set looks OK (-2.8529482409) dft_params % cam_flag = . true . call functional % add_functional ( XC_HYB_LDA_XC_CAM_LDA0 , 1.00_fp , & alpha = dft_params % cam_alpha , & beta = dft_params % cam_beta , & omega = dft_params % cam_mu ) !CAM-LDA0_hXC case ( \"APF\" ) call functional % add_functional ( XC_HYB_GGA_XC_APF , 1.00_fp , hfex = HFEX ) case ( \"B1WC\" ) call functional % add_functional ( XC_HYB_GGA_XC_B1WC , 1.00_fp , hfex = HFEX ) case ( \"PBE0\" , \"PBE-25\" , \"PBE1PBE\" ) call functional % add_functional ( XC_HYB_GGA_XC_PBEH , 1.00_fp , hfex = HFEX ) case ( \"PBE-33\" ) call functional % add_functional ( XC_HYB_GGA_XC_PBE0_13 , 1.00_fp , hfex = HFEX ) case ( \"PBE-38\" , \"PBE-3/8\" ) call functional % add_functional ( XC_HYB_GGA_XC_PBE38 , 1.00_fp , hfex = HFEX ) case ( \"PBE-50\" ) call functional % add_functional ( XC_HYB_GGA_XC_PBE50 , 1.00_fp , hfex = HFEX ) case ( \"PBE-2X\" ) call functional % add_functional ( XC_HYB_GGA_XC_PBE_2X , 1.00_fp , hfex = HFEX ) case ( \"PBE-3X\" ) HFEX = 0.84_fp call functional % add_functional ( XC_GGA_X_PBE , 0.16_fp ) !PBE_X call functional % add_functional ( XC_GGA_C_PBE , 1.00_fp ) !PBE_C case ( \"BHH\" ) call functional % add_functional ( XC_HYB_GGA_XC_BHANDH , 1.00_fp , hfex = HFEX ) case ( \"B1PW91\" ) call functional % add_functional ( XC_HYB_GGA_XC_B1PW91 , 1.00_fp , hfex = HFEX ) case ( \"B3PW91\" ) call functional % add_functional ( XC_HYB_GGA_XC_B3PW91 , 1.00_fp , hfex = HFEX ) case ( \"BLYP35\" ) call functional % add_functional ( XC_HYB_GGA_XC_BLYP35 , 1.00_fp , hfex = HFEX ) case ( \"B1LYP\" ) call functional % add_functional ( XC_HYB_GGA_XC_B1LYP , 1.00_fp , hfex = HFEX ) case ( \"BHHLYP\" ) call functional % add_functional ( XC_HYB_GGA_XC_BHANDHLYP , 1.00_fp , hfex = HFEX ) case ( \"STG1X\" ) call functional % add_functional ( XC_HYB_GGA_XC_BHANDHLYP , 1.00_fp , hfex = HFEX ) hfex = 0.85 tddft_params % spc_coco = 0.5_fp tddft_params % spc_ovov = 0.5_fp tddft_params % spc_coov = 0.5_fp write ( * , fmt = '(a)' ) \"STG1X = B(0.15)HF(0.85)-LYP functional\" write ( * , fmt = '(3a)' ) \"[3] Y. Horbatenko, S. Lee, M. Filatov, and C. H. Choi, \" , & \"J. Phys. Chem. A, 123, 7991-8000 (2019); \" , & \"DOI: 10.1021/acs.jpca.9b07556\" case ( \"B3LYP\" ) call show_message ( \"B3LYP functional has different meanings,\" ) call show_message ( \"so that it can not be run using LibXC interface.\" ) call show_message ( \"For running B3LYP, choose one of them:\" ) call show_message ( \" - B3LYPV1R with  VWN RPA LDA correlation part (default for Gaussian)\" ) call show_message ( \" - B3LYPV3  with  VWN_3   LDA correlation part\" ) call show_message ( \" - B3LYPV5  with  VWN_5   LDA correlation part (default for GAMESS-US)\" ) call show_message ( ABORTING , WITH_ABORT ) case ( \"B3LYPV1R\" ) call functional % add_functional ( XC_HYB_GGA_XC_B3LYP , 1.00_fp , hfex = HFEX ) case ( \"B3LYPV3\" ) call functional % add_functional ( XC_HYB_GGA_XC_B3LYP3 , 1.00_fp , hfex = HFEX ) case ( \"B3LYPV5\" , \"B3LYP5\" ) call functional % add_functional ( XC_HYB_GGA_XC_B3LYP5 , 1.00_fp , hfex = HFEX ) case ( \"O3LYP\" ) call functional % add_functional ( XC_HYB_GGA_XC_O3LYP , 1.00_fp , hfex = HFEX ) case ( \"X3LYP\" ) call functional % add_functional ( XC_HYB_GGA_XC_X3LYP , 1.00_fp , hfex = HFEX ) case ( \"REVB3LYP\" ) call functional % add_functional ( XC_HYB_GGA_XC_REVB3LYP , 1.00_fp , hfex = HFEX ) case ( \"B3LYP*\" , \"B3LYPS\" ) call functional % add_functional ( XC_HYB_GGA_XC_B3LYPs , 1.00_fp , hfex = HFEX ) case ( \"B50LYP\" , \"B5050LYP\" ) call functional % add_functional ( XC_HYB_GGA_XC_B5050LYP , 1.00_fp , hfex = HFEX ) case ( \"KMLYP\" ) call functional % add_functional ( XC_HYB_GGA_XC_KMLYP , 1.00_fp , hfex = HFEX ) case ( \"CASE21\" ) call functional % add_functional ( XC_HYB_GGA_XC_CASE21 , 1.00_fp , hfex = HFEX ) case ( \"B97-1P\" ) call functional % add_functional ( XC_HYB_GGA_XC_B97_1p , 1.00_fp , hfex = HFEX ) case ( \"B97\" ) call functional % add_functional ( XC_HYB_GGA_XC_B97 , 1.00_fp , hfex = HFEX ) case ( \"B97-1\" ) call functional % add_functional ( XC_HYB_GGA_XC_B97_1 , 1.00_fp , hfex = HFEX ) case ( \"B97-2\" ) call functional % add_functional ( XC_HYB_GGA_XC_B97_2 , 1.00_fp , hfex = HFEX ) case ( \"B97-3\" ) call functional % add_functional ( XC_HYB_GGA_XC_B97_3 , 1.00_fp , hfex = HFEX ) case ( \"B97-K\" ) call functional % add_functional ( XC_HYB_GGA_XC_B97_K , 1.00_fp , hfex = HFEX ) case ( \"MPWLYP1M\" ) call functional % add_functional ( XC_HYB_GGA_XC_MPWLYP1M , 1.00_fp , hfex = HFEX ) case ( \"MPW1K\" ) call functional % add_functional ( XC_HYB_GGA_XC_MPW1K , 1.00_fp , hfex = HFEX ) case ( \"MPW1PBE\" ) call functional % add_functional ( XC_HYB_GGA_XC_MPW1PBE , 1.00_fp , hfex = HFEX ) case ( \"MPW1PW\" , \"MPW1PW91\" ) call functional % add_functional ( XC_HYB_GGA_XC_MPW1PW , 1.00_fp , hfex = HFEX ) case ( \"MPW1LYP\" ) call functional % add_functional ( XC_HYB_GGA_XC_MPW1LYP , 1.00_fp , hfex = HFEX ) case ( \"MPW3PW\" , \"MPW3PW91\" ) call functional % add_functional ( XC_HYB_GGA_XC_MPW3PW , 1.00_fp , hfex = HFEX ) case ( \"MPW3LYP\" ) call functional % add_functional ( XC_HYB_GGA_XC_MPW3LYP , 1.00_fp , hfex = HFEX ) case ( \"SOGGA11-X\" , \"SOGGA11X\" ) call functional % add_functional ( XC_HYB_GGA_X_SOGGA11_X , 1.00_fp , hfex = HFEX ) call functional % add_functional ( XC_GGA_C_SOGGA11_X , 1.00_fp ) case ( \"QTP17\" ) call functional % add_functional ( XC_HYB_GGA_XC_QTP17 , 1.00_fp , hfex = HFEX ) case ( \"EDF2\" ) call functional % add_functional ( XC_HYB_GGA_XC_EDF2 , 1.00_fp , hfex = HFEX ) case ( \"HPBEINT\" ) call functional % add_functional ( XC_HYB_GGA_XC_HPBEINT , 1.00_fp , hfex = HFEX ) case ( \"CAP0\" ) call functional % add_functional ( XC_HYB_GGA_XC_CAP0 , 1.00_fp , hfex = HFEX ) case ( \"WC04\" ) call functional % add_functional ( XC_HYB_GGA_XC_WC04 , 1.00_fp , hfex = HFEX ) case ( \"WP04\" ) call functional % add_functional ( XC_HYB_GGA_XC_WP04 , 1.00_fp , hfex = HFEX ) case ( \"WB97\" ) dft_params % cam_flag = . true . call functional % add_functional ( XC_HYB_GGA_XC_WB97 , 1.00_fp , & alpha = dft_params % cam_alpha , & beta = dft_params % cam_beta , & omega = dft_params % cam_mu ) case ( \"WB97X\" ) dft_params % cam_flag = . true . call functional % add_functional ( XC_HYB_GGA_XC_WB97X , 1.00_fp , & alpha = dft_params % cam_alpha , & beta = dft_params % cam_beta , & omega = dft_params % cam_mu ) case ( \"WB97X-D\" ) dft_params % cam_flag = . true . call functional % add_functional ( XC_HYB_GGA_XC_WB97X_D , 1.00_fp , & alpha = dft_params % cam_alpha , & beta = dft_params % cam_beta , & omega = dft_params % cam_mu ) case ( \"HSE03\" ) dft_params % cam_flag = . true . call functional % add_functional ( XC_HYB_GGA_XC_HSE03 , 1.00_fp , & alpha = dft_params % cam_alpha , & beta = dft_params % cam_beta , & omega = dft_params % cam_mu ) case ( \"HSE06\" ) dft_params % cam_flag = . true . call functional % add_functional ( XC_HYB_GGA_XC_HSE06 , 1.00_fp , & alpha = dft_params % cam_alpha , & beta = dft_params % cam_beta , & omega = dft_params % cam_mu ) case ( \"HSE12\" ) dft_params % cam_flag = . true . call functional % add_functional ( XC_HYB_GGA_XC_HSE12 , 1.00_fp , & alpha = dft_params % cam_alpha , & beta = dft_params % cam_beta , & omega = dft_params % cam_mu ) case ( \"HSE12-S\" ) dft_params % cam_flag = . true . call functional % add_functional ( XC_HYB_GGA_XC_HSE12S , 1.00_fp , & alpha = dft_params % cam_alpha , & beta = dft_params % cam_beta , & omega = dft_params % cam_mu ) case ( \"HSESOL\" ) dft_params % cam_flag = . true . call functional % add_functional ( XC_HYB_GGA_XC_HSE_SOL , 1.00_fp , & alpha = dft_params % cam_alpha , & beta = dft_params % cam_beta , & omega = dft_params % cam_mu ) case ( \"MCAM-B3LYP\" , \"MCAMB3LYP\" ) dft_params % cam_flag = . true . call functional % add_functional ( XC_HYB_GGA_XC_MCAM_B3LYP , 1.00_fp , & alpha = dft_params % cam_alpha , & beta = dft_params % cam_beta , & omega = dft_params % cam_mu ) case ( \"CAM-B3LYP\" , \"CAMB3LYP\" ) dft_params % cam_flag = . true . call functional % add_functional ( XC_HYB_GGA_XC_CAM_B3LYP , 1.00_fp , & alpha = dft_params % cam_alpha , & beta = dft_params % cam_beta , & omega = dft_params % cam_mu ) case ( \"CAMH-B3LYP\" , \"CAMHB3LYP\" ) dft_params % cam_flag = . true . call functional % add_functional ( XC_HYB_GGA_XC_CAMH_B3LYP , 1.00_fp , & alpha = dft_params % cam_alpha , & beta = dft_params % cam_beta , & omega = dft_params % cam_mu ) case ( \"DTCAM-TUNE\" , \"CDTCAMTUNE\" ) ! Use to tune HF exchange in DFT and TDDFT dft_params % cam_flag = . true . call functional % add_functional ( XC_HYB_GGA_XC_TUNED_CAM_B3LYP , 1.00_fp , & external_parameters = ( / 0.81_fp , & dft_params % cam_alpha + dft_params % cam_beta , & - dft_params % cam_beta , & dft_params % cam_mu / ), & alpha = dft_params % cam_alpha , & beta = dft_params % cam_beta , & omega = dft_params % cam_mu ) write ( * , fmt = '(3a)' ) \"[2] W. Park, A. Lashkaripour, K. Komarov, S. Lee, M. Huix-Rotllant, \" , & \"and C. H. Choi, J. Chem. Theory Comput., 20(13), 5679-5694 (2024); \" , & \"DOI: 10.1021/acs.jctc.4c00640\" case ( \"DTCAM-VAEE\" , \"DTCAMVAEE\" ) ! see doi.org/10.1021/acs.jctc.4c00640 dft_params % cam_flag = . true . call functional % add_functional ( XC_HYB_GGA_XC_TUNED_CAM_B3LYP , 1.00_fp , & external_parameters = ( / 0.81_fp , 0.30_fp , 0.20_fp , 0.33_fp / ), & alpha = dft_params % cam_alpha , & ! = 0.50 beta = dft_params % cam_beta , & ! =-0.20 omega = dft_params % cam_mu ) ! = 0.33 tddft_params % cam_alpha = 0.5_fp tddft_params % cam_beta = - 0.1_fp tddft_params % cam_mu = dft_params % cam_mu tddft_params % spc_coco = 0.5_fp tddft_params % spc_ovov = 0.5_fp tddft_params % spc_coov = 0.5_fp write ( * , fmt = '(3a)' ) \"[2] W. Park, A. Lashkaripour, K. Komarov, S. Lee, M. Huix-Rotllant, \" , & \"and C. H. Choi, J. Chem. Theory Comput., 20(13), 5679-5694 (2024); \" , & \"DOI: 10.1021/acs.jctc.4c00640\" case ( \"DTCAM-XIV\" , \"DTCAMXIV\" ) ! see doi.org/10.1021/acs.jctc.4c00640 dft_params % cam_flag = . true . call functional % add_functional ( XC_HYB_GGA_XC_TUNED_CAM_B3LYP , 1.00_fp , & external_parameters = ( / 0.81_fp , 0.30_fp , 0.29_fp , 0.33_fp / ), & alpha = dft_params % cam_alpha , & ! = 0.59 beta = dft_params % cam_beta , & ! =-0.29 omega = dft_params % cam_mu ) ! = 0.33 tddft_params % cam_alpha = 0.50_fp tddft_params % cam_alpha = 0.10_fp tddft_params % cam_beta = 0.90_fp tddft_params % cam_mu = dft_params % cam_mu tddft_params % spc_coco = 0.50_fp tddft_params % spc_ovov = 0.50_fp tddft_params % spc_coov = 0.50_fp write ( * , fmt = '(3a)' ) \"[2] W. Park, A. Lashkaripour, K. Komarov, S. Lee, M. Huix-Rotllant, \" , & \"and C. H. Choi, J. Chem. Theory Comput., 20(13), 5679-5694 (2024); \" , & \"DOI: 10.1021/acs.jctc.4c00640\" case ( \"DTCAM-XI\" , \"DTCAMXI\" ) dft_params % cam_flag = . true . call functional % add_functional ( XC_HYB_GGA_XC_TUNED_CAM_B3LYP , 1.00_fp , & external_parameters = ( / 0.81_fp , 1.02_fp , - 0.52_fp , 0.33_fp / ), & alpha = dft_params % cam_alpha , & ! = 0.50 beta = dft_params % cam_beta , & ! = 0.52 omega = dft_params % cam_mu ) ! = 0.33 tddft_params % cam_alpha = 0.395_fp tddft_params % cam_beta = 0.425_fp tddft_params % cam_mu = dft_params % cam_mu tddft_params % spc_coco = 0.50_fp tddft_params % spc_ovov = 0.50_fp tddft_params % spc_coov = 0.50_fp write ( * , fmt = '(3a)' ) \"[2] W. Park, A. Lashkaripour, K. Komarov, S. Lee, M. Huix-Rotllant, \" , & \"and C. H. Choi, J. Chem. Theory Comput., ??, ?? (2024); \" , & \"DOI: 10.1021/acs.jctc.4c00640\" case ( \"DTCAM-AEE\" , \"DTCAMAEE\" ) dft_params % cam_flag = . true . call functional % add_functional ( XC_HYB_GGA_XC_TUNED_CAM_B3LYP , 1.00_fp , & external_parameters = ( / 0.81_fp , 0.48_fp , - 0.29_fp , 0.33_fp / ), & alpha = dft_params % cam_alpha , & ! = 0.19 beta = dft_params % cam_beta , & ! = 0.29 omega = dft_params % cam_mu ) ! = 0.33 tddft_params % cam_alpha = 0.15_fp tddft_params % cam_beta = 0.95_fp tddft_params % cam_mu = dft_params % cam_mu tddft_params % spc_coco = 0.50_fp tddft_params % spc_ovov = 0.50_fp tddft_params % spc_coov = 0.50_fp write ( * , fmt = '(3a)' ) \"[2] K. Komarov, W. Park, S. Lee, M. Huix-Rotllant, \" , & \"and C. H. Choi, J. Chem. Theory Comput., 19, 7671-7684 (2023); \" , & \"DOI: 10.1021/acs.jctc.3c00884\" case ( \"DTCAM-VEE\" , \"DTCAMVEE\" ) dft_params % cam_flag = . true . call functional % add_functional ( XC_HYB_GGA_XC_TUNED_CAM_B3LYP , 1.00_fp , & external_parameters = ( / 0.81_fp , 0.48_fp , - 0.29_fp , 0.33_fp / ), & alpha = dft_params % cam_alpha , & ! = 0.19 beta = dft_params % cam_beta , & ! = 0.29 omega = dft_params % cam_mu ) ! = 0.33 tddft_params % cam_alpha = 0.48_fp tddft_params % cam_beta = 0.00_fp tddft_params % cam_mu = dft_params % cam_mu tddft_params % spc_coco = 0.50_fp tddft_params % spc_ovov = 0.50_fp tddft_params % spc_coov = 0.50_fp write ( * , fmt = '(3a)' ) \"[2] K. Komarov, W. Park, S. Lee, M. Huix-Rotllant, \" , & \"and C. H. Choi, J. Chem. Theory Comput., 19, 7671-7684 (2023); \" , & \"DOI: 10.1021/acs.jctc.3c00884\" case ( \"DTCAM-STG\" , \"DTCAMSTG\" ) dft_params % cam_flag = . true . call functional % add_functional ( XC_HYB_GGA_XC_TUNED_CAM_B3LYP , 1.00_fp , & external_parameters = ( / 0.81_fp , 0.17_fp , 0.28_fp , 0.33_fp / ), & alpha = dft_params % cam_alpha , & ! = 0.45 beta = dft_params % cam_beta , & ! =-0.28 omega = dft_params % cam_mu ) ! = 0.33 tddft_params % cam_alpha = 0.64_fp tddft_params % cam_beta = - 0.11_fp tddft_params % cam_mu = 0.30_fp tddft_params % spc_coco = 0.43_fp tddft_params % spc_ovov = 0.44_fp tddft_params % spc_coov = 0.65_fp write ( * , fmt = '(3a)' ) \"[2] A. Lashkaripour, W. Park,  M. Mazaherifar \" , & \"and C. H. Choi, J. Chem. Theory Comput. 2025, 21, 11, 5661–5668; \" , & \"DOI: 10.1021/acs.jctc.5c00451\" case ( \"RCAM-B3LYP\" , \"RCAMB3LYP\" ) dft_params % cam_flag = . true . call functional % add_functional ( XC_HYB_GGA_XC_RCAM_B3LYP , 1.00_fp , & alpha = dft_params % cam_alpha , & beta = dft_params % cam_beta , & omega = dft_params % cam_mu ) case ( \"TUNCAM-B3LYP\" , \"TUNEDCAM-B3LYP\" ) dft_params % cam_flag = . true . call functional % add_functional ( XC_HYB_GGA_XC_TUNED_CAM_B3LYP , 1.00_fp , & alpha = dft_params % cam_alpha , & beta = dft_params % cam_beta , & omega = dft_params % cam_mu ) case ( \"CAM-QTP00\" , \"CAMQTP00\" , \"CAM-QTP(00)\" , \"CAM-QTP-00\" ) dft_params % cam_flag = . true . call functional % add_functional ( XC_HYB_GGA_XC_CAM_QTP_00 , 1.00_fp , & alpha = dft_params % cam_alpha , & beta = dft_params % cam_beta , & omega = dft_params % cam_mu ) case ( \"CAM-QTP01\" , \"CAMQTP01\" , \"CAM-QTP(01)\" , \"CAM-QTP-01\" ) dft_params % cam_flag = . true . call functional % add_functional ( XC_HYB_GGA_XC_CAM_QTP_01 , 1.00_fp , & alpha = dft_params % cam_alpha , & beta = dft_params % cam_beta , & omega = dft_params % cam_mu ) case ( \"CAM-QTP02\" , \"CAMQTP02\" , \"CAM-QTP(02)\" , \"CAM-QTP-02\" ) dft_params % cam_flag = . true . call functional % add_functional ( XC_HYB_GGA_XC_CAM_QTP_02 , 1.00_fp , & alpha = dft_params % cam_alpha , & beta = dft_params % cam_beta , & omega = dft_params % cam_mu ) case ( \"CAM-PBEH\" ) ! The energy of He in 3-21G basis set looks OK (-2.8610170571) dft_params % cam_flag = . true . call functional % add_functional ( XC_HYB_GGA_XC_CAM_PBEH , 1.00_fp , & alpha = dft_params % cam_alpha , & beta = dft_params % cam_beta , & omega = dft_params % cam_mu ) case ( \"LRC-WPBEH\" ) dft_params % cam_flag = . true . call functional % add_functional ( XC_HYB_GGA_XC_LRC_WPBEH , 1.00_fp , & alpha = dft_params % cam_alpha , & beta = dft_params % cam_beta , & omega = dft_params % cam_mu ) case ( \"LRC-WPBE\" ) dft_params % cam_flag = . true . call functional % add_functional ( XC_HYB_GGA_XC_LRC_WPBE , 1.00_fp , & alpha = dft_params % cam_alpha , & beta = dft_params % cam_beta , & omega = dft_params % cam_mu ) case ( \"LC-WPBE\" , \"LCWPBE\" ) dft_params % cam_flag = . true . call functional % add_functional ( XC_HYB_GGA_XC_LC_WPBE , 1.00_fp , & alpha = dft_params % cam_alpha , & beta = dft_params % cam_beta , & omega = dft_params % cam_mu ) case ( \"WHPBE0\" ) dft_params % cam_flag = . true . call functional % add_functional ( XC_HYB_GGA_XC_WHPBE0 , 1.00_fp , & alpha = dft_params % cam_alpha , & beta = dft_params % cam_beta , & omega = dft_params % cam_mu ) case ( \"N12-SX\" , \"N12SX\" ) dft_params % cam_flag = . true . call functional % add_functional ( XC_HYB_GGA_X_N12_SX , 1.00_fp , & alpha = dft_params % cam_alpha , & beta = dft_params % cam_beta , & omega = dft_params % cam_mu ) call functional % add_functional ( XC_GGA_C_N12_SX , 1.00_fp ) case ( \"LC-QTP\" ) dft_params % cam_flag = . true . call functional % add_functional ( XC_HYB_GGA_XC_LC_QTP , 1.00_fp , & alpha = dft_params % cam_alpha , & beta = dft_params % cam_beta , & omega = dft_params % cam_mu ) case ( \"LC-BLYP\" ) dft_params % cam_flag = . true . call functional % add_functional ( XC_HYB_GGA_XC_LC_BLYP , 1.00_fp , & alpha = dft_params % cam_alpha , & beta = dft_params % cam_beta , & omega = dft_params % cam_mu ) case ( \"TPSSH\" ) call functional % add_functional ( XC_HYB_MGGA_XC_TPSSH , 1.00_fp , hfex = HFEX ) case ( \"TPSS0\" ) call functional % add_functional ( XC_HYB_MGGA_XC_TPSS0 , 1.00_fp , hfex = HFEX ) case ( \"REVTPSSH\" ) call functional % add_functional ( XC_HYB_MGGA_XC_REVTPSSH , 1.00_fp , hfex = HFEX ) case ( \"MS2H\" ) call functional % add_functional ( XC_HYB_MGGA_X_MS2H , 1.00_fp , hfex = HFEX ) call functional % add_functional ( XC_GGA_C_PBE , 1.00_fp ) case ( \"MVSH\" ) call functional % add_functional ( XC_HYB_MGGA_X_MVSH , 1.00_fp , hfex = HFEX ) call functional % add_functional ( XC_GGA_C_PBE , 1.00_fp ) case ( \"SCAN0\" ) call functional % add_functional ( XC_HYB_MGGA_X_SCAN0 , 1.00_fp , hfex = HFEX ) call functional % add_functional ( XC_MGGA_C_SCAN , 1.00_fp ) case ( \"REVSCAN0\" ) call functional % add_functional ( XC_HYB_MGGA_X_REVSCAN0 , 1.00_fp , hfex = HFEX ) call functional % add_functional ( XC_MGGA_C_REVSCAN , 1.00_fp ) case ( \"HYBTAUHCTH\" , \"HYBTHCTH\" , \"HYB-THCTH\" , \"HYB-TAUHCTH\" , \"THCTHHYB\" , \"TAUHCTHHYB\" ) call functional % add_functional ( XC_HYB_MGGA_X_TAU_HCTH , 1.00_fp , hfex = HFEX ) call functional % add_functional ( XC_GGA_C_HYB_TAU_HCTH , 1.00_fp ) case ( \"BMK\" ) call functional % add_functional ( XC_HYB_MGGA_X_BMK , 1.00_fp , hfex = HFEX ) call functional % add_functional ( XC_GGA_C_BMK , 1.00_fp ) case ( \"DLDF\" ) call functional % add_functional ( XC_HYB_MGGA_X_DLDF , 1.00_fp , hfex = HFEX ) call functional % add_functional ( XC_MGGA_C_DLDF , 1.00_fp ) case ( \"M05\" ) call functional % add_functional ( XC_HYB_MGGA_X_M05 , 1.00_fp , hfex = HFEX ) call functional % add_functional ( XC_MGGA_C_M05 , 1.00_fp ) case ( \"M05-2X\" , \"M052X\" ) call functional % add_functional ( XC_HYB_MGGA_X_M05_2X , 1.00_fp , hfex = HFEX ) call functional % add_functional ( XC_MGGA_C_M05_2X , 1.00_fp ) case ( \"M06\" ) call functional % add_functional ( XC_HYB_MGGA_X_M06 , 1.00_fp , hfex = HFEX ) call functional % add_functional ( XC_MGGA_C_M06 , 1.00_fp ) case ( \"REVM06\" ) call functional % add_functional ( XC_HYB_MGGA_X_REVM06 , 1.00_fp , hfex = HFEX ) call functional % add_functional ( XC_MGGA_C_REVM06 , 1.00_fp ) case ( \"M06-2X\" , \"M062X\" ) call functional % add_functional ( XC_HYB_MGGA_X_M06_2X , 1.00_fp , hfex = HFEX ) call functional % add_functional ( XC_MGGA_C_M06_2X , 1.00_fp ) case ( \"M06-HF\" , \"M06HF\" ) call functional % add_functional ( XC_HYB_MGGA_X_M06_HF , 1.00_fp , hfex = HFEX ) call functional % add_functional ( XC_MGGA_C_M06_HF , 1.00_fp ) case ( \"M08-SO\" ) call functional % add_functional ( XC_HYB_MGGA_X_M08_SO , 1.00_fp , hfex = HFEX ) call functional % add_functional ( XC_MGGA_C_M08_SO , 1.00_fp ) case ( \"M08-HX\" ) call functional % add_functional ( XC_HYB_MGGA_X_M08_HX , 1.00_fp , hfex = HFEX ) call functional % add_functional ( XC_MGGA_C_M08_HX , 1.00_fp ) case ( \"MN15\" ) call functional % add_functional ( XC_HYB_MGGA_X_MN15 , 1.00_fp , hfex = HFEX ) call functional % add_functional ( XC_MGGA_C_MN15 , 1.00_fp ) case ( \"PW86BC95\" , \"PW86B95\" ) call functional % add_functional ( XC_HYB_MGGA_XC_PW86B95 , 1.00_fp , hfex = HFEX ) case ( \"BB1K\" ) call functional % add_functional ( XC_HYB_MGGA_XC_BB1K , 1.00_fp , hfex = HFEX ) case ( \"MPW1BC95\" , \"MPW1B95\" ) call functional % add_functional ( XC_HYB_MGGA_XC_MPW1B95 , 1.00_fp , hfex = HFEX ) case ( \"MPW1B1K\" ) call functional % add_functional ( XC_HYB_MGGA_XC_MPWB1K , 1.00_fp , hfex = HFEX ) case ( \"PW6BC95\" , \"PW6B95\" ) call functional % add_functional ( XC_HYB_MGGA_XC_PW6B95 , 1.00_fp , hfex = HFEX ) case ( \"PWB6K\" ) call functional % add_functional ( XC_HYB_MGGA_XC_PWB6K , 1.00_fp , hfex = HFEX ) case ( \"MPW1KCIS\" ) call functional % add_functional ( XC_HYB_MGGA_XC_MPW1KCIS , 1.00_fp , hfex = HFEX ) case ( \"MPWKCIS1K\" ) call functional % add_functional ( XC_HYB_MGGA_XC_MPWKCIS1K , 1.00_fp , hfex = HFEX ) case ( \"B0KCIS\" ) call functional % add_functional ( XC_HYB_MGGA_XC_B0KCIS , 1.00_fp , hfex = HFEX ) case ( \"PBE1KCIS\" ) call functional % add_functional ( XC_HYB_MGGA_XC_PBE1KCIS , 1.00_fp , hfex = HFEX ) case ( \"TPSS1KCIS\" ) call functional % add_functional ( XC_HYB_MGGA_XC_TPSS1KCIS , 1.00_fp , hfex = HFEX ) case ( \"X1BC95\" , \"X1B95\" ) call functional % add_functional ( XC_HYB_MGGA_XC_X1B95 , 1.00_fp , hfex = HFEX ) case ( \"XB1K\" ) call functional % add_functional ( XC_HYB_MGGA_XC_XB1K , 1.00_fp , hfex = HFEX ) case ( \"B88BC95\" , \"BBC95\" , \"B88B95\" , \"BB95\" ) call functional % add_functional ( XC_HYB_MGGA_XC_B88B95 , 1.00_fp , hfex = HFEX ) case ( \"B86BC95\" , \"B86B95\" ) call functional % add_functional ( XC_HYB_MGGA_XC_B86B95 , 1.00_fp , hfex = HFEX ) case ( \"M06-SX\" , \"M06SX\" ) dft_params % cam_flag = . true . call functional % add_functional ( XC_HYB_MGGA_X_M06_SX , 1.00_fp , & alpha = dft_params % cam_alpha , & beta = dft_params % cam_beta , & omega = dft_params % cam_mu ) call functional % add_functional ( XC_MGGA_C_M06_SX , 1.00_fp ) case ( \"M11\" ) dft_params % cam_flag = . true . call functional % add_functional ( XC_HYB_MGGA_X_M11 , 1.00_fp , & alpha = dft_params % cam_alpha , & beta = dft_params % cam_beta , & omega = dft_params % cam_mu ) call functional % add_functional ( XC_MGGA_C_M11 , 1.00_fp ) case ( \"REVM11\" ) dft_params % cam_flag = . true . call functional % add_functional ( XC_HYB_MGGA_X_REVM11 , 1.00_fp , & alpha = dft_params % cam_alpha , & beta = dft_params % cam_beta , & omega = dft_params % cam_mu ) call functional % add_functional ( XC_MGGA_C_REVM11 , 1.00_fp ) case ( \"MN12-SX\" , \"MN12SX\" ) dft_params % cam_flag = . true . call functional % add_functional ( XC_HYB_MGGA_X_MN12_SX , 1.00_fp , & alpha = dft_params % cam_alpha , & beta = dft_params % cam_beta , & omega = dft_params % cam_mu ) call functional % add_functional ( XC_MGGA_C_MN12_SX , 1.00_fp ) case ( \"PBE0-DH\" ) dft_params % dh_flag = . true . HFEX = 0.5_fp MP2 = 0.128_fp chf = HFEX c2same = MP2 c2opp = MP2 call functional % add_functional ( XC_GGA_X_PBE , 1.00_fp - HFEX ) call functional % add_functional ( XC_GGA_C_PBE , 1.00_fp - MP2 ) case ( \"TPSS0-DH\" ) dft_params % dh_flag = . true . HFEX = 0.5_fp MP2 = 0.128_fp chf = HFEX c2same = MP2 c2opp = MP2 call functional % add_functional ( XC_MGGA_X_TPSS , 1.00_fp - HFEX ) call functional % add_functional ( XC_MGGA_C_TPSS , 1.00_fp - MP2 ) case ( \"SCAN0-DH\" ) dft_params % dh_flag = . true . HFEX = 0.5_fp MP2 = 0.128_fp chf = HFEX c2same = MP2 c2opp = MP2 call functional % add_functional ( XC_MGGA_X_SCAN , 1.00_fp - HFEX ) call functional % add_functional ( XC_MGGA_C_SCAN , 1.00_fp - MP2 ) case ( \"PBE-QIDH\" ) dft_params % dh_flag = . true . HFEX = 0.693391_fp MP2 = 0.128_fp chf = HFEX c2same = MP2 c2opp = MP2 call functional % add_functional ( XC_GGA_X_PBE , 1.00_fp - HFEX ) call functional % add_functional ( XC_GGA_C_PBE , 1.00_fp - MP2 ) case ( \"TPSS-QIDH\" ) dft_params % dh_flag = . true . HFEX = 0.693391_fp MP2 = 0.128_fp chf = HFEX c2same = MP2 c2opp = MP2 call functional % add_functional ( XC_MGGA_X_TPSS , 1.00_fp - HFEX ) call functional % add_functional ( XC_MGGA_C_TPSS , 1.00_fp - MP2 ) case ( \"SCAN-QIDH\" ) dft_params % dh_flag = . true . HFEX = 0.693391_fp MP2 = 0.128_fp chf = HFEX c2same = MP2 c2opp = MP2 call functional % add_functional ( XC_MGGA_X_SCAN , 1.00_fp - HFEX ) call functional % add_functional ( XC_MGGA_C_SCAN , 1.00_fp - MP2 ) case ( \"PBE0-2\" ) dft_params % dh_flag = . true . HFEX = 0.793701_fp MP2 = 0.5_fp chf = HFEX c2same = MP2 c2opp = MP2 call functional % add_functional ( XC_GGA_X_PBE , 1.00_fp - HFEX ) call functional % add_functional ( XC_GGA_C_PBE , 1.00_fp - MP2 ) case ( \"TPSS0-2\" ) dft_params % dh_flag = . true . HFEX = 0.793701_fp MP2 = 0.5_fp chf = HFEX c2same = MP2 c2opp = MP2 call functional % add_functional ( XC_MGGA_X_TPSS , 1.00_fp - HFEX ) call functional % add_functional ( XC_MGGA_C_TPSS , 1.00_fp - MP2 ) case ( \"SCAN0-2\" ) dft_params % dh_flag = . true . HFEX = 0.793701_fp MP2 = 0.5_fp chf = HFEX c2same = MP2 c2opp = MP2 call functional % add_functional ( XC_MGGA_X_SCAN , 1.00_fp - HFEX ) call functional % add_functional ( XC_MGGA_C_SCAN , 1.00_fp - MP2 ) case ( \"B2-PLYP\" , \"B2PLYP\" ) dft_params % dh_flag = . true . HFEX = 0.53_fp MP2 = 0.27_fp chf = HFEX c2same = MP2 c2opp = MP2 call functional % add_functional ( XC_GGA_X_B88 , 1.00_fp - HFEX ) !Becke88 call functional % add_functional ( XC_GGA_C_LYP , 1.00_fp - MP2 ) !Lee-Yang-Parr case ( \"B2GP-PLYP\" , \"B2GPPLYP\" ) dft_params % dh_flag = . true . HFEX = 0.65_fp MP2 = 0.36_fp chf = HFEX c2same = MP2 c2opp = MP2 call functional % add_functional ( XC_GGA_X_B88 , 1.00_fp - HFEX ) !Becke88 call functional % add_functional ( XC_GGA_C_LYP , 1.00_fp - MP2 ) !Lee-Yang-Parr case ( \"B2T-PLYP\" , \"B2TPLYP\" ) dft_params % dh_flag = . true . HFEX = 0.60_fp MP2 = 0.31_fp chf = HFEX c2same = MP2 c2opp = MP2 call functional % add_functional ( XC_GGA_X_B88 , 1.00_fp - HFEX ) !Becke88 call functional % add_functional ( XC_GGA_C_LYP , 1.00_fp - MP2 ) !Lee-Yang-Parr case ( \"B2K-PLYP\" , \"B2KPLYP\" ) dft_params % dh_flag = . true . HFEX = 0.42_fp MP2 = 0.72_fp chf = HFEX c2same = MP2 c2opp = MP2 call functional % add_functional ( XC_GGA_X_B88 , 1.00_fp - HFEX ) !Becke88 call functional % add_functional ( XC_GGA_C_LYP , 1.00_fp - MP2 ) !Lee-Yang-Parr case ( \"MPW2-PLYP\" , \"MPW2PLYP\" ) dft_params % dh_flag = . true . HFEX = 0.53_fp MP2 = 0.27_fp chf = HFEX c2same = MP2 c2opp = MP2 call functional % add_functional ( XC_GGA_X_MPW91 , 1.00_fp - HFEX ) !mPW91 call functional % add_functional ( XC_GGA_C_LYP , 1.00_fp - MP2 ) !Lee-Yang-Parr case ( \"MPWK-PLYP\" , \"MPWKPLYP\" ) dft_params % dh_flag = . true . HFEX = 0.42_fp MP2 = 0.72_fp chf = HFEX c2same = MP2 c2opp = MP2 call functional % add_functional ( XC_GGA_X_MPW91 , 1.00_fp - HFEX ) !mPW91 call functional % add_functional ( XC_GGA_C_LYP , 1.00_fp - MP2 ) !Lee-Yang-Parr case default !It will be good, if someone write procedure for parsing of functional names, like PBE-1-PBE or PBE-0 or S+PBE-3-LYP+VWN-RPA call show_message ( \"Unrecognized functional name: \" // funcname ) call show_message ( \"Please, check the documentation about this functional or\" ) call show_message ( \" implement it to LibXC [https://gitlab.com/libxc/libxc],\" ) call show_message ( \"   and, then, to OQP-LibXC interface\" ) call show_message ( ABORTING , WITH_ABORT ) end select ! No one of functionals was not selected if (. not . functional % can_calculate () . and . funcname /= \"HFEX\" ) then call show_message ( \"No one functional was not selected!\" ) call show_message ( \"Please, check the input!\" ) call show_message ( ABORTING , WITH_ABORT ) end if dft_params % HFScale = HFEX dft_params % MP2SS_Scale = c2opp dft_params % MP2OS_Scale = c2same ! Print information about non-local part of functionals call show_message ( \" \" ) if (. not . dft_params % cam_flag ) then call show_message ( \"(A,ES16.8E2)\" , \"The global hybrid part:                \" , dft_params % HFScale ) else call show_message ( \"CAM-corrected functional is called\" ) call show_message ( \"Yanai's notation of CAM parameters is used\" ) call show_message ( \"(A,ES16.8E2)\" , \"The global hybrid part:                \" , dft_params % cam_alpha ) call show_message ( \"(A,ES16.8E2)\" , \"Additional long-range hybrid part:     \" , dft_params % cam_beta ) call show_message ( \"(A,ES16.8E2)\" , \"Range-saparated factor:                \" , dft_params % cam_mu ) end if if ( dft_params % dh_flag ) then call show_message ( \" \" ) call show_message ( \"Double-hybrid functional is called\" ) call show_message ( \"(A,ES16.8E2)\" , \"Same-spin MP2 correlation factor:      \" , dft_params % MP2SS_Scale ) call show_message ( \"(A,ES16.8E2)\" , \"Opposite-spin MP2 correlation factor:  \" , dft_params % MP2OS_Scale ) end if call show_message ( \" \" ) end subroutine libxc_input ! !> @brief  Destroy internal variables of functional !> @author Igor S. Gerasimov !> @date   Dec, 2020 - Initial release - !> @date   Dec, 2022 Pass local functional instead of global subroutine libxc_destroy ( functional ) type ( functional_t ), intent ( inout ) :: functional call functional % destroy end subroutine libxc_destroy end module libxc","tags":"","url":"sourcefile/libxc.f90.html"},{"title":"guess_minao.F90 – OpenQP Fortran API","text":"Source Code module guess_minao_mod implicit none character ( len =* ), parameter :: module_name = \"guess_minao_mod\" contains subroutine guess_minao_C ( c_handle ) bind ( C , name = \"guess_minao\" ) use c_interop , only : oqp_handle_t , oqp_handle_get_info use types , only : information type ( oqp_handle_t ) :: c_handle type ( information ), pointer :: inf inf => oqp_handle_get_info ( c_handle ) call guess_minao ( inf ) end subroutine guess_minao_C subroutine guess_minao ( infos ) use precision , only : dp use types , only : information use io_constants , only : IW use oqp_tagarray_driver use basis_tools , only : basis_set use guess , only : get_ab_initio_density use mathlib , only : unpack_matrix use qmat_cache , only : get_qmat_cached use eigen , only : diag_symm_full use util , only : measure_time use messages , only : show_message , WITH_ABORT use printing , only : print_module_info use parallel , only : par_env_t use iso_c_binding , only : c_char use constants , only : tol_int use int1 , only : basis_overlap use minao_lut , only : minao_table_t implicit none character ( len =* ), parameter :: subroutine_name = \"guess_minao\" type ( information ), target , intent ( inout ) :: infos integer :: nbf , nbf2 , nbf_min , ok , i , j , ish , iat , z , a0 , m integer :: bar type ( basis_set ), pointer :: basis type ( basis_set ) :: min_basis type ( minao_table_t ) :: minao character ( len = :), allocatable :: paths , basis_file , data_file logical :: err integer , parameter :: root = 0 type ( par_env_t ) :: pe real ( kind = dp ), allocatable :: dmin (:,:), sco (:,:), qmat (:,:), sfull (:,:) real ( kind = dp ), allocatable :: pmat (:,:), dt (:,:), tmpmn (:,:) real ( kind = dp ), allocatable :: wrk (:,:), occ (:), cno (:,:) integer , allocatable :: at_ao0 (:), at_nao (:) real ( kind = dp ), contiguous , pointer :: & Smat (:), & dmat_a (:), mo_a (:,:), mo_energy_a (:), & dmat_b (:), mo_b (:,:), mo_energy_b (:) character ( len =* ), parameter :: tags_alpha ( 3 ) = ( / character ( len = 80 ) :: & OQP_DM_A , OQP_E_MO_A , OQP_VEC_MO_A / ) character ( len =* ), parameter :: tags_beta ( 3 ) = ( / character ( len = 80 ) :: & OQP_DM_B , OQP_E_MO_B , OQP_VEC_MO_B / ) character ( len =* ), parameter :: tags_general ( 2 ) = ( / character ( len = 80 ) :: & OQP_SM , OQP_hbasis_filename / ) character ( len = 1 , kind = c_char ), contiguous , pointer :: cfn (:) open ( unit = IW , file = infos % log_filename , position = \"append\" ) call print_module_info ( 'Guess_MINAO' , & 'Initial guess using projected atomic minimal-basis densities' ) call pe % init ( infos % mpiinfo % comm , infos % mpiinfo % usempi ) ! Resolve the two paths (\"basisfile|datafile\") passed from Python call data_has_tags ( infos % dat , tags_general , module_name , subroutine_name , WITH_ABORT ) call tagarray_get_data ( infos % dat , OQP_hbasis_filename , cfn ) allocate ( character ( ubound ( cfn , 1 )) :: paths ) do i = 1 , ubound ( cfn , 1 ) paths ( i : i ) = cfn ( i ) end do bar = index ( paths , '|' ) if ( bar <= 0 ) call show_message ( 'Guess_MINAO: bad path spec' , WITH_ABORT ) basis_file = paths ( 1 : bar - 1 ) data_file = paths ( bar + 1 : len ( paths )) ! Load the minimal reference basis and the atomic-density table call min_basis % from_file ( basis_file , infos % atoms , err ) infos % control % basis_set_issue = err call pe % bcast ( infos % control % basis_set_issue , 1 ) if ( err ) call show_message ( 'Guess_MINAO: cannot read minimal basis ' // trim ( basis_file ), WITH_ABORT ) min_basis % atoms => infos % atoms call minao % load ( data_file , err ) if ( err ) call show_message ( 'Guess_MINAO: cannot read MINAO data ' // trim ( data_file ), WITH_ABORT ) basis => infos % basis basis % atoms => infos % atoms nbf = basis % nbf nbf2 = nbf * ( nbf + 1 ) / 2 nbf_min = min_basis % nbf ! Per-atom AO ranges in the minimal basis allocate ( at_ao0 ( infos % mol_prop % natom ), at_nao ( infos % mol_prop % natom ), source = 0 ) do ish = 1 , min_basis % nshell iat = min_basis % origin ( ish ) if ( at_nao ( iat ) == 0 ) at_ao0 ( iat ) = min_basis % ao_offset ( ish ) at_nao ( iat ) = at_nao ( iat ) + min_basis % naos ( ish ) end do ! Assemble block-diagonal minimal-basis density D_min allocate ( dmin ( nbf_min , nbf_min ), source = 0.0_dp ) do iat = 1 , infos % mol_prop % natom z = nint ( infos % atoms % zn ( iat )) if ( z < 1 ) cycle if ( z > minao % zmax ) & call show_message ( 'Guess_MINAO: element beyond tabulated range (Z<=36)' , WITH_ABORT ) if ( minao % elem ( z )% nao /= at_nao ( iat )) & call show_message ( 'Guess_MINAO: minimal-basis size mismatch for atom' , WITH_ABORT ) a0 = at_ao0 ( iat ) m = at_nao ( iat ) dmin ( a0 : a0 + m - 1 , a0 : a0 + m - 1 ) = minao % elem ( z )% dm end do ! Cross-overlap between minimal and target basis, bfnrm-scaled (as proj_dm_newbas) allocate ( sco ( nbf_min , nbf )) call basis_overlap ( sco , basis , min_basis , tol = log ( 1 0.0d0 ) * tol_int ) do i = 1 , nbf sco (:, i ) = sco (:, i ) * basis % bfnrm ( i ) * min_basis % bfnrm (:) end do ! tagarray records call tagarray_get_data ( infos % dat , OQP_SM , smat ) call infos % dat % alloc_or_die ( OQP_DM_A , ( / nbf2 / ), dmat_a , description = OQP_DM_A_comment ) call infos % dat % alloc_or_die ( OQP_E_MO_A , ( / nbf / ), mo_energy_a , description = OQP_E_MO_A_comment ) call infos % dat % alloc_or_die ( OQP_VEC_MO_A , ( / nbf , nbf / ), mo_a , description = OQP_VEC_MO_A_comment ) if ( infos % control % scftype >= 2 ) then call infos % dat % alloc_or_die ( OQP_DM_B , ( / nbf2 / ), dmat_b , description = OQP_DM_B_comment ) call infos % dat % alloc_or_die ( OQP_E_MO_B , ( / nbf / ), mo_energy_b , description = OQP_E_MO_B_comment ) call infos % dat % alloc_or_die ( OQP_VEC_MO_B , ( / nbf , nbf / ), mo_b , description = OQP_VEC_MO_B_comment ) end if ! Canonical orthogonalizer Q from matrix_invsqrt (Q = U L&#94;{-1/2}, so that ! Q&#94;T S Q = I and Q Q&#94;T = S&#94;{-1}), plus the full overlap S (unpacked). allocate ( qmat ( nbf , nbf ), sfull ( nbf , nbf )) call get_qmat_cached ( infos , smat , qmat , nbf ) call unpack_matrix ( smat , sfull ) ! Projector pmat(target,min) = S&#94;{-1} Scross(target,min) = Q (Q&#94;T Scross), ! with Scross(target,min) = sco&#94;T (sco is stored (min,target)). Then form the ! projected density D_t = pmat * D_min * pmat&#94;T in the target basis. allocate ( pmat ( nbf , nbf_min ), tmpmn ( nbf , nbf_min ), dt ( nbf , nbf ), wrk ( nbf , nbf )) ! tmpmn = Q&#94;T * sco&#94;T   (= Q&#94;T Scross) call dgemm ( 't' , 't' , nbf , nbf_min , nbf , 1.0_dp , qmat , nbf , sco , nbf_min , 0.0_dp , tmpmn , nbf ) ! pmat = Q * tmpmn call dgemm ( 'n' , 'n' , nbf , nbf_min , nbf , 1.0_dp , qmat , nbf , tmpmn , nbf , 0.0_dp , pmat , nbf ) ! D_t = pmat * D_min * pmat&#94;T call dgemm ( 'n' , 'n' , nbf , nbf_min , nbf_min , 1.0_dp , pmat , nbf , dmin , nbf_min , 0.0_dp , tmpmn , nbf ) call dgemm ( 'n' , 't' , nbf , nbf , nbf_min , 1.0_dp , tmpmn , nbf , pmat , nbf , 0.0_dp , dt , nbf ) ! Natural orbitals in the orthonormal (Q) basis: diagonalize ! M = Q&#94;T (S D_t S) Q = W n W&#94;T. Eigenvalues n are occupations; the AO-basis ! natural orbitals are C = Q W and reconstruct D_t exactly. ! wrk = S * D_t call dgemm ( 'n' , 'n' , nbf , nbf , nbf , 1.0_dp , sfull , nbf , dt , nbf , 0.0_dp , wrk , nbf ) ! dt <- (S D_t) * S call dgemm ( 'n' , 'n' , nbf , nbf , nbf , 1.0_dp , wrk , nbf , sfull , nbf , 0.0_dp , dt , nbf ) ! wrk = Q&#94;T * (S D_t S) call dgemm ( 't' , 'n' , nbf , nbf , nbf , 1.0_dp , qmat , nbf , dt , nbf , 0.0_dp , wrk , nbf ) ! dt = wrk * Q  = Q&#94;T S D_t S Q call dgemm ( 'n' , 'n' , nbf , nbf , nbf , 1.0_dp , wrk , nbf , qmat , nbf , 0.0_dp , dt , nbf ) allocate ( occ ( nbf ), cno ( nbf , nbf )) call diag_symm_full ( 1 , nbf , dt , nbf , occ , ok ) if ( ok /= 0 ) call show_message ( 'Guess_MINAO: NO diagonalization failed' , WITH_ABORT ) ! NOs in AO basis: C = Q * W   (W = eigenvectors in dt) call dgemm ( 'n' , 'n' , nbf , nbf , nbf , 1.0_dp , qmat , nbf , dt , nbf , 0.0_dp , cno , nbf ) ! diag_symm_full returns ascending occupations; reverse so highest-occupied first do j = 1 , nbf mo_a (:, j ) = cno (:, nbf - j + 1 ) mo_energy_a ( j ) = - occ ( nbf - j + 1 ) end do if ( infos % control % scftype >= 2 ) then mo_b = mo_a mo_energy_b = mo_energy_a end if ! Build density from aufbau-occupied natural orbitals if ( infos % control % scftype == 1 ) then call get_ab_initio_density ( Dmat_A , MO_A , infos = infos , basis = basis ) else call get_ab_initio_density ( Dmat_A , MO_A , Dmat_B , MO_B , infos , basis ) end if call minao % clean () write ( IW , '(/1x,a/)' ) '...... End Of Initial Orbital Guess ......' call measure_time ( print_total = 1 , log_unit = iw ) close ( IW ) end subroutine guess_minao end module guess_minao_mod","tags":"","url":"sourcefile/guess_minao.f90.html"},{"title":"int_libint.F90 – OpenQP Fortran API","text":"Source Code module int2e_libint use precision , only : dp use int2_pairs , only : int2_pair_storage , int2_cutoffs_t use iso_c_binding , only : c_double , c_ptr , c_null_ptr , c_int , & c_funptr , c_f_pointer , c_f_procpointer , c_size_t use libint_f use constants , only : pi implicit none #ifdef OQP_LIBINT_ENABLE #include \"libint2/config.h\" #include \"libint2/util/generated/libint2_params.h\" #include \"fortran_incldefs.h\" #endif private public libint_compute_eri public libint_print_eri public libint_static_init public libint_static_cleanup public libint_t public libint2_active public libint2_init_eri public libint2_cleanup_eri public libint2_build real ( dp ), parameter :: halfsqrtpi = 0.5d0 * sqrt ( pi ) contains subroutine libint_static_init if ( libint2_active ) call libint2_static_init end subroutine subroutine libint_static_cleanup if ( libint2_active ) call libint2_static_cleanup end subroutine subroutine libint_compute_eri ( basis , ppairs , cutoffs , & shell_ids , deriv_order , & erieval , flips , zero_shq ) use boys_lut , only : tmax use basis_tools , only : basis_set implicit none type ( basis_set ), intent ( in ) :: basis type ( int2_cutoffs_t ), intent ( in ) :: cutoffs type ( int2_pair_storage ), intent ( in ) :: ppairs integer , intent ( in ) :: shell_ids ( 4 ) integer , intent ( out ) :: flips ( 4 ) integer , intent ( in ) :: deriv_order logical , intent ( out ) :: zero_shq real ( kind = dp ), dimension ( 3 ) :: a , b , c , d real ( kind = dp ), dimension ( 21 ) :: f type ( libint_t ), intent ( out ) :: erieval ( * ) real ( kind = dp ) :: pq2 , rhoq , gammapq , pfac real ( kind = dp ), dimension ( 3 ) :: pq integer :: am ( 4 ), am_tot , p1234 procedure ( libint2_build ), pointer :: build_eri integer :: shl_new ( 4 ) real ( kind = dp ) :: gpqinv real ( kind = dp ) :: tt , t2m1 integer :: m integer :: p12 , p34 integer :: ppid_p , ppid_q , npp_p , npp_q integer :: id1 , id2 zero_shq = . true . #ifdef OQP_LIBINT_ENABLE am = basis % am ( shell_ids ) am_tot = sum ( am ) + deriv_order flips = [ 1 , 2 , 3 , 4 ] if ( am ( 1 ) < am ( 2 )) then flips ( 1 : 2 ) = [ 2 , 1 ] am ( 1 : 2 ) = am ([ 2 , 1 ]) end if if ( am ( 3 ) < am ( 4 )) then flips ( 3 : 4 ) = [ 4 , 3 ] am ( 3 : 4 ) = am ([ 4 , 3 ]) end if if ( am ( 1 ) + am ( 2 ) > am ( 3 ) + am ( 4 )) then flips = flips ([ 3 , 4 , 1 , 2 ]) am = am ([ 3 , 4 , 1 , 2 ]) end if shl_new = shell_ids ( flips ) id1 = maxval ( shl_new ([ 1 , 2 ])) id2 = minval ( shl_new ([ 1 , 2 ])) npp_p = ppairs % ppid ( 1 , id1 * ( id1 - 1 ) / 2 + id2 ) ppid_p = ppairs % ppid ( 2 , id1 * ( id1 - 1 ) / 2 + id2 ) id1 = maxval ( shl_new ([ 3 , 4 ])) id2 = minval ( shl_new ([ 3 , 4 ])) npp_q = ppairs % ppid ( 1 , id1 * ( id1 - 1 ) / 2 + id2 ) ppid_q = ppairs % ppid ( 2 , id1 * ( id1 - 1 ) / 2 + id2 ) if ( npp_p == 0 . or . npp_q == 0 ) return a = basis % shell_centers ( shl_new ( 1 ), 1 : 3 ) b = basis % shell_centers ( shl_new ( 2 ), 1 : 3 ) c = basis % shell_centers ( shl_new ( 3 ), 1 : 3 ) d = basis % shell_centers ( shl_new ( 4 ), 1 : 3 ) p1234 = 0 associate ( & alpha1 => ppairs % alpha_a ( ppid_p :), & alpha2 => ppairs % alpha_b ( ppid_p :), & gammap => ppairs % g ( ppid_p :), & gpinv => ppairs % ginv ( ppid_p :), & p => ppairs % p (:, ppid_p :), & k1 => ppairs % k ( ppid_p :), & alpha3 => ppairs % alpha_a ( ppid_q :), & alpha4 => ppairs % alpha_b ( ppid_q :), & gammaq => ppairs % g ( ppid_q :), & gqinv => ppairs % ginv ( ppid_q :), & q => ppairs % p (:, ppid_q :), & k2 => ppairs % k ( ppid_q :) ) DO p12 = 1 , npp_p DO p34 = 1 , npp_q if (( k1 ( p12 ) * k2 ( p34 )) ** 2 < & ( gammap ( p12 ) * gammaq ( p34 )) ** 2 * ( gammap ( p12 ) + gammaq ( p34 )) * & cutoffs % pair_cutoff_squared ) cycle gpqinv = 1 / ( gammap ( p12 ) + gammaq ( p34 )) pfac = k1 ( p12 ) * k2 ( p34 ) * gpinv ( p12 ) * gqinv ( p34 ) * sqrt ( gpqinv ) !            if (abs(pfac) < cutoffs%quartet_cutoff) cycle pq = p (:, p12 ) - q (:, p34 ) pq2 = dot_product ( pq , pq ) gammapq = gammap ( p12 ) * gammaq ( p34 ) * gpqinv !           Boys function calculation tt = PQ2 * gammapq if ( tt > tmax ) then !             Case of a large argument value (asymptotic expansion + forward recursion) t2m1 = 0.5d0 / tt F ( 1 ) = halfsqrtpi / sqrt ( tt ) do m = 1 , am_tot F ( m + 1 ) = ( 2 * m - 1 ) * F ( m ) * t2m1 end do else !             Case of a small argument (interpolation + backward recursion) call boysf_nonasym ( am_tot , tt , F ) end if p1234 = p1234 + 1 #if LIBINT2_DEFINED_PA_x erieval ( p1234 )% PA_x ( 1 ) = P ( 1 , p12 ) - A ( 1 ) #endif #if LIBINT2_DEFINED_PA_y erieval ( p1234 )% PA_y ( 1 ) = P ( 2 , p12 ) - A ( 2 ) #endif #if LIBINT2_DEFINED_PA_z erieval ( p1234 )% PA_z ( 1 ) = P ( 3 , p12 ) - A ( 3 ) #endif #if LIBINT2_DEFINED_AB_x erieval ( p1234 )% AB_x ( 1 ) = A ( 1 ) - B ( 1 ) #endif #if LIBINT2_DEFINED_AB_y erieval ( p1234 )% AB_y ( 1 ) = A ( 2 ) - B ( 2 ) #endif #if LIBINT2_DEFINED_AB_z erieval ( p1234 )% AB_z ( 1 ) = A ( 3 ) - B ( 3 ) #endif #if LIBINT2_DEFINED_oo2z erieval ( p1234 )% oo2z ( 1 ) = 0.5_dp * gpinv ( p12 ) #endif #if LIBINT2_DEFINED_QC_x erieval ( p1234 )% QC_x ( 1 ) = Q ( 1 , p34 ) - C ( 1 ) #endif #if LIBINT2_DEFINED_QC_y erieval ( p1234 )% QC_y ( 1 ) = Q ( 2 , p34 ) - C ( 2 ) #endif #if LIBINT2_DEFINED_QC_z erieval ( p1234 )% QC_z ( 1 ) = Q ( 3 , p34 ) - C ( 3 ) #endif #if LIBINT2_DEFINED_CD_x erieval ( p1234 )% CD_x ( 1 ) = C ( 1 ) - D ( 1 ) #endif #if LIBINT2_DEFINED_CD_y erieval ( p1234 )% CD_y ( 1 ) = C ( 2 ) - D ( 2 ) #endif #if LIBINT2_DEFINED_CD_z erieval ( p1234 )% CD_z ( 1 ) = C ( 3 ) - D ( 3 ) #endif #if LIBINT2_DEFINED_oo2e erieval ( p1234 )% oo2e ( 1 ) = 0.5_dp * gqinv ( p34 ) #endif #if LIBINT2_DEFINED_WP_x erieval ( p1234 )% WP_x ( 1 ) = - gammaq ( p34 ) * gpqinv * pq ( 1 ) #endif #if LIBINT2_DEFINED_WP_y erieval ( p1234 )% WP_y ( 1 ) = - gammaq ( p34 ) * gpqinv * pq ( 2 ) #endif #if LIBINT2_DEFINED_WP_z erieval ( p1234 )% WP_z ( 1 ) = - gammaq ( p34 ) * gpqinv * pq ( 3 ) #endif #if LIBINT2_DEFINED_WQ_x erieval ( p1234 )% WQ_x ( 1 ) = gammap ( p12 ) * gpqinv * pq ( 1 ) #endif #if LIBINT2_DEFINED_WQ_y erieval ( p1234 )% WQ_y ( 1 ) = gammap ( p12 ) * gpqinv * pq ( 2 ) #endif #if LIBINT2_DEFINED_WQ_z erieval ( p1234 )% WQ_z ( 1 ) = gammap ( p12 ) * gpqinv * pq ( 3 ) #endif #if LIBINT2_DEFINED_oo2ze erieval ( p1234 )% oo2ze ( 1 ) = 0.5_dp * gpqinv #endif #if LIBINT2_DEFINED_roz erieval ( p1234 )% roz ( 1 ) = gammapq * gpinv ( p12 ) #endif #if LIBINT2_DEFINED_roe erieval ( p1234 )% roe ( 1 ) = gammapq * gqinv ( p34 ) #endif IF ( deriv_order > 0 ) THEN #if LIBINT2_DEFINED_alpha1rho_over_zeta2 erieval ( p1234 )% alpha1rho_over_zeta2 ( 1 ) = alpha1 ( p12 ) * gammapq * gpinv ( p12 ) * gpinv ( p12 ) #endif #if LIBINT2_DEFINED_alpha2rho_over_zeta2 erieval ( p1234 )% alpha2rho_over_zeta2 ( 1 ) = alpha2 ( p12 ) * gammapq * gpinv ( p12 ) * gpinv ( p12 ) #endif #if LIBINT2_DEFINED_alpha3rho_over_eta2 erieval ( p1234 )% alpha3rho_over_eta2 ( 1 ) = alpha3 ( p34 ) * gammapq * gqinv ( p34 ) * gqinv ( p34 ) #endif #if LIBINT2_DEFINED_alpha4rho_over_eta2 erieval ( p1234 )% alpha4rho_over_eta2 ( 1 ) = alpha4 ( p34 ) * gammapq * gqinv ( p34 ) * gqinv ( p34 ) #endif #if LIBINT2_DEFINED_alpha1over_zetapluseta erieval ( p1234 )% alpha1over_zetapluseta ( 1 ) = alpha1 ( p12 ) * gpqinv #endif #if LIBINT2_DEFINED_alpha2over_zetapluseta erieval ( p1234 )% alpha2over_zetapluseta ( 1 ) = alpha2 ( p12 ) * gpqinv #endif #if LIBINT2_DEFINED_alpha3over_zetapluseta erieval ( p1234 )% alpha3over_zetapluseta ( 1 ) = alpha3 ( p34 ) * gpqinv #endif #if LIBINT2_DEFINED_alpha4over_zetapluseta erieval ( p1234 )% alpha4over_zetapluseta ( 1 ) = alpha4 ( p34 ) * gpqinv #endif #if LIBINT2_DEFINED_rho12_over_alpha1 erieval ( p1234 )% rho12_over_alpha1 ( 1 ) = alpha2 ( p12 ) * gpinv ( p12 ) #endif #if LIBINT2_DEFINED_rho12_over_alpha2 erieval ( p1234 )% rho12_over_alpha2 ( 1 ) = alpha1 ( p12 ) * gpinv ( p12 ) #endif rhoq = alpha3 ( p34 ) * alpha4 ( p34 ) * gqinv ( p34 ) #if LIBINT2_DEFINED_rho34_over_alpha3 erieval ( p1234 )% rho34_over_alpha3 ( 1 ) = alpha4 ( p34 ) * gqinv ( p34 ) #endif #if LIBINT2_DEFINED_rho34_over_alpha4 erieval ( p1234 )% rho34_over_alpha4 ( 1 ) = alpha3 ( p34 ) * gqinv ( p34 ) #endif #if LIBINT2_DEFINED_two_alpha0_bra erieval ( p1234 )% two_alpha0_bra ( 1 ) = 2.0_dp * alpha1 ( p12 ) #endif #if LIBINT2_DEFINED_two_alpha0_ket erieval ( p1234 )% two_alpha0_ket ( 1 ) = 2.0_dp * alpha2 ( p12 ) #endif #if LIBINT2_DEFINED_two_alpha1ket erieval ( p1234 )% two_alpha1ket ( 1 ) = 2.0_dp * alpha4 ( p34 ) #endif #if LIBINT2_DEFINED_two_alpha1bra erieval ( p1234 )% two_alpha1bra ( 1 ) = 2.0_dp * alpha3 ( p34 ) #endif END IF #ifdef LIBINT2_DEFINED__aB_s___0__s___1___TwoPRep_s___0__s___1___Ab__up_0 IF ( am_tot >= 0 ) erieval ( p1234 )% f_aB_s___0__s___1___TwoPRep_s___0__s___1___Ab__up_0 ( 1 ) = & pfac * F ( 1 ) #endif #ifdef LIBINT2_DEFINED__aB_s___0__s___1___TwoPRep_s___0__s___1___Ab__up_1 IF ( am_tot >= 1 ) erieval ( p1234 )% f_aB_s___0__s___1___TwoPRep_s___0__s___1___Ab__up_1 ( 1 ) = & pfac * F ( 2 ) #endif #ifdef LIBINT2_DEFINED__aB_s___0__s___1___TwoPRep_s___0__s___1___Ab__up_2 IF ( am_tot >= 2 ) erieval ( p1234 )% f_aB_s___0__s___1___TwoPRep_s___0__s___1___Ab__up_2 ( 1 ) = & pfac * F ( 3 ) #endif #ifdef LIBINT2_DEFINED__aB_s___0__s___1___TwoPRep_s___0__s___1___Ab__up_3 IF ( am_tot >= 3 ) erieval ( p1234 )% f_aB_s___0__s___1___TwoPRep_s___0__s___1___Ab__up_3 ( 1 ) = & pfac * F ( 4 ) #endif #ifdef LIBINT2_DEFINED__aB_s___0__s___1___TwoPRep_s___0__s___1___Ab__up_4 IF ( am_tot >= 4 ) erieval ( p1234 )% f_aB_s___0__s___1___TwoPRep_s___0__s___1___Ab__up_4 ( 1 ) = & pfac * F ( 5 ) #endif #ifdef LIBINT2_DEFINED__aB_s___0__s___1___TwoPRep_s___0__s___1___Ab__up_5 IF ( am_tot >= 5 ) erieval ( p1234 )% f_aB_s___0__s___1___TwoPRep_s___0__s___1___Ab__up_5 ( 1 ) = & pfac * F ( 6 ) #endif #ifdef LIBINT2_DEFINED__aB_s___0__s___1___TwoPRep_s___0__s___1___Ab__up_6 IF ( am_tot >= 6 ) erieval ( p1234 )% f_aB_s___0__s___1___TwoPRep_s___0__s___1___Ab__up_6 ( 1 ) = & pfac * F ( 7 ) #endif #ifdef LIBINT2_DEFINED__aB_s___0__s___1___TwoPRep_s___0__s___1___Ab__up_7 IF ( am_tot >= 7 ) erieval ( p1234 )% f_aB_s___0__s___1___TwoPRep_s___0__s___1___Ab__up_7 ( 1 ) = & pfac * F ( 8 ) #endif #ifdef LIBINT2_DEFINED__aB_s___0__s___1___TwoPRep_s___0__s___1___Ab__up_8 IF ( am_tot >= 8 ) erieval ( p1234 )% f_aB_s___0__s___1___TwoPRep_s___0__s___1___Ab__up_8 ( 1 ) = & pfac * F ( 9 ) #endif #ifdef LIBINT2_DEFINED__aB_s___0__s___1___TwoPRep_s___0__s___1___Ab__up_9 IF ( am_tot >= 9 ) erieval ( p1234 )% f_aB_s___0__s___1___TwoPRep_s___0__s___1___Ab__up_9 ( 1 ) = & pfac * F ( 10 ) #endif #ifdef LIBINT2_DEFINED__aB_s___0__s___1___TwoPRep_s___0__s___1___Ab__up_10 IF ( am_tot >= 10 ) erieval ( p1234 )% f_aB_s___0__s___1___TwoPRep_s___0__s___1___Ab__up_10 ( 1 ) = & pfac * F ( 11 ) #endif #ifdef LIBINT2_DEFINED__aB_s___0__s___1___TwoPRep_s___0__s___1___Ab__up_11 IF ( am_tot >= 11 ) erieval ( p1234 )% f_aB_s___0__s___1___TwoPRep_s___0__s___1___Ab__up_11 ( 1 ) = & pfac * F ( 12 ) #endif #ifdef LIBINT2_DEFINED__aB_s___0__s___1___TwoPRep_s___0__s___1___Ab__up_12 IF ( am_tot >= 12 ) erieval ( p1234 )% f_aB_s___0__s___1___TwoPRep_s___0__s___1___Ab__up_12 ( 1 ) = & pfac * F ( 13 ) #endif #ifdef LIBINT2_DEFINED__aB_s___0__s___1___TwoPRep_s___0__s___1___Ab__up_13 IF ( am_tot >= 13 ) erieval ( p1234 )% f_aB_s___0__s___1___TwoPRep_s___0__s___1___Ab__up_13 ( 1 ) = & pfac * F ( 14 ) #endif #ifdef LIBINT2_DEFINED__aB_s___0__s___1___TwoPRep_s___0__s___1___Ab__up_14 IF ( am_tot >= 14 ) erieval ( p1234 )% f_aB_s___0__s___1___TwoPRep_s___0__s___1___Ab__up_14 ( 1 ) = & pfac * F ( 15 ) #endif #ifdef LIBINT2_DEFINED__aB_s___0__s___1___TwoPRep_s___0__s___1___Ab__up_15 IF ( am_tot >= 15 ) erieval ( p1234 )% f_aB_s___0__s___1___TwoPRep_s___0__s___1___Ab__up_15 ( 1 ) = & pfac * F ( 16 ) #endif #ifdef LIBINT2_DEFINED__aB_s___0__s___1___TwoPRep_s___0__s___1___Ab__up_16 IF ( am_tot >= 16 ) erieval ( p1234 )% f_aB_s___0__s___1___TwoPRep_s___0__s___1___Ab__up_16 ( 1 ) = & pfac * F ( 17 ) #endif #ifdef LIBINT2_DEFINED__aB_s___0__s___1___TwoPRep_s___0__s___1___Ab__up_17 IF ( am_tot >= 17 ) erieval ( p1234 )% f_aB_s___0__s___1___TwoPRep_s___0__s___1___Ab__up_17 ( 1 ) = & pfac * F ( 18 ) #endif #ifdef LIBINT2_DEFINED__aB_s___0__s___1___TwoPRep_s___0__s___1___Ab__up_18 IF ( am_tot >= 18 ) erieval ( p1234 )% f_aB_s___0__s___1___TwoPRep_s___0__s___1___Ab__up_18 ( 1 ) = & pfac * F ( 19 ) #endif #ifdef LIBINT2_DEFINED__aB_s___0__s___1___TwoPRep_s___0__s___1___Ab__up_19 IF ( am_tot >= 19 ) erieval ( p1234 )% f_aB_s___0__s___1___TwoPRep_s___0__s___1___Ab__up_19 ( 1 ) = & pfac * F ( 20 ) #endif #ifdef LIBINT2_DEFINED__aB_s___0__s___1___TwoPRep_s___0__s___1___Ab__up_20 IF ( am_tot >= 20 ) erieval ( p1234 )% f_aB_s___0__s___1___TwoPRep_s___0__s___1___Ab__up_20 ( 1 ) = & pfac * F ( 21 ) #endif END DO END DO end associate #if LIBINT2_CONTRACTED_INTS erieval ( 1 )% contrdepth = int ( p1234 , C_INT ) #endif select case ( deriv_order ) case ( 0 ) CALL C_F_PROCPOINTER ( libint2_build_eri ( am ( 4 ), am ( 3 ), am ( 2 ), am ( 1 )), build_eri ) #if INCLUDE_ERI >= 1 case ( 1 ) CALL C_F_PROCPOINTER ( libint2_build_eri1 ( am ( 4 ), am ( 3 ), am ( 2 ), am ( 1 )), build_eri ) #endif #if INCLUDE_ERI >= 2 case ( 2 ) CALL C_F_PROCPOINTER ( libint2_build_eri2 ( am ( 4 ), am ( 3 ), am ( 2 ), am ( 1 )), build_eri ) #endif case default error stop \"Unsupported `deriv_order` ! Please reconfigure and rebuild libint\" end select if ( p1234 == 0 ) return CALL build_eri ( erieval ) zero_shq = . false . #endif end subroutine subroutine libint_print_eri ( basis , shell_ids , deriv_order , erieval , flips ) use constants , only : shells_pnrm2 use basis_tools , only : basis_set type ( basis_set ) :: basis integer , intent ( in ) :: shell_ids ( 4 ), deriv_order , flips ( 4 ) type ( libint_t ), dimension ( * ), intent ( in ) :: erieval real ( kind = dp ), dimension (:,:,:,:), pointer :: eri_shell_set integer :: n ( 4 ), n0 ( 4 ), i_target , na , nb , nc , nd , ishell integer :: am ( 4 ), am0 ( 4 ) integer , parameter , dimension ( 3 ) :: n_targets = [ 1 , 12 , 78 ] integer :: mins ( 4 ), maxs ( 4 ), ids ( 4 ), shls ( 4 ) real ( kind = dp ) :: pnorms ( 36 , 4 ) shls = shell_ids ( flips ) am = basis % am ( shls ) n = ( am + 1 ) * ( am + 2 ) / 2 mins = shmax ( am - 1 ) + 1 maxs = shmax ( am ) pnorms (:, 1 ) = shells_pnrm2 (: n ( 1 ), am ( 1 )) pnorms (:, 2 ) = shells_pnrm2 (: n ( 2 ), am ( 2 )) pnorms (:, 3 ) = shells_pnrm2 (: n ( 3 ), am ( 3 )) pnorms (:, 4 ) = shells_pnrm2 (: n ( 4 ), am ( 4 )) am0 = basis % am ( shell_ids ) n0 = ( am0 + 1 ) * ( am0 + 2 ) / 2 do i_target = 1 , n_targets ( deriv_order + 1 ) call c_f_pointer ( erieval ( 1 )% targets ( i_target ), eri_shell_set , & shape = n ([ 4 , 3 , 2 , 1 ])) ishell = 0 do na = 1 , n0 ( 1 ) do nb = 1 , n0 ( 2 ) do nc = 1 , n0 ( 3 ) do nd = 1 , n0 ( 4 ) ids = [ na , nb , nc , nd ] ids = ids ( flips ) write ( * , \"(a6, 2i3, a, 2i3, a, es30.15)\" ) & \"elem (\" , na , nb , \" |\" , nc , nd , \") = \" , & eri_shell_set ( ids ( 4 ), ids ( 3 ), ids ( 2 ), ids ( 1 )) * & pnorms ( ids ( 1 ), 1 ) * pnorms ( ids ( 2 ), 2 ) * & pnorms ( ids ( 3 ), 3 ) * pnorms ( ids ( 4 ), 4 ) end do end do end do end do end do contains integer elemental function shmax ( i ) integer , intent ( in ) :: i shmax = ( i + 1 ) * ( i + 2 ) * ( i + 3 ) / 6 end function end subroutine !> @brief Non-asymptotic Boys function case pure subroutine boysf_nonasym ( n , tt , ft ) use boys_lut , only : rxinc , rfinc , nord , igrid , irgrd , fgrid , rmr implicit none real ( kind = 8 ), intent ( in ) :: tt integer , intent ( in ) :: n real ( kind = 8 ), intent ( out ) :: ft ( 0 : * ) real ( kind = 8 ) :: tv , tx , fx , et , t2 integer :: m , ip , ifxgrd , iftgrd ifxgrd = igrid ( n ) iftgrd = irgrd ( n ) tv = tt * rfinc ( ifxgrd ) tx = tt * rxinc ip = nint ( tv ) fx = 0 et = 0 et = exp ( - tt ) do m = nord , 0 , - 1 fx = ( fx * tv + fgrid ( m , ip , ifxgrd )) end do ft ( iftgrd ) = fx t2 = 2 * tt do m = iftgrd , 1 , - 1 ft ( m - 1 ) = ( t2 * ft ( m ) + et ) * rmr ( m ) end do end subroutine boysf_nonasym end module","tags":"","url":"sourcefile/int_libint.f90.html"},{"title":"apply_basis.F90 – OpenQP Fortran API","text":"Source Code !> @brief   Apply selected basis set library to the molecule !> @details This module extracts the information about basis set from the library file. !>               The library should be in GAMESS(US) basis set format. Then, it applies the selected !>               basis to all atoms in the molecule. !> @param infos(in,out)     Molecule information !> @param abas(in)      [R] Basis set library file, GAMESS(US) format module apply_basis_mod character ( len =* ), parameter :: module_name = \"apply_basis_mod\" contains subroutine apply_basis_C ( c_handle ) bind ( C , name = \"apply_basis\" ) use c_interop , only : oqp_handle_t , oqp_handle_get_info use types , only : information type ( oqp_handle_t ) :: c_handle type ( information ), pointer :: inf inf => oqp_handle_get_info ( c_handle ) call oqp_apply_basis ( inf ) end subroutine apply_basis_C subroutine oqp_apply_basis ( infos ) use messages , only : with_abort use types , only : information use atomic_structure_m , only : atomic_structure use strings , only : fstring use oqp_tagarray_driver use iso_c_binding , only : c_char use parallel , only : par_env_t use basis_api , only : map_shell2basis_set , print_basis implicit none type ( information ), intent ( inout ) :: infos type ( par_env_t ) :: pe character ( len = :), allocatable :: basis_file integer :: iw , i logical :: err ! ! Section of Tagarray for the basis filename ! We are getting basis file name from Python via tagarray ! character ( len = 1 , kind = c_char ), contiguous , pointer :: basis_filename (:) character ( len =* ), parameter :: subroutine_name = \"oqp_apply_basis\" character ( len =* ), parameter :: tags_general ( 1 ) = ( / character ( len = 80 ) :: & OQP_basis_filename / ) call data_has_tags ( infos % dat , tags_general , module_name , subroutine_name , with_abort ) call tagarray_get_data ( infos % dat , OQP_basis_filename , basis_filename ) allocate ( character ( ubound ( basis_filename , 1 )) :: basis_file ) do i = 1 , ubound ( basis_filename , 1 ) basis_file ( i : i ) = basis_filename ( i ) end do ! !  ! Files open !  ! 3. LOG: Write: Main output file !  ! 5. BAS: read: Basis set library (internally) ! open ( newunit = iw , file = infos % log_filename , position = \"append\" ) ! write ( iw , '(/,20x,\"++++++++++++++++++++++++++++++++++++++++\")' ) write ( iw , '(  22X,\"MODULE: apply_basis \")' ) write ( iw , '(  22X,\"Setting up basis set information\")' ) write ( iw , '(20x,\"++++++++++++++++++++++++++++++++++++++++\")' ) call pe % init ( infos % mpiinfo % comm , infos % mpiinfo % usempi ) call map_shell2basis_set ( infos ) !    if (pe%rank == 0) then !      call infos%basis%from_file(basis_file, infos%atoms, err) !      infos%control%basis_set_issue = err !    endif !    call infos%basis%basis_broadcast(infos%mpiinfo%comm, infos%mpiinfo%usempi) ! Checking error of basis set reading.. !    call pe%bcast(infos%control%basis_set_issue, 1) if ( infos % control % active_basis == 0 ) then write ( iw , '(/5X,\"Basis Sets options\"/& &5X,18(\"-\")/& &5X,\"Basis Sets: \",A/& &5X,\"Number of Shells  =\",I8,5X,\"Number of Primitives  =\",I8/& &5X,\"Number of Basis Set functions  =\",I8/& &5X,\"Maximum Angluar Momentum =\",I8/)' ) & trim ( basis_file ), & infos % basis % nshell , infos % basis % nprim , & infos % basis % nbf , infos % basis % mxam else write ( iw , '(/5X,\"Alternative Basis Set Options\"/& &5X,18(\"-\")/& &5X,\"Basis Sets: \",A/& &5X,\"Number of Shells  =\",I8,5X,\"Number of Primitives  =\",I8/& &5X,\"Number of Basis Set functions  =\",I8/& &5X,\"Maximum Angluar Momentum =\",I8/)' ) & trim ( basis_file ), & infos % alt_basis % nshell , infos % alt_basis % nprim , & infos % alt_basis % nbf , infos % alt_basis % mxam endif ! Report the angular (Cartesian vs pure spherical-harmonic) AO treatment. block use constants , only : HARMONIC_ACTIVE , NUM_CART_BF integer :: ish , ncart , nsphsh ncart = 0 nsphsh = 0 do ish = 1 , infos % basis % nshell ncart = ncart + NUM_CART_BF ( infos % basis % am ( ish )) if ( infos % basis % harmonic ( ish ) == 1 ) nsphsh = nsphsh + 1 end do if ( HARMONIC_ACTIVE . and . nsphsh > 0 ) then write ( iw , '(5X,\"AO angular type: spherical harmonics (5d/7f/9g)\")' ) write ( iw , '(5X,\"Pure spherical shells  =\",I8)' ) nsphsh write ( iw , '(5X,\"Spherical AO functions =\",I8,5X,\"Cartesian-equivalent =\",I8/)' ) & infos % basis % nbf , ncart else write ( iw , '(5X,\"AO angular type: Cartesian (6d/10f/15g)\"/)' ) end if end block close ( iw ) call print_basis ( infos ) end subroutine oqp_apply_basis end module apply_basis_mod","tags":"","url":"sourcefile/apply_basis.f90.html"},{"title":"trah_converger.F90 – OpenQP Fortran API","text":"Source Code !> @brief Trust-region augmented-Hessian (TRAH) SCF solver. !> @detail Method: Helmich-Paris, J. Chem. Phys. 154, 164104 (2021); the !>         augmented-Hessian/level-shift lineage traces to Bacskay, Chem. Phys. !>         61, 385 (1981). Selected by control%trh_impl = 1. Reuses the physics callbacks !>         already provided by the trah_converger (calc_g_h, calc_h_op, rotate_orbs) !>         plus calc_fock/get_ab_initio_density/compute_energy -- only the !>         optimization shell is implemented here. !> !>         Algorithm: trust-region Newton. Each macro step solves the !>         subproblem  min_p  g.p + 1/2 p.H p  s.t. |p| <= Delta  by the !>         Steihaug-Toint preconditioned conjugate-gradient method (preconditioner !>         M = diag(h_diag)); the step is accepted/rejected and Delta updated from !>         the ratio of actual to predicted energy reduction. H.p is formed matrix- !>         free via calc_h_op (a Fock-like contraction); H is never built. !> !>         Convention: calc_g_h / calc_h_op return half the true orbital gradient / !>         Hessian (same as otr_interface, which scales by 2), so we scale by 2. !> !> @note  E1 implementation (CG-Steihaug + basic trust control). Hardening of the !>        micro-solver for pathological/negative-gap cases (Jacobi-Davidson, !>        restarts, random trial vectors) is Phase-E2. !> @author Claude (native TRAH, Phase E1), 2026-06 module trah_native use precision , only : dp use types , only : information use mod_dft_molgrid , only : dft_grid_t use scf_converger , only : trah_converger , scf_conv_result , scf_conv_trah_result use scf_addons , only : calc_fock , compute_energy , scf_energy_t , scf_rhf use guess , only : get_ab_initio_density use basis_tools , only : basis_set use io_constants , only : IW implicit none private public :: trah_native_run contains !> @brief Macro trust-region loop. On entry conv%mo_a/mo_b hold the current !>        orbitals; on exit they hold the converged orbitals and conv%fock_ao !>        the corresponding Fock matrix. subroutine trah_native_run ( infos , molgrid , conv , res , energy ) type ( information ), intent ( inout ), target :: infos type ( dft_grid_t ), intent ( in ), target :: molgrid type ( trah_converger ), intent ( inout ), target :: conv class ( scf_conv_result ), intent ( inout ) :: res type ( scf_energy_t ), intent ( inout ), target :: energy integer :: n , macro , nmac , nmic , micro_used , irst , nrst real ( dp ) :: delta , dmax , conv_tol , gnorm , e0 , etrial , rho , pred , snorm , e_best real ( dp ), allocatable :: g (:), hdiag (:), p (:), mo0_a (:,:), mo0_b (:,:), mob_a (:,:), mob_b (:,:) real ( dp ), allocatable :: mo_e_a (:), mo_e_b (:) real ( dp ), allocatable :: vmin (:) real ( dp ) :: lam logical :: accepted , conv_ok , have_best real ( dp ), parameter :: stab_eig_tol = 1.0e-4_dp ! Hessian eigenvalue below -this = unstable ! near-convergence guards: once the model can no longer predict a meaningful ! energy reduction (pred below FP noise) or the trust radius collapses while ! the gradient is already small, the energy is converged even if |g| has not ! reached the (tight) gradient tolerance. A trust collapse with a large |g| is ! instead a genuine stall and is reported as non-convergence. real ( dp ), parameter :: pred_floor = 1.0e-11_dp real ( dp ), parameter :: delta_min = 1.0e-4_dp real ( dp ), parameter :: gtol_fp = 1.0e-4_dp real ( dp ), parameter :: stab_step = 1.0e-3_dp ! step above this at small |g| = saddle escape n = int ( conv % n_param ) nmac = int ( infos % control % maxit ) nmic = int ( infos % control % trh_nmic ) conv_tol = real ( infos % control % conv , dp ) delta = real ( infos % control % trh_r0 , dp ) dmax = max ( 4.0_dp , 8.0_dp * delta ) allocate ( g ( n ), hdiag ( n ), p ( n ), vmin ( n ), mo_e_a ( conv % nbf ), mo_e_b ( conv % nbf )) conv % f_old = 0.0_dp conv % d_old = 0.0_dp write ( IW , '(/5X,\"Native TRAH (trust-region Newton, Steihaug-CG)\"/5X,46(\"-\"))' ) write ( IW , '(5X,\"start trust radius =\",F7.3,\"   conv =\",ES9.2,\"   max micro =\",I4)' ) & delta , conv_tol , nmic write ( IW , '(/4x,\"Macro\",6x,\"Energy\",13x,\"|grad|\",7x,\"rho\",6x,\"trust\",3x,\"micro\",3x,\"step\")' ) write ( IW , '(3x,75(\"=\"))' ) ! --- multiple symmetry-broken restarts; keep the lowest converged energy --- ! restart 1 uses the plain guess; restarts 2.. add a distinct symmetry-breaking ! kick (cf. TRAH random trial vectors). trh_nrtv<=1 -> single deterministic ! solve (the validated default). nrst = max ( 1 , int ( infos % control % trh_nrtv )) if ( infos % control % mom ) nrst = 1 ! no symmetry-breaking restarts under MOM ! The RHF TRAH setup stores only alpha MOs.  The native trust-region ! driver passes both alpha and beta arrays through shared RHF/UHF/ROHF ! helpers, so provide a beta shadow for RHF instead of dereferencing an ! unallocated conv%mo_b. if (. not . allocated ( conv % mo_b )) allocate ( conv % mo_b , source = conv % mo_a ) allocate ( mo0_a , source = conv % mo_a ); allocate ( mo0_b , source = conv % mo_b ) allocate ( mob_a , source = conv % mo_a ); allocate ( mob_b , source = conv % mo_b ) e_best = huge ( 1.0_dp ); have_best = . false . do irst = 1 , nrst conv % mo_a = mo0_a ; conv % mo_b = mo0_b conv % f_old = 0.0_dp ; conv % d_old = 0.0_dp delta = real ( infos % control % trh_r0 , dp ) if ( nrst > 1 ) write ( IW , '(/5X,\"--- restart \",I0,\" of \",I0,\" ---\")' ) irst , nrst if ( irst > 1 ) then call symmetry_break ( conv , infos % control % scftype , n , 0.1_dp , 1234567 + 7919 * irst ) write ( IW , '(5X,\"(symmetry-breaking perturbation, norm 0.10)\")' ) end if ! initial point at the (possibly perturbed) orbitals call build_fock_grad ( infos , molgrid , conv , energy , conv % mo_a , conv % mo_b , g , hdiag , e0 ) do macro = 1 , nmac gnorm = sqrt ( dot_product ( g , g ) / real ( n , dp )) ! trust-region subproblem  ->  step p, predicted reduction pred. ! Default (davidson/jacobi_davidson) = augmented-Hessian + random trial vectors ! (robust; finds broken-symmetry minima, like OpenTrustRegion). trh_sub_solver=tcg ! selects the cheaper Steihaug-Toint CG for routine/easy cases. ! With MOM (state-specific SCF) we MUST stay deterministic: random trial vectors ! would break symmetry and collapse the targeted (often excited) state, so force ! the conservative Steihaug step that preserves the MOM-selected occupied space. ! The micro-solver runs BEFORE the convergence test so the aug-Hessian eigensolve ! can detect a negative-curvature (saddle) direction even when |g|~0 -- this is the ! stability check that lets us escape an unstable solution a prior DIIS pass landed on. if ( infos % control % trh_sub_solver == 2 . or . infos % control % mom ) then call steihaug_cg ( infos , conv , g , hdiag , delta , n , nmic , p , pred , micro_used ) else call aughess_step ( infos , conv , g , hdiag , delta , n , nmic , p , pred , micro_used ) end if snorm = sqrt ( dot_product ( p , p )) ! converged only at a genuine minimum: small gradient AND no escape step. if ( gnorm < conv_tol . and . snorm < stab_step ) then ! Stability check (skip under MOM, which must stay on the targeted state): ! find the lowest eigenvalue of the orbital Hessian H. If it is negative the ! point is a saddle/unstable solution -- kick along that mode and keep going ! to descend into the lower (symmetry-broken) minimum. if (. not . infos % control % mom ) then call lowest_hessian_eig ( infos , conv , hdiag , n , nmic , lam , vmin ) if ( lam < - stab_eig_tol ) then write ( IW , '(4x,i4,2x,f20.10,2x,es12.4,3x,\"unstable (Hess eig \",es10.2,\") - escaping\")' ) & macro , e0 , gnorm , lam call apply_step ( conv , infos % control % scftype , 0.1_dp * vmin ) call build_fock_grad ( infos , molgrid , conv , energy , conv % mo_a , conv % mo_b , g , hdiag , e0 ) delta = real ( infos % control % trh_r0 , dp ) cycle end if end if write ( IW , '(4x,i4,2x,f20.10,2x,es12.4,3x,\"CONVERGED\")' ) macro - 1 , e0 , gnorm res % error = gnorm exit end if ! model can no longer predict a meaningful ENERGY reduction (pred ~ FP noise). ! The energy is converged, but the orbital GRADIENT may still be loose -- near a ! minimum pred ~ 0.5*g.p ~ gnorm&#94;2, so it underflows the floor while gnorm is ! still ~1e-7. Post-SCF consumers (ROHF canonicalisation for MRSF, analytic ! gradients) need accurate orbitals, so take the (descent) Newton/CG step once to ! tighten the gradient quadratically before exiting (OTR likewise steps on to ! ~1e-8). The energy ratio is FP-noise-dominated here, so accept unconditionally. if ( pred <= pred_floor . and . gnorm < gtol_fp . and . snorm < stab_step ) then do while ( gnorm > conv_tol . and . snorm > 0.0_dp . and . pred <= pred_floor ) call apply_step ( conv , infos % control % scftype , p ) call build_fock_grad ( infos , molgrid , conv , energy , conv % mo_a , conv % mo_b , g , hdiag , e0 ) gnorm = sqrt ( dot_product ( g , g ) / real ( n , dp )) if ( infos % control % trh_sub_solver == 2 . or . infos % control % mom ) then call steihaug_cg ( infos , conv , g , hdiag , delta , n , nmic , p , pred , micro_used ) else call aughess_step ( infos , conv , g , hdiag , delta , n , nmic , p , pred , micro_used ) end if snorm = sqrt ( dot_product ( p , p )) end do ! If a step revived the model (pred > floor) without reaching conv_tol, resume ! the normal trust-region loop; otherwise the orbitals are as tight as FP allows. if ( pred > pred_floor . and . gnorm >= conv_tol ) cycle write ( IW , '(4x,i4,2x,f20.10,2x,es12.4,3x,\"CONVERGED (FP precision)\")' ) macro , e0 , gnorm ! report error below conv_tol so the SCF driver recognises convergence and ! does NOT re-diagonalise the raw Fock (which would corrupt ROHF orbitals) res % error = min ( gnorm , 0.99_dp * conv_tol ) exit end if ! trial energy at trial orbitals (copies; conv%mo_* untouched) etrial = trial_energy ( infos , molgrid , conv , energy , p ) if ( pred > 0.0_dp ) then rho = ( e0 - etrial ) / pred else rho = - 1.0_dp end if accepted = ( rho > 0.1_dp ) ! Backtracking line search: if the full trust step is rejected, shrink it ! along its own direction (energy-only evals, no extra Hessian transforms) ! until the energy decreases. The first CG direction is -M&#94;{-1}g (descent), ! so a sufficiently short step always lowers the energy. This rescues steps ! that overshoot into an ascent region (e.g. small-denominator ROHF ! docc-socc rotations) instead of collapsing the trust radius. if (. not . accepted . and . pred > pred_floor ) then block real ( dp ) :: fac , et2 integer :: ls fac = 0.5_dp do ls = 1 , 5 et2 = trial_energy ( infos , molgrid , conv , energy , fac * p ) if ( et2 < e0 - 1.0e-12_dp ) then p = fac * p ; snorm = fac * snorm ; etrial = et2 rho = ( e0 - etrial ) / ( pred * fac ) ! reduction vs.\\ scaled prediction accepted = . true . exit end if fac = 0.5_dp * fac end do end block end if write ( IW , '(4x,i4,2x,f20.10,2x,es12.4,2x,f7.3,2x,f7.3,3x,i4,3x,a)' ) & macro , merge ( etrial , e0 , accepted ), gnorm , rho , delta , micro_used , & merge ( 'acc' , 'rej' , accepted ) call flush ( IW ) if ( accepted ) then ! commit the rotation, then rebuild gradient/Hessian-diag at the new point call apply_step ( conv , infos % control % scftype , p ) call build_fock_grad ( infos , molgrid , conv , energy , conv % mo_a , conv % mo_b , g , hdiag , e0 ) end if ! trust-radius update if ( rho < 0.25_dp ) then delta = 0.25_dp * delta else if ( rho > 0.75_dp . and . snorm > 0.8_dp * delta ) then delta = min ( 2.0_dp * delta , dmax ) end if ! trust region collapsed: converged (small |g|) or a genuine stall (large |g|) if ( delta < delta_min ) then if ( gnorm < gtol_fp ) then write ( IW , '(4x,i4,2x,f20.10,2x,es12.4,3x,\"CONVERGED (trust radius minimal)\")' ) & macro , e0 , gnorm res % error = min ( gnorm , 0.99_dp * conv_tol ) else write ( IW , '(5X,\"Native TRAH: trust region collapsed without convergence, |g|=\",ES10.3)' ) gnorm res % error = gnorm res % ierr = 4 end if exit end if if ( macro == nmac ) then write ( IW , '(5X,\"Native TRAH: reached max macro iterations.\")' ) res % error = gnorm res % ierr = 4 end if end do ! macro conv_ok = ( gnorm < gtol_fp ) if ( conv_ok . and . e0 < e_best ) then e_best = e0 ; mob_a = conv % mo_a ; mob_b = conv % mo_b ; have_best = . true . end if if ( nrst > 1 ) write ( IW , '(5X,\"restart \",I0,\": E =\",F20.10,\"  converged=\",L1)' ) irst , e0 , conv_ok end do ! restart ! adopt the lowest converged solution and refresh the Fock/gradient at it. ! Reset the incremental-Fock history so the FINAL Fock is built fresh from the ! converged density: an incrementally-accumulated Fock drifts from the exact one, ! and post-SCF consumers (ROHF canonicalisation for MRSF, analytic gradients) ! diagonalise this Fock -- a drifted Fock yields wrong canonical orbitals/energies. if ( have_best ) then conv % mo_a = mob_a ; conv % mo_b = mob_b conv % f_old = 0.0_dp ; conv % d_old = 0.0_dp call build_fock_grad ( infos , molgrid , conv , energy , conv % mo_a , conv % mo_b , g , hdiag , e0 ) res % error = min ( sqrt ( dot_product ( g , g ) / real ( n , dp )), 0.99_dp * conv_tol ) res % ierr = 0 if ( nrst > 1 ) write ( IW , '(/5X,\"best of \",I0,\" restarts: E =\",F20.10)' ) nrst , e_best end if conv % etot = e0 call compute_native_mo_energies ( conv % nbf , conv % fock_ao (:, 1 ), conv % mo_a , & mo_e_a , conv % work1 , conv % work2 ) if ( infos % control % scftype /= scf_rhf ) then call compute_native_mo_energies ( conv % nbf , conv % fock_ao (:, 2 ), conv % mo_b , & mo_e_b , conv % work1 , conv % work2 ) else mo_e_b = mo_e_a end if conv % dat % buffer ( conv % dat % slot )% focks = conv % fock_ao conv % dat % buffer ( conv % dat % slot )% densities = conv % dens conv % dat % buffer ( conv % dat % slot )% energy = e0 conv % dat % buffer ( conv % dat % slot )% mo_a = conv % mo_a conv % dat % buffer ( conv % dat % slot )% mo_e_a = mo_e_a if ( infos % control % scftype /= scf_rhf ) then conv % dat % buffer ( conv % dat % slot )% mo_b = conv % mo_b conv % dat % buffer ( conv % dat % slot )% mo_e_b = mo_e_b end if select type ( res ) class is ( scf_conv_trah_result ) res % iter = macro end select deallocate ( g , hdiag , p , vmin , mo0_a , mo0_b , mob_a , mob_b , mo_e_a , mo_e_b ) end subroutine trah_native_run subroutine compute_native_mo_energies ( nbf , fock , mo_coeffs , mo_energies , work_1 , work_2 ) use mathlib , only : unpack_matrix integer , intent ( in ) :: nbf real ( dp ), intent ( in ) :: fock (:), mo_coeffs (:,:) real ( dp ), intent ( out ) :: mo_energies (:) real ( dp ), intent ( inout ) :: work_1 (:,:), work_2 (:,:) integer :: i call unpack_matrix ( fock , work_1 ) call dgemm ( 'T' , 'N' , nbf , nbf , nbf , & 1.0_dp , mo_coeffs , nbf , & work_1 , nbf , & 0.0_dp , work_2 , nbf ) call dgemm ( 'N' , 'N' , nbf , nbf , nbf , & 1.0_dp , work_2 , nbf , & mo_coeffs , nbf , & 0.0_dp , work_1 , nbf ) do i = 1 , nbf mo_energies ( i ) = work_1 ( i , i ) end do end subroutine compute_native_mo_energies !> @brief Build density+Fock from the given orbitals and return the (scaled) !>        orbital gradient, Hessian diagonal, and total energy. subroutine build_fock_grad ( infos , molgrid , conv , energy , mo_a , mo_b , g , hdiag , e ) type ( information ), intent ( inout ), target :: infos type ( dft_grid_t ), intent ( in ) :: molgrid type ( trah_converger ), intent ( inout ) :: conv type ( scf_energy_t ), intent ( inout ), target :: energy real ( dp ), intent ( inout ) :: mo_a (:,:), mo_b (:,:) real ( dp ), intent ( out ) :: g (:), hdiag (:), e type ( scf_energy_t ), pointer :: ep integer :: nschwz call rebuild_fock ( infos , molgrid , conv , energy , mo_a , mo_b , nschwz ) call conv % calc_g_h ( g , hdiag ) g = 2.0_dp * g hdiag = 2.0_dp * hdiag ep => energy e = compute_energy ( ep ) end subroutine build_fock_grad !> @brief Energy at a trial step p, evaluated on copies of the orbitals. function trial_energy ( infos , molgrid , conv , energy , p ) result ( e ) type ( information ), intent ( inout ), target :: infos type ( dft_grid_t ), intent ( in ) :: molgrid type ( trah_converger ), intent ( inout ) :: conv type ( scf_energy_t ), intent ( inout ), target :: energy real ( dp ), intent ( in ) :: p (:) real ( dp ) :: e real ( dp ), allocatable :: ma (:,:), mb (:,:) type ( scf_energy_t ), pointer :: ep integer :: nschwz allocate ( ma , source = conv % mo_a ) allocate ( mb , source = conv % mo_b ) call rotate_mo ( conv , infos % control % scftype , p , ma , mb ) call rebuild_fock ( infos , molgrid , conv , energy , ma , mb , nschwz ) ep => energy e = compute_energy ( ep ) deallocate ( ma , mb ) end function trial_energy !> @brief Permanently rotate the converger orbitals by p. subroutine apply_step ( conv , scftype , p ) type ( trah_converger ), intent ( inout ) :: conv integer ( 8 ), intent ( in ) :: scftype real ( dp ), intent ( in ) :: p (:) call rotate_mo ( conv , scftype , p , conv % mo_a , conv % mo_b ) end subroutine apply_step !> @brief Apply rotation vector p to the supplied orbital arrays per SCF type. subroutine rotate_mo ( conv , scftype , p , mo_a , mo_b ) type ( trah_converger ), intent ( inout ) :: conv integer ( 8 ), intent ( in ) :: scftype real ( dp ), intent ( in ) :: p (:) real ( dp ), intent ( inout ) :: mo_a (:,:), mo_b (:,:) integer :: na select case ( int ( scftype )) case ( 1 ) ! RHF call conv % rotate_orbs ( p , conv % nbf , conv % nocc_a , mo_a ) case ( 2 ) ! UHF na = conv % nocc_a * conv % nvir_a call conv % rotate_orbs ( p ( 1 : na ), conv % nbf , conv % nocc_a , mo_a ) call conv % rotate_orbs ( p ( na + 1 :), conv % nbf , conv % nocc_b , mo_b ) case ( 3 ) ! ROHF call conv % rotate_orbs ( p , conv % nbf , conv % nocc_a , mo_a ) mo_b = mo_a end select end subroutine rotate_mo !> @brief density (from mo) -> Fock (calc_fock). Mirrors otr_interface. subroutine rebuild_fock ( infos , molgrid , conv , energy , mo_a , mo_b , nschwz ) type ( information ), intent ( inout ), target :: infos type ( dft_grid_t ), intent ( in ) :: molgrid type ( trah_converger ), intent ( inout ) :: conv type ( scf_energy_t ), intent ( inout ), target :: energy real ( dp ), intent ( inout ) :: mo_a (:,:), mo_b (:,:) integer , intent ( out ) :: nschwz type ( basis_set ), pointer :: basis basis => infos % basis if ( int ( infos % control % scftype ) == 1 ) then call get_ab_initio_density ( conv % dens (:, 1 ), mo_a , conv % dens (:, 1 ), mo_a , infos , basis ) else call get_ab_initio_density ( conv % dens (:, 1 ), mo_a , conv % dens (:, 2 ), mo_b , infos , basis ) end if call calc_fock ( basis , infos , molgrid , conv % fock_ao , energy , mo_a , conv % dens , & mo_b , nschwz , conv % f_old , conv % d_old ) end subroutine rebuild_fock !> @brief Steihaug-Toint preconditioned CG for the trust-region subproblem. !>        Minimises m(p)=g.p+1/2 p.H p with |p|<=delta. Preconditioner M=diag(hdiag). !>        H.x via calc_h_op (scaled by 2). Returns step p and pred = -m(p) >= 0. subroutine steihaug_cg ( infos , conv , g , hdiag , delta , n , nmic , p , pred , used ) type ( information ), intent ( inout ), target :: infos type ( trah_converger ), intent ( inout ) :: conv real ( dp ), intent ( in ) :: g (:), hdiag (:), delta integer , intent ( in ) :: n , nmic real ( dp ), intent ( out ) :: p (:), pred integer , intent ( out ) :: used real ( dp ), allocatable :: r (:), y (:), d (:), hd (:), hx (:), hp (:) real ( dp ) :: ry , ry_new , curv , alpha , beta , tau , pd , dd , pp , gp , php , rnorm0 , rnorm integer :: k allocate ( r ( n ), y ( n ), d ( n ), hd ( n ), hx ( n ), hp ( n )) p = 0.0_dp hp = 0.0_dp ! hp accumulates H.p alongside p (hd=2*calc_h_op is H.d), r = g ! residual of (H p + g); at p=0, r=g call precond ( hdiag , r , y ) ! y = M&#94;-1 r d = - y ry = dot_product ( r , y ) rnorm0 = sqrt ( dot_product ( r , r )) used = 0 do k = 1 , nmic used = k call conv % calc_h_op ( infos , d , hx ) hd = 2.0_dp * hx curv = dot_product ( d , hd ) if ( curv <= 0.0_dp ) then ! negative curvature -> go to trust boundary call to_boundary ( p , d , delta , tau ) p = p + tau * d hp = hp + tau * hd exit end if alpha = ry / curv ! check trust-region boundary pp = dot_product ( p , p ); pd = dot_product ( p , d ); dd = dot_product ( d , d ) if ( pp + 2.0_dp * alpha * pd + alpha * alpha * dd >= delta * delta ) then call to_boundary ( p , d , delta , tau ) p = p + tau * d hp = hp + tau * hd exit end if p = p + alpha * d hp = hp + alpha * hd r = r + alpha * hd rnorm = sqrt ( dot_product ( r , r )) if ( rnorm <= min ( 0.1_dp , sqrt ( rnorm0 )) * rnorm0 . or . rnorm < 1.0e-10_dp ) exit call precond ( hdiag , r , y ) ry_new = dot_product ( r , y ) beta = ry_new / ry d = - y + beta * d ry = ry_new end do ! predicted reduction = -(g.p + 1/2 p.H p); hp already holds H.p, so the ! curvature term p.H.p = p.hp -- no extra Hessian-vector (Fock) build needed. gp = dot_product ( g , p ) php = dot_product ( p , hp ) pred = - ( gp + 0.5_dp * php ) deallocate ( r , y , d , hd , hx , hp ) end subroutine steihaug_cg !> @brief y = M&#94;-1 r with M = diag(hdiag), small/negative diagonal floored. !> @note  Using |hdiag| was tried to handle indefinite ROHF Hessians but !>        destabilised well-behaved UHF cases (e.g. [Fe(H2O)6]2+); the robust !>        handling of an indefinite Hessian belongs in the micro-solver !>        (augmented-Hessian / level shift), not the preconditioner. subroutine precond ( hdiag , r , y ) real ( dp ), intent ( in ) :: hdiag (:), r (:) real ( dp ), intent ( out ) :: y (:) integer :: i real ( dp ) :: di do i = 1 , size ( r ) di = hdiag ( i ) if ( di < 1.0e-6_dp ) di = 1.0e-6_dp y ( i ) = r ( i ) / di end do end subroutine precond !> @brief Positive root tau of |p + tau d| = delta (move to trust boundary). subroutine to_boundary ( p , d , delta , tau ) real ( dp ), intent ( in ) :: p (:), d (:), delta real ( dp ), intent ( out ) :: tau real ( dp ) :: a , b , c , disc a = dot_product ( d , d ) b = 2.0_dp * dot_product ( p , d ) c = dot_product ( p , p ) - delta * delta disc = max ( b * b - 4.0_dp * a * c , 0.0_dp ) tau = ( - b + sqrt ( disc )) / ( 2.0_dp * a ) end subroutine to_boundary !> @brief Deterministic symmetry-breaking kick: rotate the orbitals by a random !>        vector of fixed total norm (fixed seed -> reproducible). Breaks spin/ !>        spatial symmetry so the optimizer can leave an unstable symmetric solution. subroutine symmetry_break ( conv , scftype , n , amp , iseed ) type ( trah_converger ), intent ( inout ) :: conv integer ( 8 ), intent ( in ) :: scftype integer , intent ( in ) :: n , iseed real ( dp ), intent ( in ) :: amp real ( dp ), allocatable :: kp (:) integer , allocatable :: seed (:) integer :: ssz real ( dp ) :: nrm allocate ( kp ( n )) call random_seed ( size = ssz ); allocate ( seed ( ssz )); seed = iseed ; call random_seed ( put = seed ) call random_number ( kp ) kp = 2.0_dp * kp - 1.0_dp nrm = norm2 ( kp ) if ( nrm > 0.0_dp ) kp = amp * kp / nrm ! fixed total rotation norm = amp call rotate_mo ( conv , scftype , kp , conv % mo_a , conv % mo_b ) deallocate ( kp , seed ) end subroutine symmetry_break !> @brief A.[c;y] for the bordered (augmented) Hessian A=[[0,g&#94;T],[g,H]] (alpha=1). !>        v(1)=head, v(2:n+1)=orbital rotation. H.y via calc_h_op (scaled by 2). subroutine aug_matvec ( infos , conv , g , v , n , av ) type ( information ), intent ( inout ), target :: infos type ( trah_converger ), intent ( inout ) :: conv real ( dp ), intent ( in ) :: g (:), v (:) integer , intent ( in ) :: n real ( dp ), intent ( out ) :: av (:) real ( dp ), allocatable :: hx (:) allocate ( hx ( n )) call conv % calc_h_op ( infos , v ( 2 : n + 1 ), hx ) av ( 1 ) = dot_product ( g , v ( 2 : n + 1 )) av ( 2 : n + 1 ) = v ( 1 ) * g + 2.0_dp * hx deallocate ( hx ) end subroutine aug_matvec !> @brief Augmented-Hessian (RFO) trust-region step via Davidson for the lowest !>        eigenpair of [[0,g&#94;T],[g,H]]. The lowest eigenvector [c;y] yields the !>        level-shifted Newton step kappa = y/c, which follows negative curvature !>        into the lower (symmetry-broken) basin -- unlike Steihaug-CG, which !>        truncates there. Matrix-free (calc_h_op), preconditioned by [0;hdiag], !>        step truncated to the trust radius. This is the defining TRAH micro-solver. subroutine aughess_step ( infos , conv , g , hdiag , delta , n , nmic , p , pred , used ) type ( information ), intent ( inout ), target :: infos type ( trah_converger ), intent ( inout ) :: conv real ( dp ), intent ( in ) :: g (:), hdiag (:), delta integer , intent ( in ) :: n , nmic real ( dp ), intent ( out ) :: p (:), pred integer , intent ( out ) :: used integer :: nn , mmax , m , i , k , info , lwork , n_rtv , j , mw , ssz real ( dp ) :: theta , rnorm , c0 , snorm , php , di , nv real ( dp ), allocatable :: V (:,:), W (:,:), Tm (:,:), u (:), au (:), r (:), tc (:) real ( dp ), allocatable :: eig (:), work (:), hx (:) integer , allocatable :: seed (:) nn = n + 1 mmax = min ( max ( int ( nmic ), 6 ), 40 ) allocate ( V ( nn , mmax ), W ( nn , mmax ), u ( nn ), au ( nn ), r ( nn ), tc ( nn ), hx ( n )) allocate ( eig ( mmax ), work ( 8 * mmax + 2 * mmax * mmax )) lwork = size ( work ) ! initial subspace, vector 1: gradient-seeded [1 ; -M&#94;{-1} g] V ( 1 , 1 ) = 1.0_dp do i = 1 , n di = hdiag ( i ); if ( di < 1.0e-6_dp ) di = 1.0e-6_dp V ( 1 + i , 1 ) = - g ( i ) / di end do V (:, 1 ) = V (:, 1 ) / norm2 ( V (:, 1 )) m = 1 ! random trial vectors (head 0, random tail): give the eigensolver a generic ! component along symmetry-breaking negative-curvature modes that the gradient ! cannot see at a symmetric point -- this is how the solver locates broken- ! symmetry minima in a single run. Deterministic fixed seed -> reproducible. n_rtv = min ( max ( int ( infos % control % trh_nrtv ), 1 ), mmax - 1 ) call random_seed ( size = ssz ); allocate ( seed ( ssz )); seed = 20260607 ; call random_seed ( put = seed ) do j = 1 , n_rtv tc ( 1 ) = 0.0_dp call random_number ( tc ( 2 : nn )); tc ( 2 : nn ) = 2.0_dp * tc ( 2 : nn ) - 1.0_dp do i = 1 , m tc = tc - dot_product ( V (:, i ), tc ) * V (:, i ) end do nv = norm2 ( tc ) if ( nv > 1.0e-8_dp ) then m = m + 1 ; V (:, m ) = tc / nv end if end do deallocate ( seed ) used = 0 ; mw = 0 do k = 1 , mmax ! augmented matrix-vector products for any new basis columns do while ( mw < m ) mw = mw + 1 call aug_matvec ( infos , conv , g , V (:, mw ), n , W (:, mw )); used = used + 1 end do ! Rayleigh matrix Tm = V&#94;T W  (m x m, symmetric); BLAS over the large nn dim allocate ( Tm ( m , m )) call dgemm ( 'T' , 'N' , m , m , nn , 1.0_dp , V , nn , W , nn , 0.0_dp , Tm , m ) call dsyev ( 'V' , 'U' , m , Tm , m , eig (: m ), work , lwork , info ) theta = eig ( 1 ) ! lowest eigenvalue call dgemv ( 'N' , nn , m , 1.0_dp , V , nn , Tm (:, 1 ), 1 , 0.0_dp , u , 1 ) ! Ritz vector call dgemv ( 'N' , nn , m , 1.0_dp , W , nn , Tm (:, 1 ), 1 , 0.0_dp , au , 1 ) ! A u deallocate ( Tm ) r = au - theta * u ! residual rnorm = norm2 ( r ) if ( rnorm < 1.0e-6_dp . or . m == mmax ) exit ! preconditioned correction t = (D - theta)&#94;{-1} r,  D = [0 ; hdiag] tc ( 1 ) = r ( 1 ) / sign ( max ( abs ( 0.0_dp - theta ), 1.0e-6_dp ), 0.0_dp - theta ) do i = 1 , n di = hdiag ( i ) - theta if ( abs ( di ) < 1.0e-6_dp ) di = sign ( 1.0e-6_dp , di ) tc ( 1 + i ) = r ( 1 + i ) / di end do ! orthonormalize against current basis (modified Gram-Schmidt) do i = 1 , m tc = tc - dot_product ( V (:, i ), tc ) * V (:, i ) end do nv = norm2 ( tc ) if ( nv < 1.0e-8_dp ) exit m = m + 1 V (:, m ) = tc / nv end do ! step kappa = y/c from the lowest Ritz vector (head normalized positive) c0 = u ( 1 ) if ( c0 < 0.0_dp ) then ; u = - u ; c0 = - c0 ; end if p = u ( 2 : nn ) / max ( c0 , 1.0e-8_dp ) snorm = norm2 ( p ) if ( snorm > delta ) p = p * ( delta / snorm ) call conv % calc_h_op ( infos , p , hx ) php = 2.0_dp * dot_product ( p , hx ) pred = - ( dot_product ( g , p ) + 0.5_dp * php ) deallocate ( V , W , u , au , r , tc , eig , work , hx ) end subroutine aughess_step !> @brief Lowest eigenpair of the orbital Hessian H (n x n, NOT bordered), by !>        Davidson with several random starts (so it reliably finds a negative !>        symmetry-breaking mode at a converged point, where the gradient is ~0 !>        and the bordered form degenerates). Matrix-free: H.x = 2*calc_h_op. subroutine lowest_hessian_eig ( infos , conv , hdiag , n , nmic , lam , vmin ) type ( information ), intent ( inout ), target :: infos type ( trah_converger ), intent ( inout ) :: conv real ( dp ), intent ( in ) :: hdiag (:) integer , intent ( in ) :: n , nmic real ( dp ), intent ( out ) :: lam , vmin (:) integer :: mmax , m , i , k , info , lwork , mw , ssz real ( dp ) :: rnorm , di , nv , theta real ( dp ), allocatable :: V (:,:), W (:,:), Tm (:,:), u (:), r (:), tc (:), eig (:), work (:), hx (:) integer , allocatable :: seed (:) mmax = min ( max ( int ( nmic ), 8 ), 40 ) allocate ( V ( n , mmax ), W ( n , mmax ), u ( n ), r ( n ), tc ( n ), hx ( n )) allocate ( eig ( mmax ), work ( 8 * mmax + 2 * mmax * mmax )); lwork = size ( work ) call random_seed ( size = ssz ); allocate ( seed ( ssz )); seed = 987654321 ; call random_seed ( put = seed ) m = 0 do i = 1 , min ( 4 , mmax ) ! a few random trial vectors call random_number ( tc ); tc = 2.0_dp * tc - 1.0_dp do k = 1 , m ; tc = tc - dot_product ( V (:, k ), tc ) * V (:, k ); end do nv = norm2 ( tc ); if ( nv > 1.0e-8_dp ) then ; m = m + 1 ; V (:, m ) = tc / nv ; end if end do deallocate ( seed ) theta = 0.0_dp ; mw = 0 do k = 1 , mmax do while ( mw < m ) mw = mw + 1 call conv % calc_h_op ( infos , V (:, mw ), hx ); W (:, mw ) = 2.0_dp * hx end do allocate ( Tm ( m , m )) call dgemm ( 'T' , 'N' , m , m , n , 1.0_dp , V , n , W , n , 0.0_dp , Tm , m ) call dsyev ( 'V' , 'U' , m , Tm , m , eig (: m ), work , lwork , info ) theta = eig ( 1 ) call dgemv ( 'N' , n , m , 1.0_dp , V , n , Tm (:, 1 ), 1 , 0.0_dp , u , 1 ) call dgemv ( 'N' , n , m , 1.0_dp , W , n , Tm (:, 1 ), 1 , 0.0_dp , r , 1 ) r = r - theta * u deallocate ( Tm ) rnorm = norm2 ( r ) if ( rnorm < 1.0e-5_dp . or . m == mmax ) exit do i = 1 , n di = hdiag ( i ) - theta if ( abs ( di ) < 1.0e-6_dp ) di = sign ( 1.0e-6_dp , di ) tc ( i ) = r ( i ) / di end do do i = 1 , m ; tc = tc - dot_product ( V (:, i ), tc ) * V (:, i ); end do nv = norm2 ( tc ); if ( nv < 1.0e-8_dp ) exit m = m + 1 ; V (:, m ) = tc / nv end do lam = theta nv = norm2 ( u ); if ( nv > 0.0_dp ) u = u / nv vmin = u deallocate ( V , W , u , r , tc , hx , eig , work ) end subroutine lowest_hessian_eig end module trah_native","tags":"","url":"sourcefile/trah_converger.f90.html"},{"title":"parallel.F90 – OpenQP Fortran API","text":"Source Code !> buffer_types defines a list of data types used in parallel communication. !> Each entry specifies: !> (1) A human-readable name for the data type, !> (2) The corresponding MPI data type for communication, !> (3) The Fortran data type (with the appropriate kind), !> (4) The array rank or shape (e.g., scalar, 1D, 2D, etc.). !> These types are used for creating allreduce/bcast buffers in MPI operations. !> @author Mohsen Mazaherifar !> @date Sep 2024 module parallel use , intrinsic :: iso_fortran_env , only : int8 , int32 , int64 , real64 use precision , only : fp , dp use iso_c_binding , only : c_char , c_bool #ifdef ENABLE_MPI use mpi #endif implicit none #ifndef ENABLE_MPI integer , parameter :: MPI_COMM_NULL = 0 integer , parameter :: PARALLEL_INT = int32 #else integer , parameter :: PARALLEL_INT = MPI_INTEGER_KIND #endif private public :: par_env_t public :: PARALLEL_INT public :: MPI_COMM_NULL type :: par_env_t integer ( PARALLEL_INT ) :: comm = MPI_COMM_NULL integer ( PARALLEL_INT ) :: rank = 0 integer ( PARALLEL_INT ) :: size = 1 integer ( PARALLEL_INT ) :: err = 0 logical ( c_bool ) :: use_mpi = . false . contains procedure , pass ( self ) :: init => par_env_t_init procedure , pass ( self ) :: barrier => par_env_t_barrier procedure , pass ( self ) :: get_hostnames procedure , pass ( self ) :: par_env_t_bcast_int32_scalar procedure , pass ( self ) :: par_env_t_allreduce_int32_scalar procedure , pass ( self ) :: par_env_t_bcast_int32_1d procedure , pass ( self ) :: par_env_t_allreduce_int32_1d procedure , pass ( self ) :: par_env_t_bcast_int64_scalar procedure , pass ( self ) :: par_env_t_allreduce_int64_scalar procedure , pass ( self ) :: par_env_t_bcast_int64_1d procedure , pass ( self ) :: par_env_t_allreduce_int64_1d procedure , pass ( self ) :: par_env_t_bcast_dp_scalar procedure , pass ( self ) :: par_env_t_allreduce_dp_scalar procedure , pass ( self ) :: par_env_t_bcast_dp_1d procedure , pass ( self ) :: par_env_t_allreduce_dp_1d procedure , pass ( self ) :: par_env_t_bcast_dp_2d procedure , pass ( self ) :: par_env_t_allreduce_dp_2d procedure , pass ( self ) :: par_env_t_bcast_dp_3d procedure , pass ( self ) :: par_env_t_allreduce_dp_3d procedure , pass ( self ) :: par_env_t_bcast_dp_4d procedure , pass ( self ) :: par_env_t_allreduce_dp_4d procedure , pass ( self ) :: par_env_t_bcast_byte procedure , pass ( self ) :: par_env_t_allreduce_byte procedure , pass ( self ) :: par_env_t_bcast_c_bool procedure , pass ( self ) :: par_env_t_allreduce_c_bool generic :: bcast => & par_env_t_bcast_int32_scalar ,& par_env_t_bcast_int32_1d ,& par_env_t_bcast_int64_scalar ,& par_env_t_bcast_int64_1d ,& par_env_t_bcast_dp_scalar ,& par_env_t_bcast_dp_1d ,& par_env_t_bcast_dp_2d ,& par_env_t_bcast_dp_3d ,& par_env_t_bcast_dp_4d ,& par_env_t_bcast_byte ,& par_env_t_bcast_c_bool generic :: allreduce => & par_env_t_allreduce_int32_scalar ,& par_env_t_allreduce_int32_1d ,& par_env_t_allreduce_int64_scalar ,& par_env_t_allreduce_int64_1d ,& par_env_t_allreduce_dp_scalar ,& par_env_t_allreduce_dp_1d ,& par_env_t_allreduce_dp_2d ,& par_env_t_allreduce_dp_3d ,& par_env_t_allreduce_dp_4d ,& par_env_t_allreduce_byte ,& par_env_t_allreduce_c_bool end type par_env_t contains subroutine par_env_t_init ( self , comm , use_mpi ) class ( par_env_t ), intent ( inout ) :: self integer ( PARALLEL_INT ), intent ( in ) :: comm logical ( c_bool ), intent ( in ) :: use_mpi self % use_mpi = use_mpi #ifdef ENABLE_MPI self % comm = comm if (. not . use_mpi ) return call MPI_Comm_rank ( comm , self % rank , self % err ) call MPI_Comm_size ( comm , self % size , self % err ) #else self % use_mpi = . FALSE . self % rank = 0 self % err = 0 #endif end subroutine par_env_t_init subroutine par_env_t_barrier ( self ) class ( par_env_t ) :: self #ifndef ENABLE_MPI return #else if ( self % use_mpi ) then call MPI_Barrier ( self % comm , self % err ) endif #endif end subroutine par_env_t_barrier !################################## subroutine get_hostnames ( self , node_info_str ) implicit none character ( len = :), allocatable , intent ( inout ) :: node_info_str class ( par_env_t ), intent ( inout ) :: self integer ( PARALLEL_INT ), PARAMETER :: max_host_print = 4 #ifdef ENABLE_MPI integer ( PARALLEL_INT ) :: node_comm , local_rank , node_root_comm , ierr integer ( PARALLEL_INT ) :: num_nodes character ( len = MPI_MAX_PROCESSOR_NAME ) :: hostname integer ( PARALLEL_INT ) :: node_info_len character ( len = MPI_MAX_PROCESSOR_NAME ), allocatable :: gathered_node_names (:) integer :: i character ( len = 32 ) :: num_nodes_str #endif integer ( PARALLEL_INT ) :: name_len name_len = 28 #ifndef ENABLE_MPI allocate ( character ( len = name_len ) :: node_info_str ) call hostnm ( node_info_str ) #else if ( self % use_mpi ) then call MPI_Comm_split_type ( self % comm , MPI_COMM_TYPE_SHARED , int ( 0 , kind = PARALLEL_INT ), MPI_INFO_NULL , node_comm , ierr ) call MPI_Comm_rank ( node_comm , local_rank , ierr ) call MPI_Comm_split ( self % comm , int ( merge ( 0 , 1 , local_rank == 0 ), kind = PARALLEL_INT ), self % rank , node_root_comm , ierr ) if ( local_rank == 0 ) then call MPI_Comm_size ( node_root_comm , num_nodes , ierr ) end if call MPI_Bcast ( num_nodes , int ( 1 , kind = PARALLEL_INT ), MPI_INTEGER , int ( 0 , kind = PARALLEL_INT ), self % comm , ierr ) call MPI_Get_processor_name ( hostname , name_len , ierr ) if ( local_rank == 0 . and . num_nodes <= max_host_print ) then allocate ( gathered_node_names ( num_nodes )) call MPI_Gather ( hostname , MPI_MAX_PROCESSOR_NAME , MPI_CHARACTER , gathered_node_names , MPI_MAX_PROCESSOR_NAME , MPI_CHARACTER ,& int ( 0 , kind = PARALLEL_INT ) , node_root_comm , ierr ) end if if ( self % rank == 0 ) then if ( num_nodes > max_host_print ) then write ( num_nodes_str , '(I0)' ) num_nodes node_info_str = \"Number of nodes \" // trim ( num_nodes_str ) else node_info_str = '' do i = 1 , num_nodes node_info_str = trim ( node_info_str ) // trim ( gathered_node_names ( i )) // ', ' end do node_info_str = node_info_str ( 1 : len_trim ( node_info_str ) - 1 ) end if end if if ( self % rank == 0 ) then node_info_len = len_trim ( node_info_str ) endif call MPI_Bcast ( node_info_len , int ( 1 , kind = PARALLEL_INT ), MPI_INTEGER , int ( 0 , kind = PARALLEL_INT ), self % comm , ierr ) if ( self % rank /= 0 ) then allocate ( character ( len = node_info_len ) :: node_info_str ) end if call MPI_Bcast ( node_info_str , node_info_len , MPI_CHARACTER , int ( 0 , kind = PARALLEL_INT ), self % comm , ierr ) if ( local_rank == 0 . and . num_nodes <= max_host_print ) then deallocate ( gathered_node_names ) call MPI_Comm_free ( node_root_comm , ierr ) end if call MPI_Comm_free ( node_comm , ierr ) else allocate ( character ( len = name_len ) :: node_info_str ) call hostnm ( node_info_str ) endif #endif end subroutine get_hostnames !################################## subroutine par_env_t_bcast_int32_scalar ( self , buffer , length , root ) class ( par_env_t ), intent ( inout ) :: self integer ( int32 ), intent ( inout ) :: buffer integer , intent ( in ) :: length integer ( PARALLEL_INT ), optional , intent ( in ) :: root integer ( PARALLEL_INT ) :: root_ #ifndef ENABLE_MPI self % err = 0 return #else if (. not . self % use_mpi ) return root_ = 0 if ( present ( root )) root_ = root call MPI_Bcast ( buffer , int ( length , kind = PARALLEL_INT ), MPI_INTEGER , root_ , self % comm , self % err ) #endif end subroutine par_env_t_bcast_int32_scalar subroutine par_env_t_allreduce_int32_scalar ( self , buffer , length ) class ( par_env_t ), intent ( inout ) :: self integer ( int32 ), intent ( inout ) :: buffer integer , intent ( in ) :: length #ifndef ENABLE_MPI self % err = 0 return #else if (. not . self % use_mpi ) return call MPI_Allreduce ( MPI_IN_PLACE , buffer , int ( length , kind = PARALLEL_INT ), MPI_INTEGER , MPI_SUM , self % comm , self % err ) #endif end subroutine par_env_t_allreduce_int32_scalar subroutine par_env_t_bcast_int32_1d ( self , buffer , length , root ) class ( par_env_t ), intent ( inout ) :: self integer ( int32 ), intent ( inout ) :: buffer (:) integer , intent ( in ) :: length integer ( PARALLEL_INT ), optional , intent ( in ) :: root integer ( PARALLEL_INT ) :: root_ #ifndef ENABLE_MPI self % err = 0 return #else if (. not . self % use_mpi ) return root_ = 0 if ( present ( root )) root_ = root call MPI_Bcast ( buffer , int ( length , kind = PARALLEL_INT ), MPI_INTEGER , root_ , self % comm , self % err ) #endif end subroutine par_env_t_bcast_int32_1d subroutine par_env_t_allreduce_int32_1d ( self , buffer , length ) class ( par_env_t ), intent ( inout ) :: self integer ( int32 ), intent ( inout ) :: buffer (:) integer , intent ( in ) :: length #ifndef ENABLE_MPI self % err = 0 return #else if (. not . self % use_mpi ) return call MPI_Allreduce ( MPI_IN_PLACE , buffer , int ( length , kind = PARALLEL_INT ), MPI_INTEGER , MPI_SUM , self % comm , self % err ) #endif end subroutine par_env_t_allreduce_int32_1d subroutine par_env_t_bcast_int64_scalar ( self , buffer , length , root ) class ( par_env_t ), intent ( inout ) :: self integer ( int64 ), intent ( inout ) :: buffer integer , intent ( in ) :: length integer ( PARALLEL_INT ), optional , intent ( in ) :: root integer ( PARALLEL_INT ) :: root_ #ifndef ENABLE_MPI self % err = 0 return #else if (. not . self % use_mpi ) return root_ = 0 if ( present ( root )) root_ = root call MPI_Bcast ( buffer , int ( length , kind = PARALLEL_INT ), MPI_INTEGER8 , root_ , self % comm , self % err ) #endif end subroutine par_env_t_bcast_int64_scalar subroutine par_env_t_allreduce_int64_scalar ( self , buffer , length ) class ( par_env_t ), intent ( inout ) :: self integer ( int64 ), intent ( inout ) :: buffer integer , intent ( in ) :: length #ifndef ENABLE_MPI self % err = 0 return #else if (. not . self % use_mpi ) return call MPI_Allreduce ( MPI_IN_PLACE , buffer , int ( length , kind = PARALLEL_INT ), MPI_INTEGER8 , MPI_SUM , self % comm , self % err ) #endif end subroutine par_env_t_allreduce_int64_scalar subroutine par_env_t_bcast_int64_1d ( self , buffer , length , root ) class ( par_env_t ), intent ( inout ) :: self integer ( int64 ), intent ( inout ) :: buffer (:) integer , intent ( in ) :: length integer ( PARALLEL_INT ), optional , intent ( in ) :: root integer ( PARALLEL_INT ) :: root_ #ifndef ENABLE_MPI self % err = 0 return #else if (. not . self % use_mpi ) return root_ = 0 if ( present ( root )) root_ = root call MPI_Bcast ( buffer , int ( length , kind = PARALLEL_INT ), MPI_INTEGER8 , root_ , self % comm , self % err ) #endif end subroutine par_env_t_bcast_int64_1d subroutine par_env_t_allreduce_int64_1d ( self , buffer , length ) class ( par_env_t ), intent ( inout ) :: self integer ( int64 ), intent ( inout ) :: buffer (:) integer , intent ( in ) :: length #ifndef ENABLE_MPI self % err = 0 return #else if (. not . self % use_mpi ) return call MPI_Allreduce ( MPI_IN_PLACE , buffer , int ( length , kind = PARALLEL_INT ), MPI_INTEGER8 , MPI_SUM , self % comm , self % err ) #endif end subroutine par_env_t_allreduce_int64_1d subroutine par_env_t_bcast_dp_scalar ( self , buffer , length , root ) class ( par_env_t ), intent ( inout ) :: self real ( kind = dp ), intent ( inout ) :: buffer integer , intent ( in ) :: length integer ( PARALLEL_INT ), optional , intent ( in ) :: root integer ( PARALLEL_INT ) :: root_ #ifndef ENABLE_MPI self % err = 0 return #else if (. not . self % use_mpi ) return root_ = 0 if ( present ( root )) root_ = root call MPI_Bcast ( buffer , int ( length , kind = PARALLEL_INT ), MPI_DOUBLE_PRECISION , root_ , self % comm , self % err ) #endif end subroutine par_env_t_bcast_dp_scalar subroutine par_env_t_allreduce_dp_scalar ( self , buffer , length ) class ( par_env_t ), intent ( inout ) :: self real ( kind = dp ), intent ( inout ) :: buffer integer , intent ( in ) :: length #ifndef ENABLE_MPI self % err = 0 return #else if (. not . self % use_mpi ) return call MPI_Allreduce ( MPI_IN_PLACE , buffer , int ( length , kind = PARALLEL_INT ), MPI_DOUBLE_PRECISION , MPI_SUM , self % comm , self % err ) #endif end subroutine par_env_t_allreduce_dp_scalar subroutine par_env_t_bcast_dp_1d ( self , buffer , length , root ) class ( par_env_t ), intent ( inout ) :: self real ( kind = dp ), intent ( inout ) :: buffer (:) integer , intent ( in ) :: length integer ( PARALLEL_INT ), optional , intent ( in ) :: root integer ( PARALLEL_INT ) :: root_ #ifndef ENABLE_MPI self % err = 0 return #else if (. not . self % use_mpi ) return root_ = 0 if ( present ( root )) root_ = root call MPI_Bcast ( buffer , int ( length , kind = PARALLEL_INT ), MPI_DOUBLE_PRECISION , root_ , self % comm , self % err ) #endif end subroutine par_env_t_bcast_dp_1d subroutine par_env_t_allreduce_dp_1d ( self , buffer , length ) class ( par_env_t ), intent ( inout ) :: self real ( kind = dp ), intent ( inout ) :: buffer (:) integer , intent ( in ) :: length #ifndef ENABLE_MPI self % err = 0 return #else if (. not . self % use_mpi ) return call MPI_Allreduce ( MPI_IN_PLACE , buffer , int ( length , kind = PARALLEL_INT ), MPI_DOUBLE_PRECISION , MPI_SUM , self % comm , self % err ) #endif end subroutine par_env_t_allreduce_dp_1d subroutine par_env_t_bcast_dp_2d ( self , buffer , length , root ) class ( par_env_t ), intent ( inout ) :: self real ( kind = dp ), intent ( inout ) :: buffer (:,:) integer , intent ( in ) :: length integer ( PARALLEL_INT ), optional , intent ( in ) :: root integer ( PARALLEL_INT ) :: root_ #ifndef ENABLE_MPI self % err = 0 return #else if (. not . self % use_mpi ) return root_ = 0 if ( present ( root )) root_ = root call MPI_Bcast ( buffer , int ( length , kind = PARALLEL_INT ), MPI_DOUBLE_PRECISION , root_ , self % comm , self % err ) #endif end subroutine par_env_t_bcast_dp_2d subroutine par_env_t_allreduce_dp_2d ( self , buffer , length ) class ( par_env_t ), intent ( inout ) :: self real ( kind = dp ), intent ( inout ) :: buffer (:,:) integer , intent ( in ) :: length #ifndef ENABLE_MPI self % err = 0 return #else if (. not . self % use_mpi ) return call MPI_Allreduce ( MPI_IN_PLACE , buffer , int ( length , kind = PARALLEL_INT ), MPI_DOUBLE_PRECISION , MPI_SUM , self % comm , self % err ) #endif end subroutine par_env_t_allreduce_dp_2d subroutine par_env_t_bcast_dp_3d ( self , buffer , length , root ) class ( par_env_t ), intent ( inout ) :: self real ( kind = dp ), intent ( inout ) :: buffer (:,:,:) integer , intent ( in ) :: length integer ( PARALLEL_INT ), optional , intent ( in ) :: root integer ( PARALLEL_INT ) :: root_ #ifndef ENABLE_MPI self % err = 0 return #else if (. not . self % use_mpi ) return root_ = 0 if ( present ( root )) root_ = root call MPI_Bcast ( buffer , int ( length , kind = PARALLEL_INT ), MPI_DOUBLE_PRECISION , root_ , self % comm , self % err ) #endif end subroutine par_env_t_bcast_dp_3d subroutine par_env_t_allreduce_dp_3d ( self , buffer , length ) class ( par_env_t ), intent ( inout ) :: self real ( kind = dp ), intent ( inout ) :: buffer (:,:,:) integer , intent ( in ) :: length #ifndef ENABLE_MPI self % err = 0 return #else if (. not . self % use_mpi ) return call MPI_Allreduce ( MPI_IN_PLACE , buffer , int ( length , kind = PARALLEL_INT ), MPI_DOUBLE_PRECISION , MPI_SUM , self % comm , self % err ) #endif end subroutine par_env_t_allreduce_dp_3d subroutine par_env_t_bcast_dp_4d ( self , buffer , length , root ) class ( par_env_t ), intent ( inout ) :: self real ( kind = dp ), intent ( inout ) :: buffer (:,:,:,:) integer , intent ( in ) :: length integer ( PARALLEL_INT ), optional , intent ( in ) :: root integer ( PARALLEL_INT ) :: root_ #ifndef ENABLE_MPI self % err = 0 return #else if (. not . self % use_mpi ) return root_ = 0 if ( present ( root )) root_ = root call MPI_Bcast ( buffer , int ( length , kind = PARALLEL_INT ), MPI_DOUBLE_PRECISION , root_ , self % comm , self % err ) #endif end subroutine par_env_t_bcast_dp_4d subroutine par_env_t_allreduce_dp_4d ( self , buffer , length ) class ( par_env_t ), intent ( inout ) :: self real ( kind = dp ), intent ( inout ) :: buffer (:,:,:,:) integer , intent ( in ) :: length #ifndef ENABLE_MPI self % err = 0 return #else if (. not . self % use_mpi ) return call MPI_Allreduce ( MPI_IN_PLACE , buffer , int ( length , kind = PARALLEL_INT ), MPI_DOUBLE_PRECISION , MPI_SUM , self % comm , self % err ) #endif end subroutine par_env_t_allreduce_dp_4d subroutine par_env_t_bcast_byte ( self , buffer , length , root ) class ( par_env_t ), intent ( inout ) :: self character ( kind = c_char , len = 1 ), intent ( inout ) :: buffer ( * ) integer , intent ( in ) :: length integer ( PARALLEL_INT ), optional , intent ( in ) :: root integer ( PARALLEL_INT ) :: root_ #ifndef ENABLE_MPI self % err = 0 return #else if (. not . self % use_mpi ) return root_ = 0 if ( present ( root )) root_ = root call MPI_Bcast ( buffer , int ( length , kind = PARALLEL_INT ), MPI_BYTE , root_ , self % comm , self % err ) #endif end subroutine par_env_t_bcast_byte subroutine par_env_t_allreduce_byte ( self , buffer , length ) class ( par_env_t ), intent ( inout ) :: self character ( kind = c_char , len = 1 ), intent ( inout ) :: buffer ( * ) integer , intent ( in ) :: length #ifndef ENABLE_MPI self % err = 0 return #else if (. not . self % use_mpi ) return call MPI_Allreduce ( MPI_IN_PLACE , buffer , int ( length , kind = PARALLEL_INT ), MPI_BYTE , MPI_SUM , self % comm , self % err ) #endif end subroutine par_env_t_allreduce_byte subroutine par_env_t_bcast_c_bool ( self , buffer , length , root ) class ( par_env_t ), intent ( inout ) :: self logical ( c_bool ), intent ( inout ) :: buffer integer , intent ( in ) :: length integer ( PARALLEL_INT ), optional , intent ( in ) :: root integer ( PARALLEL_INT ) :: root_ #ifndef ENABLE_MPI self % err = 0 return #else if (. not . self % use_mpi ) return root_ = 0 if ( present ( root )) root_ = root call MPI_Bcast ( buffer , int ( length , kind = PARALLEL_INT ), MPI_C_BOOL , root_ , self % comm , self % err ) #endif end subroutine par_env_t_bcast_c_bool subroutine par_env_t_allreduce_c_bool ( self , buffer , length ) class ( par_env_t ), intent ( inout ) :: self logical ( c_bool ), intent ( inout ) :: buffer integer , intent ( in ) :: length #ifndef ENABLE_MPI self % err = 0 return #else if (. not . self % use_mpi ) return call MPI_Allreduce ( MPI_IN_PLACE , buffer , int ( length , kind = PARALLEL_INT ), MPI_C_BOOL , MPI_SUM , self % comm , self % err ) #endif end subroutine par_env_t_allreduce_c_bool end module parallel","tags":"","url":"sourcefile/parallel.f90.html"},{"title":"mod_gauss_hermite.F90 – OpenQP Fortran API","text":"Source Code !#define DEBUG ! Protecting macro for compilers which does not support OpenMP 4.0 #define OMPSIMD (_OPENMP >= 201307) !> @brief Gauss-Hermite quadrature used in one-electron integral code !> @author   Vladimir Mironov ! !     REVISION HISTORY: !> @date _Sep, 2018_ Initial release ! module mod_gauss_hermite use precision , only : dp !    use constants, only: h => hermit, w => hermitw implicit none private public doQuadGaussHermite public mulQuadGaussHermite !  Roots and weights for Gauss-Hermite quadrature !  The values used below were obtained by running the routine given !  in the \"numerical recipes\" book in quadruple precision. real ( kind = dp ), parameter :: h2d ( 10 , 10 ) = reshape ([& 0.0000000000000000000D+00 , 0.0000000000000000000D+00 , 0.0000000000000000000D+00 , 0.0000000000000000000D+00 , & 0.0000000000000000000D+00 , 0.0000000000000000000D+00 , 0.0000000000000000000D+00 , 0.0000000000000000000D+00 , & 0.0000000000000000000D+00 , 0.0000000000000000000D+00 , - 7.0710678118654752440D-01 , 7.0710678118654752440D-01 , & 0.0000000000000000000D+00 , 0.0000000000000000000D+00 , 0.0000000000000000000D+00 , 0.0000000000000000000D+00 , & 0.0000000000000000000D+00 , 0.0000000000000000000D+00 , 0.0000000000000000000D+00 , 0.0000000000000000000D+00 , & - 1.2247448713915890491D+00 , 0.0000000000000000000D+00 , 1.2247448713915890491D+00 , 0.0000000000000000000D+00 , & 0.0000000000000000000D+00 , 0.0000000000000000000D+00 , 0.0000000000000000000D+00 , 0.0000000000000000000D+00 , & 0.0000000000000000000D+00 , 0.0000000000000000000D+00 , - 1.6506801238857845559D+00 , - 5.2464762327529031788D-01 , & 5.2464762327529031788D-01 , 1.6506801238857845559D+00 , 0.0000000000000000000D+00 , 0.0000000000000000000D+00 , & 0.0000000000000000000D+00 , 0.0000000000000000000D+00 , 0.0000000000000000000D+00 , 0.0000000000000000000D+00 , & - 2.0201828704560856329D+00 , - 9.5857246461381850711D-01 , 0.0000000000000000000D+00 , 9.5857246461381850711D-01 , & 2.0201828704560856329D+00 , 0.0000000000000000000D+00 , 0.0000000000000000000D+00 , 0.0000000000000000000D+00 , & 0.0000000000000000000D+00 , 0.0000000000000000000D+00 , - 2.3506049736744922228D+00 , - 1.3358490740136969497D+00 , & - 4.3607741192761650868D-01 , 4.3607741192761650868D-01 , 1.3358490740136969497D+00 , 2.3506049736744922228D+00 , & 0.0000000000000000000D+00 , 0.0000000000000000000D+00 , 0.0000000000000000000D+00 , 0.0000000000000000000D+00 , & - 2.6519613568352334925D+00 , - 1.6735516287674714450D+00 , - 8.1628788285896466304D-01 , 0.0000000000000000000D+00 , & 8.1628788285896466304D-01 , 1.6735516287674714450D+00 , 2.6519613568352334925D+00 , 0.0000000000000000000D+00 , & 0.0000000000000000000D+00 , 0.0000000000000000000D+00 , - 2.9306374202572440192D+00 , - 1.9816567566958429259D+00 , & - 1.1571937124467801947D+00 , - 3.8118699020732211685D-01 , 3.8118699020732211685D-01 , 1.1571937124467801947D+00 , & 1.9816567566958429259D+00 , 2.9306374202572440192D+00 , 0.0000000000000000000D+00 , 0.0000000000000000000D+00 , & - 3.1909932017815276072D+00 , - 2.2665805845318431118D+00 , - 1.4685532892166679317D+00 , - 7.2355101875283757332D-01 , & 0.0000000000000000000D+00 , 7.2355101875283757332D-01 , 1.4685532892166679317D+00 , 2.2665805845318431118D+00 , & 3.1909932017815276072D+00 , 0.0000000000000000000D+00 , - 3.4361591188377376033D+00 , - 2.5327316742327897964D+00 , & - 1.7566836492998817735D+00 , - 1.0366108297895136542D+00 , - 3.4290132722370460879D-01 , 3.4290132722370460879D-01 , & 1.0366108297895136542D+00 , 1.7566836492998817735D+00 , 2.5327316742327897964D+00 , 3.4361591188377376033D+00 & ], shape = shape ( h2d )) real ( kind = dp ), parameter :: w2d ( 10 , 10 ) = reshape ([& 1.7724538509055160273D+00 , 0.0000000000000000000D+00 , 0.0000000000000000000D+00 , 0.0000000000000000000D+00 , & 0.0000000000000000000D+00 , 0.0000000000000000000D+00 , 0.0000000000000000000D+00 , 0.0000000000000000000D+00 , & 0.0000000000000000000D+00 , 0.0000000000000000000D+00 , 8.8622692545275801365D-01 , 8.8622692545275801365D-01 , & 0.0000000000000000000D+00 , 0.0000000000000000000D+00 , 0.0000000000000000000D+00 , 0.0000000000000000000D+00 , & 0.0000000000000000000D+00 , 0.0000000000000000000D+00 , 0.0000000000000000000D+00 , 0.0000000000000000000D+00 , & 2.9540897515091933788D-01 , 1.1816359006036773515D+00 , 2.9540897515091933788D-01 , 0.0000000000000000000D+00 , & 0.0000000000000000000D+00 , 0.0000000000000000000D+00 , 0.0000000000000000000D+00 , 0.0000000000000000000D+00 , & 0.0000000000000000000D+00 , 0.0000000000000000000D+00 , 8.1312835447245177143D-02 , 8.0491409000551283651D-01 , & 8.0491409000551283651D-01 , 8.1312835447245177143D-02 , 0.0000000000000000000D+00 , 0.0000000000000000000D+00 , & 0.0000000000000000000D+00 , 0.0000000000000000000D+00 , 0.0000000000000000000D+00 , 0.0000000000000000000D+00 , & 1.9953242059045913208D-02 , 3.9361932315224115983D-01 , 9.4530872048294188123D-01 , 3.9361932315224115983D-01 , & 1.9953242059045913208D-02 , 0.0000000000000000000D+00 , 0.0000000000000000000D+00 , 0.0000000000000000000D+00 , & 0.0000000000000000000D+00 , 0.0000000000000000000D+00 , 4.5300099055088456409D-03 , 1.5706732032285664392D-01 , & 7.2462959522439252409D-01 , 7.2462959522439252409D-01 , 1.5706732032285664392D-01 , 4.5300099055088456409D-03 , & 0.0000000000000000000D+00 , 0.0000000000000000000D+00 , 0.0000000000000000000D+00 , 0.0000000000000000000D+00 , & 9.7178124509951915415D-04 , 5.4515582819127030592D-02 , 4.2560725261012780052D-01 , 8.1026461755680732676D-01 , & 4.2560725261012780052D-01 , 5.4515582819127030592D-02 , 9.7178124509951915415D-04 , 0.0000000000000000000D+00 , & 0.0000000000000000000D+00 , 0.0000000000000000000D+00 , 1.9960407221136761921D-04 , 1.7077983007413475456D-02 , & 2.0780232581489187954D-01 , 6.6114701255824129103D-01 , 6.6114701255824129103D-01 , 2.0780232581489187954D-01 , & 1.7077983007413475456D-02 , 1.9960407221136761921D-04 , 0.0000000000000000000D+00 , 0.0000000000000000000D+00 , & 3.9606977263264381905D-05 , 4.9436242755369472172D-03 , 8.8474527394376573288D-02 , 4.3265155900255575020D-01 , & 7.2023521560605095712D-01 , 4.3265155900255575020D-01 , 8.8474527394376573288D-02 , 4.9436242755369472172D-03 , & 3.9606977263264381905D-05 , 0.0000000000000000000D+00 , 7.6404328552326206292D-06 , 1.3436457467812326922D-03 , & 3.3874394455481063136D-02 , 2.4013861108231468642D-01 , 6.1086263373532579878D-01 , 6.1086263373532579878D-01 , & 2.4013861108231468642D-01 , 3.3874394455481063136D-02 , 1.3436457467812326922D-03 , 7.6404328552326206292D-06 & ], shape = shape ( w2d )) contains !-------------------------------------------------------------------------------- !> @brief Gauss-Hermite quadrature using minimum point formula !> @details Compute: !>  xint = sum( w(1:npts,npts) * (h(1:npts,npts)*t+dxi)**(ni-1) * (h(1:npts,npts)*t+dxj)**(nj-1) ) !>  yint = sum( w(1:npts,npts) * (h(1:npts,npts)*t+dyi)**(ni-1) * (h(1:npts,npts)*t+dyj)**(nj-1) ) !>  zint = sum( w(1:npts,npts) * (h(1:npts,npts)*t+dzi)**(ni-1) * (h(1:npts,npts)*t+dzj)**(nj-1) ) !> @note Use of I functions will let NI run up to 7 (S=1, P=2, ..., I=7) !>       Use of I functions will let NJ run up to 9 (for K.E. ints) !>       Use of I functions requires NPTS=8 to do kinetic energy integrals. !> @param[out]      xint        x-component of the integral !> @param[out]      yint        y-component of the integral !> @param[out]      zint        z-component of the integral !> @param[out]      t           inverse square root of total exponent !> @param[out]      x0          `x`-coord. of the center of primitive pair !> @param[out]      y0          `y`-coord. of the center of primitive pair !> @param[out]      z0          `z`-coord. of the center of primitive pair !> @param[out]      xi          `x`-coord. of the center of 1st primitive !> @param[out]      yi          `y`-coord. of the center of 1st primitive !> @param[out]      zi          `z`-coord. of the center of 1st primitive !> @param[out]      xj          `x`-coord. of the center of 2nd primitive !> @param[out]      yj          `y`-coord. of the center of 2nd primitive !> @param[out]      zj          `z`-coord. of the center of 2nd primitive !> @param[out]      ni          current angular momentum on center i !> @param[out]      nj          current angular momentum on center j ! !> @note based on STVINT from int1.src ! !> @author   Vladimir Mironov ! !     REVISION HISTORY: !> @date _Sep, 2018_ Initial release ! subroutine doQuadGaussHermite ( tint , t , rij , ri , rj , ni , nj ) !dir$ attributes forceinline :: doQuadGaussHermite real ( kind = dp ), intent ( out ) :: tint ( 3 ) real ( kind = dp ), intent ( in ) :: t real ( kind = dp ), intent ( in ) :: rij ( 3 ), ri ( 3 ), rj ( 3 ) integer , intent ( in ) :: ni , nj real ( kind = dp ) :: dqi ( 3 ), dqj ( 3 ), p ( 3 ) integer :: i , j , npts #ifdef DEBUG if ( ni > 6 . or . nj > 8 . or . ni < 0 . or . nj < 0 ) then write ( * , '(\" stvint: exceeded limitations, with ni,nj=\",2i5)' ) ni , nj call abrt return end if #endif npts = ( ni + nj ) / 2 + 1 dqi = rij - ri dqj = rij - rj tint = 0.0 #if OMPSIMD !!$omp simd reduction(+:tint) & !!$omp   private(p) #endif do i = 1 , npts p = w2d ( i , npts ) do j = 1 , ni p = p * ( h2d ( i , npts ) * t + dqi ) end do do j = 1 , nj p = p * ( h2d ( i , npts ) * t + dqj ) end do tint = tint + p end do end subroutine !-------------------------------------------------------------------------------- !> @brief Gauss-Hermite quadrature using minimum point formula !> @details Compute: !>  xint = sum( w(1:npts,npts) * (h(1:npts,npts)*t+dxi)**(ni-1) * (h(1:npts,npts)*t+dxj)**(nj-1) ) !>  yint = sum( w(1:npts,npts) * (h(1:npts,npts)*t+dyi)**(ni-1) * (h(1:npts,npts)*t+dyj)**(nj-1) ) !>  zint = sum( w(1:npts,npts) * (h(1:npts,npts)*t+dzi)**(ni-1) * (h(1:npts,npts)*t+dzj)**(nj-1) ) !> @note Use of I functions will let NI run up to 7 (S=1, P=2, ..., I=7) !>       Use of I functions will let NJ run up to 9 (for K.E. ints) !>       Use of I functions requires NPTS=8 to do kinetic energy integrals. !> @param[out]      xint        x-component of the integral !> @param[out]      yint        y-component of the integral !> @param[out]      zint        z-component of the integral !> @param[out]      t           inverse square root of total exponent !> @param[out]      x0          `x`-coord. of the center of primitive pair !> @param[out]      y0          `y`-coord. of the center of primitive pair !> @param[out]      z0          `z`-coord. of the center of primitive pair !> @param[out]      xi          `x`-coord. of the center of 1st primitive !> @param[out]      yi          `y`-coord. of the center of 1st primitive !> @param[out]      zi          `z`-coord. of the center of 1st primitive !> @param[out]      xj          `x`-coord. of the center of 2nd primitive !> @param[out]      yj          `y`-coord. of the center of 2nd primitive !> @param[out]      zj          `z`-coord. of the center of 2nd primitive !> @param[out]      ni          current angular momentum on center i !> @param[out]      nj          current angular momentum on center j ! !> @note based on STVINT from int1.src ! !> @author   Vladimir Mironov ! !     REVISION HISTORY: !> @date _Sep, 2018_ Initial release ! subroutine mulQuadGaussHermite ( tint , t , rij , ri , rj , r , ni , nj , m ) !dir$ attributes forceinline :: doQuadGaussHermite real ( kind = dp ), intent ( out ) :: tint ( 3 , 0 : * ) real ( kind = dp ), intent ( in ) :: t real ( kind = dp ), intent ( in ) :: rij ( 3 ), ri ( 3 ), rj ( 3 ), r ( 3 ) integer , intent ( in ) :: ni , nj , m real ( kind = dp ) :: dqi ( 3 ), dqj ( 3 ), dqc ( 3 ), p ( 3 ) integer :: i , j , npts #ifdef DEBUG if ( ni > 6 . or . nj > 8 . or . ni < 0 . or . nj < 0 ) then write ( * , '(\" stvint: exceeded limitations, with ni,nj=\",2i5)' ) ni , nj call abrt return end if #endif npts = ( ni + nj + m ) / 2 + 1 dqi = rij - ri dqj = rij - rj dqc = rij - r tint (:, 0 : m ) = 0.0 #if OMPSIMD !!$omp simd reduction(+:tint) & !!$omp   private(p) #endif do i = 1 , npts p = w2d ( i , npts ) do j = 1 , ni p = p * ( h2d ( i , npts ) * t + dqi ) end do do j = 1 , nj p = p * ( h2d ( i , npts ) * t + dqj ) end do do j = 0 , m tint (:, j ) = tint (:, j ) + p p = p * ( h2d ( i , npts ) * t + dqc ) end do end do end subroutine end module","tags":"","url":"sourcefile/mod_gauss_hermite.f90.html"},{"title":"vibrational_intensities.F90 – OpenQP Fortran API","text":"Source Code module vibrational_intensities_mod use iso_c_binding , only : c_double , c_int64_t , c_ptr , c_f_pointer implicit none private public :: vibrational_intensities_native_C real ( c_double ), parameter :: IR_INTENSITY_CONVERSION = 4 2.255d0 contains subroutine vibrational_intensities_native_C ( c_handle , nmode , ncoord , modes_ptr , dipole_derivs_ptr , & polar_derivs_ptr , ir_ptr , mode_dipoles_ptr , raman_ptr , mode_polars_ptr ) & bind ( C , name = \"vibrational_intensities_native\" ) use c_interop , only : oqp_handle_t type ( oqp_handle_t ) :: c_handle integer ( c_int64_t ), value :: nmode , ncoord type ( c_ptr ), value :: modes_ptr , dipole_derivs_ptr , polar_derivs_ptr type ( c_ptr ), value :: ir_ptr , mode_dipoles_ptr , raman_ptr , mode_polars_ptr real ( c_double ), pointer :: modes (:), dipole_derivs (:), polar_derivs (:) real ( c_double ), pointer :: ir (:), mode_dipoles (:), raman (:), mode_polars (:) integer ( c_int64_t ) :: imode , icoord , a , b , p , mode_offset , dip_offset , polar_offset real ( c_double ) :: alpha_prime ( 3 , 3 ), alpha_bar_prime , gamma2 ! c_handle is present to match the normal OpenQP C ABI wrapper convention. associate ( unused => c_handle ) end associate call c_f_pointer ( modes_ptr , modes , [ nmode * ncoord ]) call c_f_pointer ( dipole_derivs_ptr , dipole_derivs , [ 3_c_int64_t * ncoord ]) call c_f_pointer ( polar_derivs_ptr , polar_derivs , [ 9_c_int64_t * ncoord ]) call c_f_pointer ( ir_ptr , ir , [ nmode ]) call c_f_pointer ( mode_dipoles_ptr , mode_dipoles , [ nmode * 3_c_int64_t ]) call c_f_pointer ( raman_ptr , raman , [ nmode ]) call c_f_pointer ( mode_polars_ptr , mode_polars , [ nmode * 9_c_int64_t ]) ir = 0.0_c_double raman = 0.0_c_double mode_dipoles = 0.0_c_double mode_polars = 0.0_c_double do imode = 1 , nmode mode_offset = ( imode - 1_c_int64_t ) * ncoord do p = 1 , 3 do icoord = 1 , ncoord dip_offset = ( p - 1_c_int64_t ) * ncoord + icoord mode_dipoles (( imode - 1_c_int64_t ) * 3_c_int64_t + p ) = & mode_dipoles (( imode - 1_c_int64_t ) * 3_c_int64_t + p ) + & dipole_derivs ( dip_offset ) * modes ( mode_offset + icoord ) end do end do ir ( imode ) = IR_INTENSITY_CONVERSION * sum ( mode_dipoles (( imode - 1_c_int64_t ) * 3_c_int64_t + 1 : & ( imode - 1_c_int64_t ) * 3_c_int64_t + 3 ) ** 2 ) alpha_prime = 0.0_c_double do a = 1 , 3 do b = 1 , 3 do icoord = 1 , ncoord polar_offset = (( a - 1_c_int64_t ) * 3_c_int64_t + ( b - 1_c_int64_t )) * ncoord + icoord alpha_prime ( a , b ) = alpha_prime ( a , b ) + polar_derivs ( polar_offset ) * modes ( mode_offset + icoord ) end do mode_polars (( imode - 1_c_int64_t ) * 9_c_int64_t + ( a - 1_c_int64_t ) * 3_c_int64_t + b ) = & alpha_prime ( a , b ) end do end do alpha_bar_prime = ( alpha_prime ( 1 , 1 ) + alpha_prime ( 2 , 2 ) + alpha_prime ( 3 , 3 )) / 3.0_c_double gamma2 = 0.5_c_double * (( alpha_prime ( 1 , 1 ) - alpha_prime ( 2 , 2 )) ** 2 + & ( alpha_prime ( 2 , 2 ) - alpha_prime ( 3 , 3 )) ** 2 + & ( alpha_prime ( 3 , 3 ) - alpha_prime ( 1 , 1 )) ** 2 + & 6.0_c_double * ( alpha_prime ( 1 , 2 ) ** 2 + alpha_prime ( 1 , 3 ) ** 2 + alpha_prime ( 2 , 3 ) ** 2 )) raman ( imode ) = 4 5.0_c_double * alpha_bar_prime ** 2 + 7.0_c_double * gamma2 end do end subroutine vibrational_intensities_native_C end module vibrational_intensities_mod","tags":"","url":"sourcefile/vibrational_intensities.f90.html"},{"title":"tdhf_sf_lib.F90 – OpenQP Fortran API","text":"Source Code module tdhf_sf_lib use , intrinsic :: ieee_arithmetic use precision , only : dp use oqp_linalg real ( kind = dp ), parameter :: SF_DAVIDSON_DENOMINATOR_FLOOR = 1.0e-8_dp contains subroutine sfroesum ( fazzfb , pmo , noca , nocb , ivec ) use precision , only : dp implicit none real ( kind = dp ), intent ( in ), dimension (:,:) :: fazzfb real ( kind = dp ), intent ( inout ), dimension (:,:) :: pmo integer , intent ( in ) :: noca , nocb , ivec integer :: i , ij , j , nbf nbf = ubound ( fazzfb , 1 ) ij = 0 do j = nocb + 1 , nbf do i = 1 , noca ij = ij + 1 pmo ( ij , ivec ) = pmo ( ij , ivec ) + fazzfb ( i , j ) end do end do end subroutine sfroesum subroutine sfresvec ( q , a , b , vec , eigv , nvec , rnorm , ndsr ) use precision , only : dp implicit none real ( kind = dp ), intent ( out ), dimension (:,:) :: q real ( kind = dp ), intent ( in ), dimension (:,:) :: a , b real ( kind = dp ), intent ( inout ), dimension (:,:) :: vec real ( kind = dp ), intent ( in ), dimension (:) :: eigv integer , intent ( in ) :: nvec real ( kind = dp ), intent ( out ), dimension (:) :: rnorm integer , intent ( in ) :: ndsr integer :: ist , xvec_dim xvec_dim = ubound ( q , 1 ) call dgemm ( 'n' , 'n' , xvec_dim , ndsr , nvec , & 1.0_dp , b , xvec_dim , & vec , nvec , & 0.0_dp , q , xvec_dim ) do ist = 1 , ndsr vec (:, ist ) = - vec (:, ist ) * eigv ( ist ) end do call dgemm ( 'n' , 'n' , xvec_dim , ndsr , nvec , & 1.0_dp , a , xvec_dim , & vec , nvec , & 1.0_dp , q , xvec_dim ) do ist = 1 , ndsr rnorm ( ist ) = dot_product ( q (:, ist ), q (:, ist )) end do end subroutine sfresvec subroutine sfqvec ( q , xm , eigv , ndsr ) use precision , only : dp implicit none real ( kind = dp ), intent ( inout ), dimension (:,:) :: q real ( kind = dp ), intent ( in ), dimension (:) :: xm , eigv integer , intent ( in ) :: ndsr integer :: ii , ist , xvec_dim real ( kind = dp ) :: val1 xvec_dim = ubound ( xm , 1 ) do ist = 1 , ndsr do ii = 1 , xvec_dim val1 = eigv ( ist ) - xm ( ii ) if (. not . sf_davidson_safe_denominator ( val1 )) then val1 = merge ( SF_DAVIDSON_DENOMINATOR_FLOOR , - SF_DAVIDSON_DENOMINATOR_FLOOR , val1 >= 0.0_dp ) end if q ( ii , ist ) = q ( ii , ist ) / val1 if (. not . ieee_is_finite ( q ( ii , ist ))) q ( ii , ist ) = 0.0_dp end do end do end subroutine sfqvec logical function sf_davidson_safe_denominator ( denom ) use precision , only : dp implicit none real ( kind = dp ), intent ( in ) :: denom sf_davidson_safe_denominator = ieee_is_finite ( denom ) . and . abs ( denom ) >= SF_DAVIDSON_DENOMINATOR_FLOOR end function sf_davidson_safe_denominator subroutine sfesum ( eiga , eigb , pmo , z , noca , nocb , ivec ) use precision , only : dp implicit none real ( kind = dp ), intent ( in ) :: eiga (:), eigb (:) real ( kind = dp ), intent ( inout ) :: pmo (:,:) real ( kind = dp ), intent ( in ) :: z (:,:) integer , intent ( in ) :: noca , nocb , ivec integer :: i , ij , j , nbf nbf = ubound ( eiga , 1 ) !   ----- add (ea-ei)*zai ----- ij = 0 do j = nocb + 1 , nbf do i = 1 , noca ij = ij + 1 pmo ( ij , ivec ) = pmo ( ij , ivec ) + ( eigb ( j ) - eiga ( i )) * z ( ij , ivec ) end do end do end subroutine sfesum subroutine trfrmb ( bvec , vec , nvec , ndsr ) use precision , only : dp implicit none real ( kind = dp ), intent ( inout ), dimension (:,:) :: bvec real ( kind = dp ), intent ( in ), dimension (:,:) :: vec integer , intent ( in ) :: nvec , ndsr real ( kind = dp ), allocatable , dimension (:,:) :: scr integer :: xvec_dim xvec_dim = ubound ( bvec , 1 ) allocate ( scr ( xvec_dim , ndsr ), & source = 0.0_dp ) scr = bvec ! Get a new Bvec call dgemm ( 'n' , 'n' , xvec_dim , ndsr , nvec , & 1.0_dp , scr , xvec_dim , & vec , nvec ,& 0.0_dp , bvec , xvec_dim ) ! do ii = 1, xvec_dim !   do jj = 1, ndsr !   bvec(ii,jj) = 0.0_dp !     do kk = 1, nvec !       bvec(ii,jj) = bvec(ii,jj)+scr(ii,kk)*vec(kk,jj) !     end do !   end do ! end do deallocate ( scr ) end subroutine trfrmb subroutine sfdmat ( bvec , abxc , mo_a , ta , tb , & noca , nocb ) use precision , only : dp use tdhf_lib , only : iatogen use mathlib , only : pack_matrix use mathlib , only : orthogonal_transform implicit none real ( kind = dp ), intent ( in ), dimension (:) :: bvec real ( kind = dp ), intent ( in ), dimension (:,:) :: mo_a real ( kind = dp ), intent ( inout ), dimension (:,:) :: abxc real ( kind = dp ), intent ( out ), dimension (:) :: ta , tb integer , intent ( in ) :: noca , nocb integer :: nvirb , nbf , nbf_tri , xvec_dim real ( kind = dp ), allocatable , dimension (:,:) :: scr1 , scr2 nbf = ubound ( mo_a , 1 ) nbf_tri = ubound ( ta , 1 ) xvec_dim = ubound ( bvec , 1 ) allocate ( scr1 ( nbf , nbf ), & scr2 ( nbf , nbf ), & source = 0.0_dp ) ! MO(I+,A-) -> AO(M,N) nvirb = nbf - nocb call iatogen ( bvec , scr1 , noca , nocb ) call orthogonal_transform ( 't' , nbf , mo_a , scr1 , abxc , scr2 ) ! Unrelaxed difference density matrix ----- ! OCC(Alpha)-OCC(Alpha) call dgemm ( 'n' , 't' , noca , noca , nvirb , & - 1.0_dp , bvec , noca , & bvec , noca , & 0.0_dp , scr1 , noca ) ! MO(I+,J+) -> AO(M,N) call dgemm ( 'n' , 'n' , nbf , noca , noca , & 1.0_dp , mo_a , nbf , & scr1 , noca , & 0.0_dp , scr2 , nbf ) call dgemm ( 'n' , 't' , nbf , nbf , noca , & 1.0_dp , scr2 , nbf , & mo_a , nbf , & 0.0_dp , scr1 , nbf ) call pack_matrix ( scr1 , ta ) call dgemm ( 't' , 'n' , nvirb , nvirb , noca , & 1.0_dp , bvec , noca , & bvec , noca , & 0.0_dp , scr1 , nvirb ) ! MO(A-,B-) -> AO(M,N) call dgemm ( 'n' , 'n' , nbf , nvirb , nvirb , & 1.0_dp , mo_a (:, nocb + 1 :), nbf , & scr1 , nvirb , & 0.0_dp , scr2 , nbf ) call dgemm ( 'n' , 't' , nbf , nbf , nvirb , & 1.0_dp , scr2 , nbf , & mo_a (:, nocb + 1 :), nbf , & 0.0_dp , scr1 , nbf ) call pack_matrix ( scr1 , tb ) deallocate ( scr1 , scr2 ) end subroutine sfdmat subroutine get_transitions ( trans , noca , nocb , nbf ) implicit none integer , intent ( out ), dimension (:,:) :: trans integer , intent ( in ) :: noca , nocb , nbf integer :: ij , i , j ij = 0 do j = nocb + 1 , nbf do i = 1 , noca ij = ij + 1 trans ( ij , 1 ) = i trans ( ij , 2 ) = j end do end do end subroutine get_transitions pure function mrsf_state_label ( mult , root ) result ( label ) implicit none integer , intent ( in ) :: mult , root character ( len = 12 ) :: label label = '' select case ( mult ) case ( 1 ) write ( label , '(\"S\",I0)' ) root - 1 case ( 3 ) write ( label , '(\"T\",I0)' ) root - 1 case ( 5 ) write ( label , '(\"Q\",I0)' ) root - 1 case default write ( label , '(\"M\",I0,\"-\",I0)' ) mult , root end select end function mrsf_state_label subroutine print_results ( infos , bvec_mo , excitation_energy , & trans , dip , spin_square , nstates , physical_mrsf_labels ) use precision , only : dp use types , only : information use physical_constants , only : toev => ev2htree implicit none type ( information ), target , intent ( in ) :: infos real ( kind = dp ), intent ( in ), dimension (:,:) :: bvec_mo real ( kind = dp ), intent ( in ), dimension (:) :: excitation_energy integer , intent ( in ), dimension (:,:) :: trans real ( kind = dp ), intent ( in ), dimension (:,:,:) :: dip real ( kind = dp ), intent ( in ), dimension (:) :: spin_square integer , intent ( in ) :: nstates logical , intent ( in ), optional :: physical_mrsf_labels integer :: istat , jstat , ij , i , j , nocca , noccb , xvec_dim , ndeex real ( kind = dp ) :: ydum , xdum , threshold , ROHF_energy , energ , f logical :: mrsf_output character ( len = 12 ) :: state_label , state_label_j mrsf_output = . false . if ( present ( physical_mrsf_labels )) mrsf_output = physical_mrsf_labels threshold = infos % control % conf_print_threshold xvec_dim = ubound ( bvec_mo , 1 ) ROHF_energy = infos % mol_energy % energy nocca = infos % mol_prop % nelec_A noccb = infos % mol_prop % nelec_B do istat = 1 , nstates ydum = toev * excitation_energy ( istat ) if ( mrsf_output ) then state_label = mrsf_state_label ( infos % tddft % mult , istat ) write ( * , '(/,1x,\"State \",A,2X,\"Energy =\",F12.6,1X,\"eV\")' ) trim ( state_label ), ydum else write ( * , '(/,1x,\"State #\",I4,2X,\"Energy =\",F12.6,1X,\"eV\")' ) istat , ydum end if !     write(*,'(3x,\"Symmetry of state =\",4x,a)') '?a?a?' write ( * , '(15x,\"<S&#94;2> =\",1x,f9.4)' ) spin_square ( istat ) write ( * , '(8x,\"DRF\",4x,\"Coeff\",8x,\"OCC\",7x,\"VIR\")' ) write ( * , '(8x,3(\"-\"),2x,8(\"-\"),5x,6(\"-\"),4x,6(\"-\"))' ) do ij = 1 , xvec_dim i = trans ( ij , 1 ) j = trans ( ij , 2 ) xdum = bvec_mo ( ij , istat ) if ( abs ( xdum ) > threshold ) then write ( * , '(7x,i4,1x,f9.6,6x,i4,2x,\"->\",2x,i4,2x)' ) ij , xdum , i , j end if end do end do write ( * , '(/5x, \"Summary table\",/)' ) write ( * , '(1x, \"State\", 6x, \"Energy\", 7x,\"Excitation\", 3x, \"Excitation(eV)\", & &2x, \"<S&#94;2>\", 9x, \"Transition dipole moment, a.u.\",& &8x, \"Oscillator\")' ) if ( mrsf_output ) then state_label = mrsf_state_label ( infos % tddft % mult , 1 ) write ( * , '(11x, \"Hartree\", 11x, \"eV\", 8x, \"rel. \",A, & &18x, \"X\", 10x, \"Y\", 10x, \"Z\", 8x,\"Abs.\", 6x, \"strength\")' ) trim ( state_label ) else write ( * , '(11x, \"Hartree\", 11x, \"eV\", 10x, \"rel. GS\", & &18x, \"X\", 10x, \"Y\", 10x, \"Z\", 8x,\"Abs.\", 6x, \"strength\")' ) end if ndeex = 0 do istat = 1 , nstates if ( excitation_energy ( istat ) < 0.0_dp ) ndeex = ndeex + 1 end do ! De-excitation do istat = 1 , ndeex energ = excitation_energy ( istat ) - excitation_energy ( 1 ) f = 2.0d0 / 3.0d0 * ( energ ) * sum ( dip (:, 1 , istat ) ** 2 ) if ( mrsf_output ) then state_label = mrsf_state_label ( infos % tddft % mult , istat ) write ( * , '(x, a5, 1x, f17.10, 2f13.6, 6x, & &f5.3, 4(1x,f10.4),2x,f10.4)' ) & trim ( state_label ), ROHF_energy + excitation_energy ( istat ), toev * excitation_energy ( istat ), & toev * energ , spin_square ( istat ), dip ( 1 : 3 , 1 , istat ), sqrt ( sum ( dip (:, 1 , istat ) ** 2 )), f else write ( * , '(x, i3, 1x, f17.10, 2f13.6, 6x, & &f5.3, 4(1x,f10.4),2x,f10.4)' ) & istat , ROHF_energy + excitation_energy ( istat ), toev * excitation_energy ( istat ), & toev * energ , spin_square ( istat ), dip ( 1 : 3 , 1 , istat ), sqrt ( sum ( dip (:, 1 , istat ) ** 2 )), f end if end do ! The high-spin SCF determinant is an internal working reference for MRSF, ! not the physical S0 state.  Keep the old numeric form for plain SF-TDDFT. if ( mrsf_output ) then write ( * , '(1x, a5, 1x, f17.10, 2f13.6, 8x,& &\"(triplet ROHF/UHF internal working reference)\")' ) & 'REF' , ROHF_energy , 0.0_dp , - excitation_energy ( 1 ) * toev else write ( * , '(1x, i3, 1x, f17.10, 2f13.6, 8x,& &\"(ROHF/UHF Reference state)\")' ) 0 , ROHF_energy , 0.0_dp , - excitation_energy ( 1 ) * toev end if ! Excitation do istat = ndeex + 1 , nstates energ = excitation_energy ( istat ) - excitation_energy ( 1 ) f = 2.0d0 / 3.0d0 * ( energ ) * sum ( dip (:, 1 , istat ) ** 2 ) if ( mrsf_output ) then state_label = mrsf_state_label ( infos % tddft % mult , istat ) write ( * , '(x, a5, 1x, f17.10, 2f13.6, 6x, & &f5.3, 4(1x,f10.4),2x,f10.4)' ) & trim ( state_label ), ROHF_energy + excitation_energy ( istat ), toev * excitation_energy ( istat ), & toev * energ , spin_square ( istat ), dip ( 1 : 3 , 1 , istat ), sqrt ( sum ( dip (:, 1 , istat ) ** 2 )), f else write ( * , '(x, i3, 1x, f17.10, 2f13.6, 6x, & &f5.3, 4(1x,f10.4),2x,f10.4)' ) & istat , ROHF_energy + excitation_energy ( istat ), toev * excitation_energy ( istat ), & toev * energ , spin_square ( istat ), dip ( 1 : 3 , 1 , istat ), sqrt ( sum ( dip (:, 1 , istat ) ** 2 )), f end if end do write ( * , * ) write ( * , \"(2x,'Transition',3x,'Excitation',9x,'Transition dipole, a.u.',19x,'Oscillator',& &/18x,'eV',14x,'x',10x,'y',10x,'z',9x,'Abs.',7x,'strength')\" ) do istat = 1 , nstates do jstat = istat + 1 , nstates energ = excitation_energy ( jstat ) - excitation_energy ( istat ) f = 2.0d0 / 3.0d0 * ( energ ) * sum ( dip (:, istat , jstat ) ** 2 ) if ( mrsf_output ) then state_label = mrsf_state_label ( infos % tddft % mult , istat ) state_label_j = mrsf_state_label ( infos % tddft % mult , jstat ) write ( * , \"(3x,a,1x,'->',1x,a,t11,3x,f11.6,3x,3f11.4,1x,f11.4,2x,f11.4)\" ) & trim ( state_label ), trim ( state_label_j ), toev * energ , dip ( 1 : 3 , istat , jstat ), & sqrt ( sum ( dip (:, istat , jstat ) ** 2 )), f else write ( * , \"(3x,i0,1x,'->',1x,i0,t11,3x,f11.6,3x,3f11.4,1x,f11.4,2x,f11.4)\" ) & istat , jstat , toev * energ , dip ( 1 : 3 , istat , jstat ), sqrt ( sum ( dip (:, istat , jstat ) ** 2 )), f end if enddo enddo write ( * , * ) end subroutine print_results subroutine sfrorhs ( rhs , xhxa , xhxb , hpta , hptb , Tij , Tab , Fa , Fb , & noca , nocb ) use precision , only : dp implicit none real ( kind = dp ), intent ( out ), dimension (:) :: rhs real ( kind = dp ), intent ( inout ), dimension (:,:) :: xhxa , xhxb real ( kind = dp ), intent ( in ), dimension (:,:) :: hpta real ( kind = dp ), intent ( in ), dimension (:,:) :: hptb real ( kind = dp ), intent ( in ), dimension (:,:) :: tij real ( kind = dp ), intent ( in ), dimension (:,:) :: tab real ( kind = dp ), intent ( in ), dimension (:,:) :: fa , fb integer , intent ( in ) :: noca , nocb real ( kind = dp ), allocatable , dimension (:,:) :: wrk integer :: nbf , i , j , ij , k , nconf nbf = ubound ( fa , 1 ) allocate ( wrk ( nbf , nbf ), & source = 0.0_dp ) ! HPTA --> AB1_MO(1) ! HPTB --> AB1_MO(2) ! TA   --> TIJ ! TB   --> TAB ! Alpha ! XHXA+= 2*FA(P+,I+)*TA(I+,J+) call dgemm ( 'n' , 'n' , nbf , noca , noca , & 2.0_dp , fa , nbf , & tij , noca , & 1.0_dp , xhxa , nbf ) ! Beta ! XHXB+= 2*FB(P-,A-)*TB(A-,B-) do j = nocb + 1 , nbf do i = nocb + 1 , nbf wrk ( i , j ) = tab ( i - nocb , j - nocb ) end do end do call dgemm ( 'n' , 'n' , nbf , nbf , nbf , & 2.0_dp , fb , nbf , & wrk , nbf , & 1.0_dp , xhxb , nbf ) ! doc-socc ij = 0 do i = nocb + 1 , noca do j = 1 , nocb ij = ij + 1 rhs ( ij ) = hptb ( j , i - nocb ) + xhxa ( i , j ) - xhxa ( j , i ) - xhxb ( j , i ) end do end do ! doc-virt do k = noca + 1 , nbf do j = 1 , nocb ij = ij + 1 rhs ( ij ) = hpta ( j , k - noca ) + hptb ( j , k - nocb ) + xhxa ( k , j ) - xhxb ( j , k ) end do end do ! soc-virt do k = noca + 1 , nbf do i = nocb + 1 , noca ij = ij + 1 rhs ( ij ) = hpta ( i , k - noca ) + xhxa ( k , i ) + xhxb ( k , i ) - xhxb ( i , k ) end do end do ! Multiplied by -1 i.e., RHS of Z-vector eq. ----- nconf = ij rhs ( 1 : nconf ) = - rhs ( 1 : nconf ) end subroutine sfrorhs subroutine sfromcal ( xm , xminv , energy , fa , fb , noca , nocb ) use precision , only : dp implicit none real ( kind = dp ), intent ( out ), dimension (:) :: xm real ( kind = dp ), intent ( out ), dimension (:) :: xminv real ( kind = dp ), intent ( in ), dimension (:) :: energy real ( kind = dp ), intent ( in ), dimension (:,:) :: fa real ( kind = dp ), intent ( in ), dimension (:,:) :: fb integer , intent ( in ) :: noca , nocb integer :: ij , i , j , k , nbf , nsoc , lzdim , nvira nbf = ubound ( fa , 1 ) nvira = nbf - noca nsoc = noca - nocb lzdim = nocb * ( nsoc + nvira ) + nsoc * nvira ! doc-socc ij = 0 do i = nocb + 1 , noca do j = 1 , nocb ij = ij + 1 xm ( ij ) = ( fb ( i , i ) - fb ( j , j )) * 0.5_dp end do end do ! DOC-VIRT do k = noca + 1 , nbf do j = 1 , nocb ij = ij + 1 xm ( ij ) = energy ( k ) - energy ( j ) end do end do ! SOCC-VIRT do k = noca + 1 , nbf do i = nocb + 1 , noca ij = ij + 1 xm ( ij ) = ( fa ( k , k ) - fa ( i , i )) * 0.5_dp end do end do do j = 1 , lzdim xminv ( j ) = 1.0_dp / xm ( j ) end do end subroutine sfromcal subroutine sfrogen ( ava , avb , pv , noca , nocb ) use precision , only : dp implicit none real ( kind = dp ), intent ( out ), dimension (:,:) :: ava real ( kind = dp ), intent ( out ), dimension (:,:) :: avb real ( kind = dp ), intent ( in ), dimension (:) :: pv integer , intent ( in ) :: noca , nocb integer :: ij , i , j , k , nbf nbf = ubound ( ava , 1 ) ava = 0.0_dp avb = 0.0_dp ! doc-socc ij = 0 do i = nocb + 1 , noca do j = 1 , nocb ij = ij + 1 avb ( j , i ) = pv ( ij ) end do end do ! doc-virt do k = noca + 1 , nbf do j = 1 , nocb ij = ij + 1 ava ( j , k ) = pv ( ij ) avb ( j , k ) = pv ( ij ) end do end do ! socc-virt do k = noca + 1 , nbf do i = nocb + 1 , noca ij = ij + 1 ava ( i , k ) = pv ( ij ) end do end do end subroutine sfrogen subroutine sfrolhs ( pmo , z , e , fa , fb , hpza , hpzb , & noca , nocb ) use precision , only : dp implicit none real ( kind = dp ), intent ( out ), dimension (:) :: pmo real ( kind = dp ), intent ( in ), dimension (:) :: z real ( kind = dp ), intent ( in ), dimension (:) :: e real ( kind = dp ), intent ( in ), dimension (:,:) :: fa , fb real ( kind = dp ), intent ( in ), dimension (:,:) :: hpza real ( kind = dp ), intent ( in ), dimension (:,:) :: hpzb integer , intent ( in ) :: noca , nocb real ( kind = dp ), allocatable , dimension (:,:) :: ztmp real ( kind = dp ), allocatable , dimension (:,:) :: wrk integer :: ij , i , k , j , nbf , lr1 , lr2 nbf = ubound ( fa , 1 ) lr1 = nocb + 1 lr2 = noca allocate ( ztmp ( nbf , nbf ), & wrk ( nbf , nbf ), & source = 0.0_dp ) ij = 0 do i = nocb + 1 , noca do j = 1 , nocb ij = ij + 1 ztmp ( j , i ) = z ( ij ) end do end do do k = noca + 1 , nbf do j = 1 , nocb ij = ij + 1 ztmp ( j , k ) = z ( ij ) end do end do do k = noca + 1 , nbf do i = nocb + 1 , noca ij = ij + 1 ztmp ( i , k ) = z ( ij ) end do end do ! doc-socc do j = 1 , nocb wrk ( j , 1 ) = wrk ( j , 1 ) + hpzb ( j , 1 ) & - fa ( lr1 , lr1 ) * ztmp ( j , lr1 ) & - fa ( lr2 , lr1 ) * ztmp ( j , lr2 ) wrk ( j , 2 ) = wrk ( j , 2 ) + hpzb ( j , 2 ) & - fa ( lr2 , lr2 ) * ztmp ( j , lr2 ) & - fa ( lr1 , lr2 ) * ztmp ( j , lr1 ) end do do j = 1 , nocb do k = 1 , nocb wrk ( j , 1 ) = wrk ( j , 1 ) + fa ( k , j ) * ztmp ( k , lr1 ) wrk ( j , 2 ) = wrk ( j , 2 ) + fa ( k , j ) * ztmp ( k , lr2 ) end do end do do j = 1 , nocb do k = 1 , nbf - noca wrk ( j , 1 ) = wrk ( j , 1 ) + fb ( noca + k , lr1 ) * ztmp ( j , noca + k ) & + fb ( noca + k , j ) * ztmp ( lr1 , noca + k ) wrk ( j , 2 ) = wrk ( j , 2 ) + fb ( noca + k , j ) * ztmp ( lr2 , noca + k ) & + fb ( noca + k , lr2 ) * ztmp ( j , noca + k ) end do end do ij = 0 wrk = wrk * 0.5_dp do i = 1 , 2 do j = 1 , nocb ij = ij + 1 pmo ( ij ) = ( e ( nocb + i ) - e ( j )) * z ( ij ) + wrk ( j , i ) end do end do ! doc-virt wrk = 0.0_dp do k = 1 , nbf - noca do j = 1 , nocb wrk ( j , k ) = wrk ( j , k ) + hpza ( j , k ) & + hpzb ( j , noca - nocb + k ) & + fb ( lr1 , noca + k ) * ztmp ( j , lr1 ) & + fb ( lr2 , noca + k ) * ztmp ( j , lr2 ) & - fa ( lr1 , j ) * ztmp ( lr1 , noca + k ) & - fa ( lr2 , j ) * ztmp ( lr2 , noca + k ) end do end do wrk = wrk * 0.5_dp do k = 1 , nbf - noca do j = 1 , nocb ij = ij + 1 pmo ( ij ) = ( e ( noca + k ) - e ( j )) * z ( ij ) + wrk ( j , k ) end do end do ! socc-virt wrk = 0.0_dp do k = 1 , nbf - noca wrk ( k , 1 ) = wrk ( k , 1 ) + hpza ( lr1 , k ) & + fb ( lr1 , lr1 ) * ztmp ( lr1 , noca + k ) & + fb ( lr2 , lr1 ) * ztmp ( lr2 , noca + k ) wrk ( k , 2 ) = wrk ( k , 2 ) + hpza ( lr2 , k ) & + fb ( lr1 , lr2 ) * ztmp ( lr1 , noca + k ) & + fb ( lr2 , lr2 ) * ztmp ( lr2 , noca + k ) end do do k = 1 , nbf - noca do j = 1 , nocb wrk ( k , 1 ) = wrk ( k , 1 ) - fa ( j , noca + k ) * ztmp ( j , lr1 ) & - fa ( j , lr1 ) * ztmp ( j , noca + k ) wrk ( k , 2 ) = wrk ( k , 2 ) - fa ( j , noca + k ) * ztmp ( j , lr2 ) & - fa ( j , lr2 ) * ztmp ( j , noca + k ) end do end do do k = 1 , nbf - noca do j = 1 , nbf - noca wrk ( k , 1 ) = wrk ( k , 1 ) - fb ( noca + j , noca + k ) * ztmp ( lr1 , noca + j ) wrk ( k , 2 ) = wrk ( k , 2 ) - fb ( noca + j , noca + k ) * ztmp ( lr2 , noca + j ) end do end do wrk = wrk * 0.5_dp do k = 1 , nbf - noca do i = 1 , noca - nocb ij = ij + 1 pmo ( ij ) = ( e ( noca + k ) - e ( nocb + i )) * z ( ij ) + wrk ( k , i ) end do end do deallocate ( ztmp , wrk ) end subroutine sfrolhs subroutine pcgrbpini ( r , pk , error , d , xm_in , a_pk ) use precision , only : dp implicit none real ( kind = dp ), intent ( out ), dimension (:) :: r real ( kind = dp ), intent ( out ), dimension (:) :: pk real ( kind = dp ), intent ( out ) :: error real ( kind = dp ), intent ( in ), dimension (:) :: d real ( kind = dp ), intent ( in ), dimension (:) :: xm_in real ( kind = dp ), intent ( in ), dimension (:) :: a_pk real ( kind = dp ) :: beta ! R ini and R norm(error) r = d - a_pk error = dot_product ( r , r ) ! Beta ini beta = 1.0_dp / dot_product ( r ** 2 , xm_in ) ! pk ini pk = beta * xm_in * r end subroutine pcgrbpini subroutine pcgb ( pk , r , xm_in ) use precision , only : dp implicit none real ( kind = dp ), intent ( out ) :: pk (:) real ( kind = dp ), intent ( in ) :: r (:) real ( kind = dp ), intent ( in ) :: xm_in (:) real ( kind = dp ) :: beta beta = 1.0_dp / sum ( r * r * xm_in ) ! pk ini pk = pk + beta * xm_in * r end subroutine pcgb subroutine sfropcal ( pa , pb , ta , tb , z , & noca , nocb ) use precision , only : dp implicit none real ( kind = dp ), intent ( out ), dimension (:,:) :: pa , pb real ( kind = dp ), intent ( in ), dimension (:,:) :: ta , tb real ( kind = dp ), intent ( in ), dimension (:) :: z integer , intent ( in ) :: noca , nocb integer :: i , j , k , ij , nbf nbf = ubound ( pa , 1 ) ! Alpha pa = 0.0_dp do j = 1 , noca do i = 1 , noca pa ( i , j ) = ta ( i , j ) end do end do pb = 0.0_dp do j = nocb + 1 , nbf do i = nocb + 1 , nbf pb ( i , j ) = tb ( i - nocb , j - nocb ) end do end do ! add Z contribution ! DOC-SOCC ij = 0 do i = nocb + 1 , noca do j = 1 , nocb ij = ij + 1 pb ( j , i ) = pb ( j , i ) + z ( ij ) * 0.5_dp end do end do ! DOC-VIRT do k = noca + 1 , nbf do j = 1 , nocb ij = ij + 1 pa ( j , k ) = pa ( j , k ) + z ( ij ) * 0.5_dp pb ( j , k ) = pb ( j , k ) + z ( ij ) * 0.5_dp end do end do ! SOCC-VIRT do k = noca + 1 , nbf do i = nocb + 1 , noca ij = ij + 1 pa ( i , k ) = pa ( i , k ) + z ( ij ) * 0.5_dp end do end do end subroutine sfropcal subroutine sfrowcal ( wmo , target_energy , mo_energy_a , fa , fb , bvec , xk , & xhxa , xhxb , hppija , hppijb , noca , nocb ) use precision , only : dp implicit none real ( kind = dp ), intent ( out ), dimension (:,:) :: wmo real ( kind = dp ), intent ( in ) :: target_energy real ( kind = dp ), intent ( in ), dimension (:) :: mo_energy_a real ( kind = dp ), intent ( in ), dimension (:,:) :: fa , fb real ( kind = dp ), intent ( in ), dimension (:) :: bvec real ( kind = dp ), intent ( in ), dimension (:) :: xk real ( kind = dp ), intent ( in ), dimension (:,:) :: xhxa , xhxb real ( kind = dp ), intent ( in ), dimension (:,:) :: hppija , hppijb integer , intent ( in ) :: noca , nocb real ( kind = dp ), allocatable , dimension (:,:) :: wrk , wrk1 , wrk2 integer :: i , a , k , x , y , j , b , ij , nbf , nvirb , lr1 , lr2 nbf = ubound ( fa , 1 ) lr1 = nocb + 1 lr2 = noca nvirb = nbf - nocb allocate ( wrk ( nbf , nbf ), & wrk1 ( nbf , nbf ), & wrk2 ( nbf , nbf ), & source = 0.0_dp ) !   ----- COPY xk ----- ij = 0 do i = nocb + 1 , noca do j = 1 , nocb ij = ij + 1 wrk1 ( j , i ) = xk ( ij ) end do end do do i = noca + 1 , nbf do j = 1 , nocb ij = ij + 1 wrk1 ( j , i ) = xk ( ij ) end do end do do k = noca + 1 , nbf do i = nocb + 1 , noca ij = ij + 1 wrk1 ( i , k ) = xk ( ij ) end do end do ! ! W_ix wrk = 0.0_dp do x = 1 , nocb do k = 1 , nocb wrk ( x , 1 ) = wrk ( x , 1 ) - wrk1 ( k , lr1 ) * fa ( k , x ) wrk ( x , 2 ) = wrk ( x , 2 ) - wrk1 ( k , lr2 ) * fa ( k , x ) end do end do do x = 1 , nocb do k = 1 , nbf - noca wrk ( x , 1 ) = wrk ( x , 1 ) + wrk1 ( lr1 , noca + k ) * fa ( noca + k , x ) wrk ( x , 2 ) = wrk ( x , 2 ) + wrk1 ( lr2 , noca + k ) * fa ( noca + k , x ) end do end do wmo ( 1 : nocb , lr1 : lr2 ) = wrk ( 1 : nocb , 1 : 2 ) * 0.5_dp & + xhxa ( 1 : nocb , lr1 : lr2 ) & + xhxb ( 1 : nocb , lr1 : lr2 ) & + hppija ( 1 : nocb , lr1 : lr2 ) wmo ( 1 : nocb , lr1 ) = wmo ( 1 : nocb , lr1 ) & + mo_energy_a ( 1 : nocb ) * wrk1 ( 1 : nocb , lr1 ) wmo ( 1 : nocb , lr2 ) = wmo ( 1 : nocb , lr2 ) & + mo_energy_a ( 1 : nocb ) * wrk1 ( 1 : nocb , lr2 ) !   ----- W_IA ----- wrk = 0.0_dp do i = 1 , nocb do a = 1 , nbf - noca wrk ( i , a ) = wrk ( i , a ) + fa ( lr1 , i ) * wrk1 ( lr1 , noca + a ) wrk ( i , a ) = wrk ( i , a ) + fa ( lr2 , i ) * wrk1 ( lr2 , noca + a ) end do end do wmo ( 1 : nocb , noca + 1 : nbf ) = wrk ( 1 : nocb , 1 : nbf - noca ) * 0.5_dp & + xhxb ( 1 : nocb , noca + 1 : nbf ) do a = noca + 1 , nbf wmo ( 1 : nocb , a ) = wmo ( 1 : nocb , a ) & + mo_energy_a ( 1 : nocb ) * wrk1 ( 1 : nocb , a ) end do !   ----- W_XA ----- wrk = 0.0_dp do a = 1 , nbf - noca do k = 1 , nocb wrk ( 1 , a ) = wrk ( 1 , a ) + fa ( k , lr1 ) * wrk1 ( k , noca + a ) wrk ( 2 , a ) = wrk ( 2 , a ) + fa ( k , lr2 ) * wrk1 ( k , noca + a ) end do end do do a = 1 , nbf - noca wrk ( 1 , a ) = wrk ( 1 , a ) - fb ( lr1 , lr1 ) * wrk1 ( lr1 , noca + a ) & - fb ( lr2 , lr1 ) * wrk1 ( lr2 , noca + a ) wrk ( 2 , a ) = wrk ( 2 , a ) - fb ( lr1 , lr2 ) * wrk1 ( lr1 , noca + a ) & - fb ( lr2 , lr2 ) * wrk1 ( lr2 , noca + a ) end do wmo ( lr1 : lr2 , noca + 1 : nbf ) = wrk ( 1 : 2 , 1 : nbf - noca ) * 0.5_dp & + xhxb ( lr1 : lr2 , noca + 1 : nbf ) do a = noca + 1 , nbf wmo ( lr1 : lr2 , a ) = wmo ( lr1 : lr2 , a ) & + mo_energy_a ( lr1 : lr2 ) * wrk1 ( lr1 : lr2 , a ) end do !   Alpha intermediate wrk = - fb do i = nocb + 1 , nbf wrk ( i , i ) = wrk ( i , i ) + target_energy end do wrk1 ( 1 : nbf - nocb , 1 : nbf - nocb ) = wrk ( nocb + 1 : nbf , nocb + 1 : nbf ) * 2.0_dp call dgemm ( 'n' , 'n' , noca , nvirb , nvirb , & 1.0_dp , bvec , noca , & wrk1 , nbf , & 0.0_dp , wrk2 , noca ) call dgemm ( 'n' , 't' , noca , noca , nvirb , & 1.0_dp , wrk2 , noca , & bvec , noca , & 0.0_dp , wrk1 , nbf ) !   beta intermediate wrk = fa do i = 1 , noca wrk ( i , i ) = wrk ( i , i ) + target_energy end do wrk ( 1 : noca , 1 : noca ) = wrk ( 1 : noca , 1 : noca ) * 2.0_dp call dgemm ( 'n' , 'n' , noca , nvirb , noca , & 1.0_dp , wrk , nbf , & bvec , noca , & 0.0_dp , wrk2 , noca ) call dgemm ( 't' , 'n' , nvirb , nvirb , noca , & 1.0_dp , bvec , noca , & wrk2 , noca , & 0.0_dp , wrk , nbf ) ! W_ij do i = 1 , nocb do j = 1 , i wmo ( i , j ) = hppija ( i , j ) + hppijb ( i , j ) + wrk1 ( i , j ) end do end do ! W_xy do x = nocb + 1 , noca do y = nocb + 1 , x wmo ( x , y ) = hppija ( x , y ) + wrk1 ( x , y ) + wrk ( x - nocb , y - nocb ) end do end do ! W_ab do a = noca + 1 , nbf do b = noca + 1 , a wmo ( a , b ) = wrk ( a - nocb , b - nocb ) end do end do ! Scale diagonal elements do i = 1 , nbf wmo ( i , i ) = wmo ( i , i ) * 0.5_dp end do wmo = - wmo deallocate ( wrk , wrk1 , wrk2 ) end subroutine sfrowcal function get_spin_square ( dmat_a , dmat_b , ta , tb , abxc , Smat , nocb , noca ) result ( s2 ) ! dmat_a / dmat_b -- alpha/beta density of the excited state ! ta / tb -- alpha/beta difference density matrix use precision , only : dp use mathlib , only : symmetrize_matrix , traceprod_sym_packed use mathlib , only : pack_matrix , unpack_matrix use messages , only : show_message , with_abort implicit none real ( kind = dp ), intent ( in ), dimension (:) :: & dmat_a , dmat_b , ta , tb real ( kind = dp ), intent ( in ), dimension (:,:) :: abxc real ( kind = dp ), intent ( in ), dimension (:) :: smat integer , intent ( in ) :: nocb , noca real ( kind = dp ) :: s2 , nsocc real ( kind = dp ), allocatable :: scr1 (:), dmat_t (:), & dmat_t_sq (:,:), smat_sq (:,:), tmp1 (:,:), tmp2 (:,:) integer :: nbf , nbf_tri , ok real ( kind = dp ) :: dum0 , dum1 , dum2 , dum3 , dum4 nbf = ubound ( abxc , 1 ) nbf_tri = ubound ( dmat_a , 1 ) allocate ( scr1 ( nbf_tri ), & dmat_t ( nbf_tri ), & dmat_t_sq ( nbf , nbf ), & smat_sq ( nbf , nbf ), & tmp1 ( nbf , nbf ), & tmp2 ( nbf , nbf ), & source = 0.0_dp , stat = ok ) if ( ok /= 0 ) call show_message ( 'Cannot allocate memory in qet_spin_square' , with_abort ) ! Calculate spin expectation values nsocc = noca - nocb dum0 = 0.25_dp * nsocc * ( nsocc - 2 ) dum1 = nocb + 1 ! Symmetric matrix scr1 = Smat*Dmat_a*Smat dmat_t = dmat_a + ta call unpack_matrix ( dmat_t , dmat_t_sq ) call unpack_matrix ( smat , smat_sq ) call dgemm ( 'n' , 'n' , nbf , nbf , nbf , & 1.0_dp , smat_sq , nbf , & dmat_t_sq , nbf , & 0.0_dp , tmp1 , nbf ) call dgemm ( 'n' , 'n' , nbf , nbf , nbf , & 1.0_dp , tmp1 , nbf , & smat_sq , nbf , & 0.0_dp , tmp2 , nbf ) call pack_matrix ( tmp2 , scr1 ) ! -tr[ Dmat_b*Smat*Dmat_a*Smat ] dmat_t = dmat_b + tb dum2 = - traceprod_sym_packed ( dmat_t , scr1 , nbf ) ! Symmetric matrix scr1 = Smat*Ta*Smat call unpack_matrix ( Ta , tmp1 ) call dgemm ( 'n' , 'n' , nbf , nbf , nbf , & 1.0_dp , smat_sq , nbf , & tmp1 , nbf , & 0.0_dp , tmp2 , nbf ) call dgemm ( 'n' , 'n' , nbf , nbf , nbf , & 1.0_dp , tmp2 , nbf , & smat_sq , nbf , & 0.0_dp , tmp1 , nbf ) call pack_matrix ( tmp1 , scr1 ) ! -tr[ Tb*Smat*Ta*Smat ]) dum3 =- traceprod_sym_packed ( tb , scr1 , nbf ) ! +tr[ abxc*Smat ] tmp1 = abxc call symmetrize_matrix ( tmp1 , nbf ) call pack_matrix ( tmp1 , scr1 ) dum4 = traceprod_sym_packed ( scr1 , smat , nbf ) / 2.0_dp s2 = dum0 + dum1 + dum2 - dum3 + dum4 ** 2 end function get_spin_square subroutine get_transition_density ( trden , bvec_mo , nbf , nocca , noccb , & nstates ) ! compute transition density between ground state and excited states use precision , only : dp use tdhf_lib , only : iatogen use messages , only : show_message , with_abort implicit none real ( kind = dp ), intent ( out ), dimension (:,:,:,:) :: trden real ( kind = dp ), intent ( in ), dimension (:,:) :: bvec_mo integer , intent ( in ) :: nbf , nocca , noccb , nstates real ( kind = dp ), allocatable :: tmp (:,:) integer :: jst , ok allocate ( tmp ( nbf , nbf ), & source = 0.0d0 , stat = ok ) if ( ok /= 0 ) call show_message ( 'Cannot allocate memory' , WITH_ABORT ) ! Compute transition dipole between the ground state and all excited do jst = 1 , nstates ! Compute transition density ! unpack X call iatogen ( bvec_mo (:, jst ), trden (:,:, 1 , jst ), nocca , noccb ) end do end subroutine get_transition_density subroutine get_transition_dipole ( basis , dip , mo_a , trden , nstates ) use precision , only : dp use int1 !   use types, only: information use basis_tools , only : basis_set use messages , only : show_message , with_abort use mathlib , only : orthogonal_transform , symmetrize_matrix , traceprod_sym_packed use mathlib , only : pack_matrix , unpack_matrix implicit none type ( basis_set ), intent ( in ) :: basis real ( kind = dp ), intent ( in ) :: trden (:,:,:,:), mo_a (:,:) real ( kind = dp ), intent ( out ) :: dip (:,:,:) integer , intent ( in ) :: nstates real ( kind = dp ) :: center_of_mass ( 3 ) real ( kind = dp ), allocatable :: mints (:,:), trden_ao (:,:) real ( kind = dp ), allocatable , target :: tmp (:,:) real ( kind = dp ), pointer :: tmp2 (:) integer :: nbf , nbf2 , ok integer :: ist , jst nbf = basis % nbf nbf2 = nbf * ( nbf + 1 ) / 2 allocate ( mints ( nbf2 , 3 ), & trden_ao ( nbf , nbf ), & tmp ( nbf , nbf ), & source = 0.0_dp , stat = ok ) if ( ok /= 0 ) call show_message ( 'Cannot allocate memory' , WITH_ABORT ) ! Compute dipole integrals at the center of mass center_of_mass = basis % atoms % center ( weight = 'mass' ) call multipole_integrals ( basis , mints , center_of_mass , 1 ) do ist = 1 , nstates do jst = 1 , nstates if ( ist == jst ) cycle ! Convert transition density from MO to AO basis call orthogonal_transform ( 't' , nbf , mo_a , trden (:,:, ist , jst ), trden_ao , tmp ) tmp2 ( 1 : nbf2 ) => tmp call symmetrize_matrix ( trden_ao , nbf ) call pack_matrix ( trden_ao , tmp2 ) ! Compute dipole moment: ! D_i = Tr(T * dipole_ints_i), i = x, y, z dip ( 1 , ist , jst ) = - traceprod_sym_packed ( tmp2 , mints (:, 1 ), nbf ) * 0.5_dp dip ( 2 , ist , jst ) = - traceprod_sym_packed ( tmp2 , mints (:, 2 ), nbf ) * 0.5_dp dip ( 3 , ist , jst ) = - traceprod_sym_packed ( tmp2 , mints (:, 3 ), nbf ) * 0.5_dp end do end do end subroutine end module tdhf_sf_lib","tags":"","url":"sourcefile/tdhf_sf_lib.f90.html"},{"title":"tagarray_driver.F90 – OpenQP Fortran API","text":"Source Code #include \"tagarray.fh\" module oqp_tagarray_driver use tagarray use , intrinsic :: iso_c_binding , only : c_int32_t , c_int64_t , c_char , c_ptr , c_null_ptr , c_bool implicit none private character ( len =* ), parameter , private :: module_name = \"oqp_tagarray_driver\" public :: tagarray_get_cptr character ( len =* ), parameter , public :: OQP_prefix = \"OQP::\" character ( len =* ), parameter , public :: OQP_DM_A = OQP_prefix // \"DM_A\" character ( len =* ), parameter , public :: OQP_DM_B = OQP_prefix // \"DM_B\" character ( len =* ), parameter , public :: OQP_FOCK_A = OQP_prefix // \"FOCK_A\" character ( len =* ), parameter , public :: OQP_FOCK_B = OQP_prefix // \"FOCK_B\" character ( len =* ), parameter , public :: OQP_E_MO_A = OQP_prefix // \"E_MO_A\" character ( len =* ), parameter , public :: OQP_E_MO_B = OQP_prefix // \"E_MO_B\" character ( len =* ), parameter , public :: OQP_VEC_MO_A = OQP_prefix // \"VEC_MO_A\" character ( len =* ), parameter , public :: OQP_VEC_MO_B = OQP_prefix // \"VEC_MO_B\" character ( len =* ), parameter , public :: OQP_Hcore = OQP_prefix // \"Hcore\" character ( len =* ), parameter , public :: OQP_SM = OQP_prefix // \"SM\" character ( len =* ), parameter , public :: OQP_QMAT = OQP_prefix // \"QMAT\" character ( len =* ), parameter , public :: OQP_TM = OQP_prefix // \"TM\" character ( len =* ), parameter , public :: OQP_ERI_AO = OQP_prefix // \"ERI_AO\" character ( len =* ), parameter , public :: OQP_ERI_AO_comment = & \"Two-electron repulsion integrals (mu nu|la si) in AO basis, chemist \" // & \"notation, full nbf**4 array stored C-contiguous with si fastest\" character ( len =* ), parameter , public :: OQP_WAO = OQP_prefix // \"WAO\" character ( len =* ), parameter , public :: OQP_td_abxc = OQP_prefix // \"td_abxc\" character ( len =* ), parameter , public :: OQP_td_bvec_mo = OQP_prefix // \"td_bvec_mo\" character ( len =* ), parameter , public :: OQP_td_mrsf_density = OQP_prefix // \"td_mrsf_density\" character ( len =* ), parameter , public :: OQP_td_p = OQP_prefix // \"td_p\" character ( len =* ), parameter , public :: OQP_td_t = OQP_prefix // \"td_t\" character ( len =* ), parameter , public :: OQP_td_xpy = OQP_prefix // \"td_xpy\" character ( len =* ), parameter , public :: OQP_td_xmy = OQP_prefix // \"td_xmy\" character ( len =* ), parameter , public :: OQP_td_energies = OQP_prefix // \"td_energies\" character ( len =* ), parameter , public :: OQP_td_singlet_energies = OQP_prefix // \"td_singlet_energies\" !new character ( len =* ), parameter , public :: OQP_td_triplet_energies = OQP_prefix // \"td_triplet_energies\" !new character ( len =* ), parameter , public :: OQP_td_bvec_mo_s = OQP_prefix // \"td_bvec_mo_s\" !new character ( len =* ), parameter , public :: OQP_td_bvec_mo_t = OQP_prefix // \"td_bvec_mo_t\" !new character ( len =* ), parameter , public :: OQP_nmr_shielding = OQP_prefix // \"nmr_shielding\" character ( len =* ), parameter , public :: OQP_nmr_shielding_comment = & \"Isotropic NMR shielding per atom (ppm); shape (5, natom): rows = \" // & \"dia, para_uncoupled, para_coupled, total_uncoupled, total_coupled\" character ( len =* ), parameter , public :: OQP_mulliken_charges = OQP_prefix // \"mulliken_charges\" character ( len =* ), parameter , public :: OQP_mulliken_charges_comment = & \"Mulliken atomic partial charges (e), one per atom\" character ( len =* ), parameter , public :: OQP_lowdin_charges = OQP_prefix // \"lowdin_charges\" character ( len =* ), parameter , public :: OQP_lowdin_charges_comment = & \"Lowdin atomic partial charges (e), one per atom\" ! NB: identifier differs from the subroutine oqp_resp_charges (Fortran is ! case-insensitive); the JSON key is still \"resp_charges\". character ( len =* ), parameter , public :: OQP_resp_chg = OQP_prefix // \"resp_charges\" character ( len =* ), parameter , public :: OQP_resp_chg_comment = & \"RESP/ESP-fitted atomic partial charges (e), one per atom\" character ( len =* ), parameter , public :: OQP_mrsf_ekt_density_mo = OQP_prefix // \"mrsf_ekt_density_mo\" character ( len =* ), parameter , public :: OQP_mrsf_ekt_lagrangian_mo = OQP_prefix // \"mrsf_ekt_lagrangian_mo\" character ( len =* ), parameter , public :: OQP_mrsf_ekt_fock_mo = OQP_prefix // \"mrsf_ekt_fock_mo\" character ( len =* ), parameter , public :: OQP_mrsf_ekt_orbitals_mo = OQP_prefix // \"mrsf_ekt_orbitals_mo\" character ( len =* ), parameter , public :: OQP_mrsf_ekt_eigenvalues = OQP_prefix // \"mrsf_ekt_eigenvalues\" character ( len =* ), parameter , public :: OQP_mrsf_ekt_strengths = OQP_prefix // \"mrsf_ekt_strengths\" character ( len =* ), parameter , public :: OQP_hf_hessian = OQP_prefix // \"hf_hessian\" character ( len =* ), parameter , public :: OQP_log_filename = OQP_prefix // \"log_filename\" character ( len =* ), parameter , public :: OQP_basis_filename = OQP_prefix // \"basis_filename\" character ( len =* ), parameter , public :: OQP_hbasis_filename = OQP_prefix // \"hbasis_filename\" ! Used to compute properties between two geometries character ( len =* ), parameter , public :: OQP_xyz_old = OQP_prefix // \"xyz_old\" character ( len =* ), parameter , public :: OQP_overlap_ao = OQP_prefix // \"overlap_ao_non_orthogonal\" character ( len =* ), parameter , public :: OQP_overlap_mo = OQP_prefix // \"overlap_mo_non_orthogonal\" character ( len =* ), parameter , public :: OQP_E_MO_A_old = OQP_prefix // \"E_MO_A_old\" character ( len =* ), parameter , public :: OQP_E_MO_B_old = OQP_prefix // \"E_MO_B_old\" character ( len =* ), parameter , public :: OQP_VEC_MO_A_old = OQP_prefix // \"VEC_MO_A_old\" character ( len =* ), parameter , public :: OQP_VEC_MO_B_old = OQP_prefix // \"VEC_MO_B_old\" character ( len =* ), parameter , public :: OQP_td_bvec_mo_old = OQP_prefix // \"td_bvec_mo_old\" character ( len =* ), parameter , public :: OQP_td_energies_old = OQP_prefix // \"td_energies_old\" character ( len =* ), parameter , public :: OQP_nac = OQP_prefix // \"nac\" character ( len =* ), parameter , public :: OQP_td_states_phase = OQP_prefix // \"td_states_phase\" character ( len =* ), parameter , public :: OQP_td_states_overlap = OQP_prefix // \"td_states_overlap\" character ( len =* ), parameter , public :: OQP_mm_potential = OQP_prefix // \"mm_potential\" character ( len =* ), parameter , public :: OQP_Hqmmm = OQP_prefix // \"hamiltonian_qmmm\" character ( len =* ), parameter , public :: OQP_partial_charges = OQP_prefix // \"partial_charges\" character ( len =* ), parameter , public :: OQP_mm_energy = OQP_prefix // \"mm_energy\" character ( len =* ), parameter , public :: OQP_mm_gradient = OQP_prefix // \"mm_gradient\" character ( len =* ), parameter , public :: OQP_ESPF_CORR = OQP_prefix // \"ESPF_CORR\" character ( len =* ), parameter , public :: OQP_POTQM = OQP_prefix // \"POTQM\" character ( len =* ), parameter , public :: OQP_POTMM = OQP_prefix // \"POTMM\" character ( len =* ), parameter , public :: OQP_ESPF_GRAD = OQP_prefix // \"ESPF_GRAD\" ! NAMD (Tully FSSH) state exchanged with the Python trajectory driver character ( len =* ), parameter , public :: OQP_namd_coef = OQP_prefix // \"namd_coef\" character ( len =* ), parameter , public :: OQP_namd_velocity = OQP_prefix // \"namd_velocity\" character ( len =* ), parameter , public :: OQP_namd_params = OQP_prefix // \"namd_params\" character ( len =* ), parameter , public :: OQP_namd_results = OQP_prefix // \"namd_results\" character ( len =* ), parameter , public :: OQP_namd_tdc = OQP_prefix // \"namd_tdc\" character ( len =* ), parameter , public :: OQP_namd_eabs = OQP_prefix // \"namd_eabs\" character ( len =* ), parameter , public :: OQP_namd_stas = OQP_prefix // \"namd_stas\" ! MRSF spin-orbit coupling (from upstream SOC merge) character ( len =* ), parameter , public :: OQP_soc_eval = OQP_prefix // \"soc_eval\" character ( len =* ), parameter , public :: OQP_soc_evec_re = OQP_prefix // \"soc_evec_re\" character ( len =* ), parameter , public :: OQP_soc_evec_im = OQP_prefix // \"soc_evec_im\" character ( len =* ), parameter , public :: OQP_soc_hsoc_re = OQP_prefix // \"soc_hsoc_re\" character ( len =* ), parameter , public :: OQP_soc_hsoc_im = OQP_prefix // \"soc_hsoc_im\" ! misc-excited-analysis: MRSF state-interaction transition/state densities and ! dipole intermediates exposed for downstream Python excited-state analysis ! (NTOs / attach-detach / cubes / descriptors). Written at the end of the MRSF ! energy driver; read read-only from Python via the tagarray bridge. character ( len =* ), parameter , public :: OQP_td_trans_density_mo = OQP_prefix // \"td_trans_density_mo\" character ( len =* ), parameter , public :: OQP_td_trans_dipole = OQP_prefix // \"td_trans_dipole\" character ( len =* ), parameter , public :: OQP_td_dip_ao = OQP_prefix // \"td_dip_ao\" character ( len =* ), parameter , public :: OQP_td_trans_density_mo_comment = & \"MRSF state-interaction 1-TDM (off-diag) / difference 1-RDM (diag) in the \" // & \"alpha-MO basis; shape (nbf,nbf,nstates*nstates), pair k=ist+(jst-1)*nstates\" character ( len =* ), parameter , public :: OQP_td_trans_dipole_comment = & \"MRSF transition dipoles (a.u.) at center of mass; shape (3,nstates,nstates)\" character ( len =* ), parameter , public :: OQP_td_dip_ao_comment = & \"AO electric-dipole integrals (a.u.) at center of mass; packed L-triangle (nbf*(nbf+1)/2,3)\" ! Symmetry petite-list metadata (written by pyoqp when use_integral_symmetry ! is enabled) character ( len =* ), parameter , public :: OQP_sym_petite = OQP_prefix // \"sym_petite_enable\" character ( len =* ), parameter , public :: OQP_sym_shell_map = OQP_prefix // \"sym_shell_map\" character ( len =* ), parameter , public :: OQP_sym_ao_target = OQP_prefix // \"sym_ao_target\" character ( len =* ), parameter , public :: OQP_sym_ao_sign = OQP_prefix // \"sym_ao_sign\" character ( len =* ), parameter , public :: OQP_sym_atom_weight = OQP_prefix // \"sym_atom_weight\" character ( len =* ), parameter , public :: OQP_sym_pair_irrep = OQP_prefix // \"sym_pair_irrep\" character ( len =* ), parameter , public :: OQP_sym_op_blocks = OQP_prefix // \"sym_op_blocks\" character ( len =* ), parameter , public :: OQP_DM_A_comment = \"Alpha-spin triangle Density matrix\" character ( len =* ), parameter , public :: OQP_DM_B_comment = \"Beta-spin triangle Density matrix\" character ( len =* ), parameter , public :: OQP_FOCK_A_comment = \"Alpha-spin triangle Fock matrix\" character ( len =* ), parameter , public :: OQP_FOCK_B_comment = \"Beta-spin triangle Fock matrix\" character ( len =* ), parameter , public :: OQP_E_MO_A_comment = \"Energies of alpha molecular orbitals\" character ( len =* ), parameter , public :: OQP_E_MO_B_comment = \"Energies of beta molecular orbitals\" character ( len =* ), parameter , public :: OQP_VEC_MO_A_comment = \"Coefficients of alpha molecular orbitals\" character ( len =* ), parameter , public :: OQP_VEC_MO_B_comment = \"Coefficients of beta molecular orbitals\" character ( len =* ), parameter , public :: OQP_Hcore_comment = \"triangle core Hamiltonian matrix\" character ( len =* ), parameter , public :: OQP_SM_comment = \"triangle Overlap matrix\" character ( len =* ), parameter , public :: OQP_QMAT_comment = \"canonical orthogonalizer Q = S&#94;(-1/2), full (nbf x nbf)\" character ( len =* ), parameter , public :: OQP_TM_comment = \"triangle Kinetic-Energy matrix\" character ( len =* ), parameter , public :: OQP_WAO_comment = \"??? WAO ???\" character ( len =* ), parameter , public :: OQP_td_abxc_comment = \"??? td_abxc ???\" character ( len =* ), parameter , public :: OQP_td_bvec_mo_comment = \"??? td_bvec_mo ???\" character ( len =* ), parameter , public :: OQP_td_mrsf_density_comment = \"??? td_mrsf_density ???\" character ( len =* ), parameter , public :: OQP_td_p_comment = \"??? td_p ???\" character ( len =* ), parameter , public :: OQP_td_t_comment = \"??? td_t ???\" character ( len =* ), parameter , public :: OQP_td_xpy_comment = OQP_prefix // \"(X+Y) vector for target state in TD-DFT calculations\" character ( len =* ), parameter , public :: OQP_td_xmy_comment = OQP_prefix // \"(X-Y) vector for target state in TD-DFT calculations\" character ( len =* ), parameter , public :: OQP_td_energies_comment = OQP_prefix // \"Responce energies\" character ( len =* ), parameter , public :: OQP_mm_potential_comment = \"MM potential\" character ( len =* ), parameter , public :: OQP_partial_charges_comment = \"QM partial charges\" character ( len =* ), parameter , public :: OQP_mm_energy_comment = \"MM energy\" character ( len =* ), parameter , public :: OQP_mm_gradient_comment = \"MM gradient\" character ( len =* ), parameter , public :: OQP_Hqmmm_comment = \"triangle QM/MM Hamiltonian matrix\" character ( len =* ), parameter , public :: OQP_espf_corr_comment = \"ESPF one-electron operators for each QM atom\" character ( len =* ), parameter , public :: OQP_log_filename_comment = OQP_prefix // \"log filename\" character ( len =* ), parameter , public :: OQP_potqm_comment = OQP_prefix // \"Quantum contribution to the potential\" character ( len =* ), parameter , public :: OQP_potmm_comment = OQP_prefix // \"MM contribution to the potential\" character ( len =* ), parameter , public :: OQP_ESPF_GRAD_comment = OQP_prefix // \"ESP contribution to the gradient\" character ( len =* ), parameter , public :: OQP_basis_filename_comment = OQP_prefix // \"basis filename\" character ( len =* ), parameter , public :: OQP_hbasis_filename_comment = OQP_prefix // \"Huckel basis_filename for Huckel Guess\" character ( len =* ), parameter , public :: OQP_nac_comment = OQP_prefix // \"nonadiabatic coupling nstates x nstates\" character ( len =* ), parameter , public :: OQP_overlap_mo_comment = OQP_prefix // \"overlap between MOs of geo1 and geo2\" character ( len =* ), parameter , public :: OQP_overlap_ao_comment = OQP_prefix // \"overlap between geo1 and geo2\" character ( len =* ), parameter , public :: OQP_td_states_phase_comment = OQP_prefix // \"Bvecs phase sign with respect to Bvec_old\" character ( len =* ), parameter , public :: OQP_td_states_overlap_comment = OQP_prefix // \"Bvecs phase sign with respect to Bvec_old\" character ( len =* ), parameter , public :: OQP_xyz_oldcomment = OQP_prefix // \"saved geo from previous step\" character ( len =* ), parameter , public :: OQP_namd_coef_comment = OQP_prefix // \"NAMD electronic amplitudes (2 x nstate: re,im)\" character ( len =* ), parameter , public :: OQP_namd_velocity_comment = OQP_prefix // \"NAMD nuclear velocities (3 x natom, a.u.)\" character ( len =* ), parameter , public :: OQP_namd_params_comment = OQP_prefix // \"NAMD packed scalar parameters/state\" character ( len =* ), parameter , public :: OQP_namd_results_comment = OQP_prefix // \"NAMD per-step diagnostics (hop prob + flags)\" character ( len =* ), parameter , public :: OQP_namd_tdc_comment = OQP_prefix // \"NAMD time-derivative coupling matrix (nstate x nstate)\" character ( len =* ), parameter , public :: OQP_namd_eabs_comment = OQP_prefix // \"NAMD absolute state energies (Hartree)\" character ( len =* ), parameter , public :: OQP_namd_stas_comment = OQP_prefix // \"NAMD state overlap matrix (flat n*n) for trivial-crossing\" character ( len =* ), parameter , public :: OQP_soc_eval_comment = OQP_prefix // \"SOC adiabatic eigenvalues (cm-1)\" character ( len =* ), parameter , public :: OQP_soc_evec_re_comment = OQP_prefix // \"SOC eigenvectors real part\" character ( len =* ), parameter , public :: OQP_soc_evec_im_comment = OQP_prefix // \"SOC eigenvectors imaginary part\" character ( len =* ), parameter , public :: OQP_soc_hsoc_re_comment = OQP_prefix // \"SOC Hamiltonian real part (cm-1)\" character ( len =* ), parameter , public :: OQP_soc_hsoc_im_comment = OQP_prefix // \"SOC Hamiltonian imaginary part (cm-1)\" character ( len =* ), parameter , public :: all_tags ( * ) = ( / character ( len = 80 ) :: & OQP_DM_A , OQP_DM_B , OQP_FOCK_A , OQP_FOCK_B , OQP_E_MO_A , OQP_E_MO_B , & OQP_VEC_MO_A , OQP_VEC_MO_B , OQP_Hcore , OQP_SM , OQP_TM , OQP_WAO , & OQP_td_abxc , OQP_td_bvec_mo , OQP_td_mrsf_density , OQP_td_p , OQP_td_t , & OQP_mrsf_ekt_density_mo , OQP_mrsf_ekt_lagrangian_mo , OQP_mrsf_ekt_fock_mo , & OQP_mrsf_ekt_orbitals_mo , OQP_mrsf_ekt_eigenvalues , OQP_mrsf_ekt_strengths , OQP_hf_hessian , & OQP_log_filename , OQP_basis_filename , OQP_hbasis_filename , & OQP_xyz_old , OQP_overlap_mo , OQP_overlap_ao , OQP_E_MO_A_old , OQP_E_MO_B_old , & OQP_VEC_MO_A_old , OQP_VEC_MO_B_old , OQP_td_bvec_mo_old , OQP_td_energies_old , & OQP_nac , OQP_td_states_phase , OQP_td_states_overlap , & OQP_Hqmmm , OQP_mm_potential , OQP_partial_charges , OQP_mm_energy , & OQP_ESPF_CORR , OQP_POTMM , OQP_POTQM , & OQP_namd_coef , OQP_namd_velocity , OQP_namd_params , OQP_namd_results , & OQP_namd_tdc , OQP_namd_eabs , OQP_namd_stas / ) interface tagarray_get_data module procedure tagarray_get_data_int64_val , tagarray_get_data_int64_1d , tagarray_get_data_int64_2d , tagarray_get_data_int64_3d module procedure tagarray_get_data_real64_val , tagarray_get_data_real64_1d , tagarray_get_data_real64_2d , tagarray_get_data_real64_3d module procedure tagarray_get_data_char8_val , tagarray_get_data_char8_1d end interface interface data_has_tags module procedure data_has_tags_location , data_has_tags_ms end interface public :: data_has_tags , check_status public :: tagarray_get_data public :: TA_TYPE_INT64 , TA_TYPE_REAL64 , TA_TYPE_CHAR8 public :: ta_ok contains function tagarray_get_cptr ( container , tag , ptr , type_id , ndims , dims , data_size ) result ( res ) type ( container_t ), intent ( inout ) :: container character ( len =* ), intent ( in ) :: tag type ( c_ptr ), intent ( out ) :: ptr integer ( c_int64_t ) :: res integer ( c_int32_t ), optional , intent ( out ) :: type_id integer ( c_int32_t ), optional , intent ( out ) :: ndims integer ( c_int64_t ), optional , intent ( out ) :: dims (:) integer ( c_int64_t ), optional , intent ( out ) :: data_size type ( recordinfo_t ) :: record_info ptr = c_null_ptr res = TA_CONTAINER_RECORD_NOT_FOUND if (. not . container % contains ( tag )) return record_info = container % get ( tag ) ptr = record_info % data res = record_info % count if ( present ( type_id )) type_id = record_info % type_id if ( present ( ndims )) ndims = int ( record_info % ndims , c_int32_t ) if ( present ( dims )) dims ( 1 : record_info % ndims ) = record_info % dims if ( present ( data_size )) data_size = record_info % count end function tagarray_get_cptr subroutine data_has_tags_location ( container , tags , location , abort , status ) use messages , only : show_message , WITHOUT_ABORT type ( container_t ), intent ( inout ) :: container character ( len =* ), intent ( in ) :: tags (:) character ( len =* ), intent ( in ) :: location logical , optional , intent ( in ) :: abort integer ( c_int32_t ), optional , intent ( out ) :: status integer ( c_int32_t ) :: tag_id , status_ logical :: abort_ abort_ = WITHOUT_ABORT if ( present ( abort )) abort_ = abort status_ = TA_OK if (. not . container % contains ( tags , tag_id )) then status_ = TA_CONTAINER_RECORD_NOT_FOUND call show_message ( & location // \": \" // get_status_message ( status_ , trim ( tags ( tag_id ))), & abort_ ) end if if ( present ( status )) status = status_ end subroutine data_has_tags_location subroutine data_has_tags_ms ( container , tags , modulename , subroutinename , abort , status ) use messages , only : show_message , WITHOUT_ABORT type ( container_t ), intent ( inout ) :: container character ( len =* ), intent ( in ) :: tags (:) character ( len =* ), intent ( in ) :: modulename , subroutinename logical , optional , intent ( in ) :: abort integer ( c_int32_t ), optional , intent ( out ) :: status integer ( c_int32_t ) :: tag_id , status_ logical :: abort_ abort_ = WITHOUT_ABORT if ( present ( abort )) abort_ = abort status_ = TA_OK if (. not . container % contains ( tags , tag_id )) then status_ = TA_CONTAINER_RECORD_NOT_FOUND call show_message ( & modulename // \"::\" // subroutinename // \": \" // get_status_message ( status_ , trim ( tags ( tag_id ))), & abort_ ) end if if ( present ( status )) status = status_ end subroutine data_has_tags_ms subroutine check_status ( status , modulename , subroutinename , tag , abort ) use messages , only : show_message , WITHOUT_ABORT integer ( c_int32_t ), intent ( in ) :: status character ( len =* ), intent ( in ) :: modulename , subroutinename , tag logical , optional , intent ( in ) :: abort logical :: abort_ abort_ = WITHOUT_ABORT if ( present ( abort )) abort_ = abort if ( status /= TA_OK ) call show_message ( & modulename // \"::\" // subroutinename // \": \" // get_status_message ( status , trim ( tag )), & abort_ ) end subroutine check_status subroutine tagarray_get_data_int64_val ( container , tag , ptr , status ) type ( container_t ), intent ( inout ) :: container character ( len =* ), intent ( in ) :: tag integer ( 8 ), pointer :: ptr integer ( c_int32_t ), optional , intent ( out ) :: status integer ( c_int32_t ) :: status_ TA_CONTAINER_GET_VALUE ( container , tag , TA_TYPE_INT64 , ptr , status_ ) if ( present ( status )) status = status_ end subroutine tagarray_get_data_int64_val subroutine tagarray_get_data_int64_1d ( container , tag , ptr , status ) type ( container_t ), intent ( inout ) :: container character ( len =* ), intent ( in ) :: tag integer ( 8 ), pointer :: ptr (:) integer ( c_int32_t ), optional , intent ( out ) :: status integer ( c_int32_t ) :: status_ TA_CONTAINER_GET_ARRAY ( container , tag , TA_TYPE_INT64 , ptr , status_ ) if ( present ( status )) status = status_ end subroutine tagarray_get_data_int64_1d subroutine tagarray_get_data_int64_2d ( container , tag , ptr , status ) type ( container_t ), intent ( inout ) :: container character ( len =* ), intent ( in ) :: tag integer ( 8 ), pointer :: ptr (:,:) integer ( c_int32_t ), optional , intent ( out ) :: status integer ( c_int32_t ) :: status_ TA_CONTAINER_GET_ARRAY ( container , tag , TA_TYPE_INT64 , ptr , status_ ) if ( present ( status )) status = status_ end subroutine tagarray_get_data_int64_2d subroutine tagarray_get_data_int64_3d ( container , tag , ptr , status ) type ( container_t ), intent ( inout ) :: container character ( len =* ), intent ( in ) :: tag integer ( 8 ), pointer :: ptr (:,:,:) integer ( c_int32_t ), optional , intent ( out ) :: status integer ( c_int32_t ) :: status_ TA_CONTAINER_GET_ARRAY ( container , tag , TA_TYPE_INT64 , ptr , status_ ) if ( present ( status )) status = status_ end subroutine tagarray_get_data_int64_3d subroutine tagarray_get_data_real64_val ( container , tag , ptr , status ) type ( container_t ), intent ( inout ) :: container character ( len =* ), intent ( in ) :: tag real ( 8 ), pointer :: ptr integer ( c_int32_t ), optional , intent ( out ) :: status integer ( c_int32_t ) :: status_ TA_CONTAINER_GET_VALUE ( container , tag , TA_TYPE_REAL64 , ptr , status_ ) if ( present ( status )) status = status_ end subroutine tagarray_get_data_real64_val subroutine tagarray_get_data_real64_1d ( container , tag , ptr , status ) type ( container_t ), intent ( inout ) :: container character ( len =* ), intent ( in ) :: tag real ( 8 ), pointer :: ptr (:) integer ( c_int32_t ), optional , intent ( out ) :: status integer ( c_int32_t ) :: status_ TA_CONTAINER_GET_ARRAY ( container , tag , TA_TYPE_REAL64 , ptr , status_ ) if ( present ( status )) status = status_ end subroutine tagarray_get_data_real64_1d subroutine tagarray_get_data_real64_2d ( container , tag , ptr , status ) type ( container_t ), intent ( inout ) :: container character ( len =* ), intent ( in ) :: tag real ( 8 ), pointer :: ptr (:,:) integer ( c_int32_t ), optional , intent ( out ) :: status integer ( c_int32_t ) :: status_ TA_CONTAINER_GET_ARRAY ( container , tag , TA_TYPE_REAL64 , ptr , status_ ) if ( present ( status )) status = status_ end subroutine tagarray_get_data_real64_2d subroutine tagarray_get_data_real64_3d ( container , tag , ptr , status ) type ( container_t ), intent ( inout ) :: container character ( len =* ), intent ( in ) :: tag real ( 8 ), pointer :: ptr (:,:,:) integer ( c_int32_t ), optional , intent ( out ) :: status integer ( c_int32_t ) :: status_ TA_CONTAINER_GET_ARRAY ( container , tag , TA_TYPE_REAL64 , ptr , status_ ) if ( present ( status )) status = status_ end subroutine tagarray_get_data_real64_3d subroutine tagarray_get_data_char8_val ( container , tag , ptr , status ) type ( container_t ), intent ( inout ) :: container character ( len =* ), intent ( in ) :: tag character ( len =* , kind = c_char ), pointer :: ptr integer ( c_int32_t ), optional , intent ( out ) :: status integer ( c_int32_t ) :: status_ TA_CONTAINER_GET_VALUE ( container , tag , TA_TYPE_CHAR8 , ptr , status_ ) if ( present ( status )) status = status_ end subroutine tagarray_get_data_char8_val subroutine tagarray_get_data_char8_1d ( container , tag , ptr , status ) type ( container_t ), intent ( inout ) :: container character ( len =* ), intent ( in ) :: tag character ( len =* , kind = c_char ), pointer :: ptr (:) integer ( c_int32_t ), optional , intent ( out ) :: status integer ( c_int32_t ) :: status_ TA_CONTAINER_GET_ARRAY ( container , tag , TA_TYPE_CHAR8 , ptr , status_ ) if ( present ( status )) status = status_ end subroutine tagarray_get_data_char8_1d end module oqp_tagarray_driver","tags":"","url":"sourcefile/tagarray_driver.f90.html"},{"title":"dft_gridint_grad.F90 – OpenQP Fortran API","text":"Source Code module mod_dft_gridint_grad use precision , only : fp use mod_dft_gridint , only : xc_engine_t , xc_consumer_t use mod_dft_gridint , only : OQP_FUNTYP_LDA , OQP_FUNTYP_MGGA use mod_dft_gridint , only : compAtGradRho , compAtGradDRho , compAtGradTau implicit none !------------------------------------------------------------------------------- type , extends ( xc_consumer_t ) :: xc_consumer_grad_t real ( kind = fp ), allocatable :: bfgrad (:,:,:) real ( kind = fp ), allocatable :: tmp_ (:,:) real ( kind = fp ), allocatable :: d1dsx (:,:,:) !< Temporary storage for dE/d\\sigma contains procedure :: parallel_start procedure :: parallel_stop procedure :: resetGradPointers procedure :: update procedure :: postUpdate procedure :: clean end type !------------------------------------------------------------------------------- private public derexc_blk !------------------------------------------------------------------------------- contains !------------------------------------------------------------------------------- subroutine parallel_start ( self , xce , nthreads ) implicit none class ( xc_consumer_grad_t ), target , intent ( inout ) :: self class ( xc_engine_t ), intent ( in ) :: xce integer , intent ( in ) :: nthreads call self % clean () allocate ( self % bfGrad ( xce % numAOs , 3 , nthreads ) & , self % d1dsx ( xce % maxPts , 3 , nthreads ) & , self % tmp_ ( xce % numAOs * 3 , nthreads ) & , source = 0.0d0 ) end subroutine !------------------------------------------------------------------------------- subroutine parallel_stop ( self ) implicit none class ( xc_consumer_grad_t ), intent ( inout ) :: self if ( ubound ( self % bfGrad , 3 ) /= 1 ) then self % bfGrad (:,:, lbound ( self % bfGrad , 3 )) = sum ( self % bfGrad , dim = 3 ) end if call self % pe % allreduce ( self % bfGrad (:,:, 1 ), & size ( self % bfGrad (:,:, 1 ))) end subroutine !------------------------------------------------------------------------------- subroutine clean ( self ) implicit none class ( xc_consumer_grad_t ), intent ( inout ) :: self if ( allocated ( self % bfGrad )) deallocate ( self % bfGrad ) if ( allocated ( self % d1dsx )) deallocate ( self % d1dsx ) if ( allocated ( self % tmp_ )) deallocate ( self % tmp_ ) end subroutine !------------------------------------------------------------------------------- !> @brief Adjust internal memory storage for a given !>  number of pruned grid points !> @author Konstantin Komarov subroutine resetGradPointers ( self , xce , tmp , myThread ) class ( xc_consumer_grad_t ), target , intent ( inout ) :: self class ( xc_engine_t ), intent ( in ) :: xce real ( kind = fp ), intent ( out ), pointer :: tmp (:,:) integer , intent ( in ) :: myThread !   pruned AOs or no pruned AOs associate ( numAOs => xce % numAOs_p & ! number of pruned AOs ) tmp ( 1 : numAOs , 1 : 3 ) => self % tmp_ ( 1 : numAOs * 3 , myThread ) end associate end subroutine !------------------------------------------------------------------------------- subroutine update ( self , xce , mythread ) class ( xc_consumer_grad_t ), intent ( inout ) :: self class ( xc_engine_t ), intent ( in ) :: xce integer :: mythread , i real ( kind = fp ), pointer :: tmpGrad (:,:) call self % resetGradPointers ( xce , tmpGrad , myThread ) associate ( bfgrad => self % bfgrad (:,:, mythread ) & , d1dsx => self % d1dsx (:,:, mythread ) & , aoG1 => xce % aoG1 & , aoG2 => xce % aoG2 & , moVA => xce % moVA & , moVB => xce % moVB & , moG1A => xce % moG1A & , moG1B => xce % moG1B & , hasBeta => xce % hasBeta & , numPts => xce % numPts & , xc => xce % XCLib & , drho => xce % xclib % drho & , ids => xce % XCLib % ids & , d1ds => xce % XCLib % d1ds & , d1dr => xce % XCLib % d1dr & , d1dt => xce % XCLib % d1dt & ) tmpGrad = 0.0d0 !     LDA gradient call compAtGradRho ( tmpGrad , d1dr ( 1 ,:), moVA , aoG1 , numPts ) !     GGA gradient if ( xce % funTyp /= OQP_FUNTYP_LDA ) then do i = 1 , numPts d1dsx ( i , 1 : 3 ) = 2 * d1ds ( ids % ga , i ) * drho ( 1 : 3 , i ) + d1ds ( ids % gc , i ) * drho ( 4 : 6 , i ) end do call compAtGradDRho ( tmpGrad , d1dsx , moVA , moG1A , aoG1 , aoG2 , numPts ) end if !     Meta-GGA gradient if ( xce % funTyp == OQP_FUNTYP_MGGA ) & call compAtGradTau ( tmpGrad , d1dt ( 1 ,:), moG1A , aoG2 , numPts ) if ( hasBeta ) then call compAtGradRho ( tmpGrad , d1dr ( 2 ,:), moVB , aoG1 , numPts ) if ( xce % funTyp /= OQP_FUNTYP_LDA ) then do i = 1 , numPts d1dsx ( i , 1 : 3 ) = 2 * d1ds ( ids % gb , i ) * drho ( 4 : 6 , i ) + d1ds ( ids % gc , i ) * drho ( 1 : 3 , i ) end do call compAtGradDRho ( tmpGrad , d1dsx , moVB , moG1B , aoG1 , aoG2 , numPts ) end if if ( xce % funTyp == OQP_FUNTYP_MGGA ) & call compAtGradTau ( tmpGrad , d1dt ( 2 ,:), moG1B , aoG2 , numPts ) end if end associate end subroutine subroutine postUpdate ( self , xce , mythread ) class ( xc_consumer_grad_t ), intent ( inout ) :: self class ( xc_engine_t ), intent ( in ) :: xce integer :: mythread real ( kind = fp ), pointer :: tmpGrad (:,:) call self % resetGradPointers ( xce , tmpGrad , myThread ) associate ( numAOs => xce % numAOs_p & ! number of pruned AOs , indices => xce % indices_p & ) if ( xce % skip_p ) then self % bfGrad (:,:, myThread ) = self % bfGrad (:,:, myThread ) + tmpGrad else self % bfGrad ( indices ( 1 : numAOs ), :, mythread ) = & self % bfGrad ( indices ( 1 : numAOs ), :, mythread ) + tmpGrad ( 1 : numAOs , :) end if end associate end subroutine !------------------------------------------------------------------------------- !> @brief Compute grid XC contribution to the nuclear gradient !> @note  Weight derivatives are not applied here. The gradient seems !>  to be good enough even using fairly poor grids. However, I do !>  not recomment to use it for numerical Hessian calculation until !>  weight derivatives are implemented !> @param[in]    da        density matrix, alpha-spin !> @param[in]    db        density matrix, beta-spin !> @param[inout] dedft     nuclear gradient !> @param[out]   totele    electronic denisty integral !> @param[out]   totkin    kinetic energy integral !> @param[in]    mxAngMom  max. needed ang. mom. value (incl. derivatives) !> @param[in]    nbf        basis set size !> @param[in]    isGGA     .TRUE. if GGA/mGGA functional used !> @param[in]    urohf     .TRUE. if open-shell calculation !> @author Vladimir Mironov subroutine derexc_blk ( basis , molGrid , da , db , dedft , & totele , totkin , & mxAngMom , nbf , dft_threshold , urohf , infos ) !$  use omp_lib, only: omp_get_num_threads, omp_get_thread_num use basis_tools , only : basis_set use mod_dft_gridint , only : xc_options_t , run_xc use types , only : information use mod_dft_molgrid , only : dft_grid_t implicit none type ( information ), target , intent ( in ) :: infos type ( dft_grid_t ), target , intent ( in ) :: molGrid type ( basis_set ) :: basis logical , intent ( IN ) :: urohf integer , intent ( IN ) :: mxAngMom , nbf real ( KIND = fp ), intent ( INOUT ) :: totele , totkin real ( KIND = fp ), intent ( INOUT ) :: da ( nbf , * ), db ( nbf , * ), dedft (:, :) real ( kind = fp ), intent ( in ) :: dft_threshold type ( xc_consumer_grad_t ) :: dat type ( xc_options_t ) :: xc_opts integer :: j integer :: nat real ( KIND = fp ), target , allocatable :: da2 (:, :), db2 (:, :) nat = infos % mol_prop % natom allocate ( da2 ( nbf , nbf )) do j = 1 , nbf da2 (:, j ) = da (:, j ) * basis % bfnrm ( j ) * basis % bfnrm ( 1 : nbf ) end do if ( urohf ) then allocate ( db2 ( nbf , nbf )) do j = 1 , nbf db2 (:, j ) = db (:, j ) * basis % bfnrm ( j ) * basis % bfnrm ( 1 : nbf ) end do end if xc_opts % isGGA = infos % functional % needGrd xc_opts % needTau = infos % functional % needTau xc_opts % functional => infos % functional xc_opts % hasBeta = urohf xc_opts % isWFVecs = . false . xc_opts % numAOs = nbf xc_opts % maxPts = molGrid % maxSlicePts xc_opts % limPts = molGrid % maxNRadTimesNAng xc_opts % numAtoms = infos % mol_prop % natom xc_opts % maxAngMom = mxAngMom xc_opts % nDer = 1 xc_opts % numOccAlpha = infos % mol_prop % nelec_A xc_opts % numOccBeta = infos % mol_prop % nelec_B xc_opts % wfAlpha => da2 xc_opts % wfBeta => db2 xc_opts % dft_threshold = dft_threshold xc_opts % molGrid => molGrid call dat % pe % init ( infos % mpiinfo % comm , infos % mpiinfo % usempi ) call run_xc ( xc_opts , dat , basis ) totele = dat % N_elec totkin = dat % E_kin do j = 1 , basis % nshell associate ( atom => basis % origin ( j ), & offset => basis % ao_offset ( j ), & naos => basis % naos ( j )) dedft ( 1 , atom ) = dedft ( 1 , atom ) - sum ( dat % bfGrad ( offset : offset + naos - 1 , 1 , 1 )) dedft ( 2 , atom ) = dedft ( 2 , atom ) - sum ( dat % bfGrad ( offset : offset + naos - 1 , 2 , 1 )) dedft ( 3 , atom ) = dedft ( 3 , atom ) - sum ( dat % bfGrad ( offset : offset + naos - 1 , 3 , 1 )) end associate end do deallocate ( da2 ) if ( urohf ) deallocate ( db2 ) call dat % clean () end subroutine !------------------------------------------------------------------------------- end module mod_dft_gridint_grad","tags":"","url":"sourcefile/dft_gridint_grad.f90.html"},{"title":"oqp_banner.F90 – OpenQP Fortran API","text":"Source Code !> @brief   The initialization of Open Quantum Platform (OpenQP = OQP in source code level) !> @details This module initialize entire OQP in Fortran side. !>          It does: !>          1) Setting up the log file !>          2) Printing out author information !>          3) Printing out the basic information regarding OS, date, HW Specs. !> !> @param infos(in,out)     Molecule information module oqp_banner_mod character ( len =* ), parameter :: module_name = \"oqp_banner_mod\" contains subroutine oqp_banner_C ( c_handle ) bind ( C , name = \"oqp_banner\" ) use c_interop , only : oqp_handle_t , oqp_handle_get_info use types , only : information type ( oqp_handle_t ) :: c_handle type ( information ), pointer :: inf inf => oqp_handle_get_info ( c_handle ) call oqp_banner ( inf ) end subroutine oqp_banner_C subroutine oqp_banner ( infos ) use messages , only : show_message , with_abort use types , only : information !$  use omp_lib, only: omp_get_max_threads use oqp_tagarray_driver use iso_c_binding , only : c_char use parallel , only : par_env_t implicit none type ( information ), intent ( inout ) :: infos integer :: iw , CPU_core , i character ( len = 28 ) :: cdate character ( len = :), allocatable :: hostnames type ( par_env_t ) :: pe ! Section of Tagarray for the log filename ! We are getting lot file name from Python via tagarray character ( len = 1 , kind = c_char ), contiguous , pointer :: log_filename (:) character ( len =* ), parameter :: subroutine_name = \"oqp_banner\" character ( len =* ), parameter :: tags_general ( 1 ) = ( / character ( len = 80 ) :: & OQP_log_filename / ) call data_has_tags ( infos % dat , tags_general , module_name , subroutine_name , with_abort ) call tagarray_get_data ( infos % dat , OQP_log_filename , log_filename ) allocate ( character ( ubound ( log_filename , 1 )) :: infos % log_filename ) do i = 1 , ubound ( log_filename , 1 ) infos % log_filename ( i : i ) = log_filename ( i ) end do call pe % init ( infos % mpiinfo % comm , infos % mpiinfo % usempi ) open ( newunit = iw , file = infos % log_filename , position = \"append\" ) write ( iw , '(/,10x, \"***********************************************************\")' ) write ( iw , '(10x,   \"*                                                         *\")' ) write ( iw , '(10x,   \"*             OpenQP: Open Quantum Platform               *\")' ) write ( iw , '(10x,   \"*                                                         *\")' ) write ( iw , '(10x,   \"*                Version: 1.0 Aug, 2024                   *\")' ) write ( iw , '(10x,   \"*                                                         *\")' ) write ( iw , '(10x,   \"***********************************************************\")' ) write ( iw , '(10x,   \"*     The most efficient implementation of MRSF-TDDFT.    *\")' ) write ( iw , '(10x,   \"***********************************************************\")' ) write ( iw , '(10x,   \"*                                                         *\")' ) write ( iw , '(10x,   \"*   OpenQP was initiated by Prof. Cheol Ho Choi in 2012.  *\")' ) write ( iw , '(10x,   \"*                                                         *\")' ) write ( iw , '(10x,   \"*   It has since been developed by:                       *\")' ) write ( iw , '(10x,   \"*   Dr. Vladimir Mironov                                  *\")' ) write ( iw , '(10x,   \"*   Dr. Konstantin Komarov                                *\")' ) write ( iw , '(10x,   \"*   Mr. Igor Gerasimov                                    *\")' ) write ( iw , '(10x,   \"*   Dr. Hiroya Nakata                                     *\")' ) write ( iw , '(10x,   \"*   Dr. Mohsen Mazaherifar                                *\")' ) write ( iw , '(10x,   \"*   Mr. Vladimir Makhnev                                  *\")' ) write ( iw , '(10x,   \"*   Mr. Alireza Lashkaripour                              *\")' ) write ( iw , '(10x,   \"*                                                         *\")' ) write ( iw , '(10x,   \"*   In 2024, Prof. Jingbai Li at Hoffmann Institute of    *\")' ) write ( iw , '(10x,   \"*   Advanced Materials began developing PyOQP.            *\")' ) write ( iw , '(10x,   \"*                                                         *\")' ) write ( iw , '(10x,   \"***********************************************************\")' ) call fdate ( cdate ) call pe % get_hostnames ( hostnames ) CPU_core = 1 !$  CPU_core = omp_get_max_threads() if ( pe % use_mpi ) then write ( iw , '(/20x,A,\"Job Details:\",/,22x,\"Start Time: \",A,/,22x,\"Host List: \",A,/,22x,\"Resources Allocated:\",/,24x,\"OpenMP Threads: \",I4,/,24x,\"MPI Processors: \",I4)' ) & ' ' , cdate , hostnames , CPU_core , pe % size else write ( iw , '(/20x,A,\"Job Details:\",/,22x,\"Start Time: \",A,/,22x,\"Host: \",A,/,22x,\"Resources Allocated:\",/,24x,\"OpenMP Threads: \",I4)' ) & ' ' , cdate , hostnames , CPU_core endif close ( iw ) end subroutine oqp_banner end module oqp_banner_mod","tags":"","url":"sourcefile/oqp_banner.f90.html"},{"title":"electric_moments.F90 – OpenQP Fortran API","text":"Source Code module electric_moments_mod implicit none character ( len =* ), parameter :: module_name = \"electric_moments_mod\" private public electric_moments public electric_moments_excited public electric_dipole_au_C contains subroutine electric_dipole_au_C ( c_handle , dipole ) bind ( C , name = \"electric_dipole_au\" ) use c_interop , only : oqp_handle_t , oqp_handle_get_info use iso_c_binding , only : c_double use types , only : information type ( oqp_handle_t ) :: c_handle real ( c_double ), intent ( out ) :: dipole ( 3 ) type ( information ), pointer :: inf inf => oqp_handle_get_info ( c_handle ) call electric_dipole_au ( inf , dipole ) end subroutine electric_dipole_au_C subroutine electric_dipole_au ( infos , dipole ) use oqp_tagarray_driver use basis_tools , only : basis_set use messages , only : show_message , with_abort use types , only : information use mathlib , only : traceprod_sym_packed use int1 , only : multipole_integrals type ( information ), target , intent ( inout ) :: infos real ( kind = 8 ), intent ( out ) :: dipole ( 3 ) integer :: nbf , nbf2 , ok , nat , i logical :: urohf type ( basis_set ), pointer :: basis real ( kind = 8 ), allocatable :: mints (:,:) real ( kind = 8 ) :: origin ( 3 ), dr ( 3 ), z real ( kind = 8 ), contiguous , pointer :: dmat_a (:), dmat_b (:) integer ( 4 ) :: status urohf = infos % control % scftype == 2 . or . infos % control % scftype == 3 basis => infos % basis basis % atoms => infos % atoms nbf = basis % nbf nbf2 = nbf * ( nbf + 1 ) / 2 nat = ubound ( basis % atoms % zn , 1 ) allocate ( mints ( nbf2 , 19 ), source = 0.0d0 , stat = ok ) if ( ok /= 0 ) call show_message ( 'Cannot allocate memory' , WITH_ABORT ) call tagarray_get_data ( infos % dat , OQP_DM_A , dmat_a , status ) call check_status ( status , module_name , \"electric_dipole_au\" , OQP_DM_A ) if ( urohf ) then call tagarray_get_data ( infos % dat , OQP_DM_B , dmat_b , status ) call check_status ( status , module_name , \"electric_dipole_au\" , OQP_DM_B ) endif origin = 0.0d0 call multipole_integrals ( basis , mints , origin , 3 ) dipole = 0.0d0 do i = 1 , nat dr = infos % atoms % xyz (:, i ) z = infos % atoms % zn ( i ) - infos % basis % ecp_zn_num ( i ) dipole = dipole + z * dr end do do i = 1 , 3 dipole ( i ) = dipole ( i ) - traceprod_sym_packed ( mints (:, i ), dmat_a , nbf ) end do if ( urohf ) then do i = 1 , 3 dipole ( i ) = dipole ( i ) - traceprod_sym_packed ( mints (:, i ), dmat_b , nbf ) end do end if deallocate ( mints ) end subroutine electric_dipole_au subroutine electric_moments_C ( c_handle ) bind ( C , name = \"electric_moments\" ) use c_interop , only : oqp_handle_t , oqp_handle_get_info use types , only : information type ( oqp_handle_t ) :: c_handle type ( information ), pointer :: inf inf => oqp_handle_get_info ( c_handle ) call electric_moments ( inf ) end subroutine electric_moments_c subroutine electric_moments_excited_C ( c_handle ) bind ( C , name = \"electric_moments_excited\" ) use c_interop , only : oqp_handle_t , oqp_handle_get_info use types , only : information type ( oqp_handle_t ) :: c_handle type ( information ), pointer :: inf inf => oqp_handle_get_info ( c_handle ) call electric_moments_excited ( inf ) end subroutine electric_moments_excited_C subroutine electric_moments ( infos ) use io_constants , only : iw use oqp_tagarray_driver use basis_tools , only : basis_set use messages , only : show_message , with_abort use types , only : information use strings , only : Cstring , fstring use mathlib , only : traceprod_sym_packed , triangular_to_full use int1 , only : multipole_integrals use physical_constants , only : AU_TO_DEBYE , AU_TO_BUCK , AU_TO_OCT use xyz_order implicit none character ( len =* ), parameter :: subroutine_name = \"electric_moments\" type ( information ), target , intent ( inout ) :: infos integer :: nbf , nbf2 , ok logical :: urohf type ( basis_set ), pointer :: basis real ( kind = 8 ), allocatable :: mints (:,:) real ( kind = 8 ) :: com ( 3 ), dip ( 3 ), qxyz ( 6 ), quad ( 3 , 3 ), dr ( 3 ), z real ( kind = 8 ) :: oxyz ( 10 ), oct ( 10 ) integer :: nat , i real ( kind = 8 ), contiguous , pointer :: dmat_a (:), dmat_b (:) integer ( 4 ) :: status urohf = infos % control % scftype == 2 . or . infos % control % scftype == 3 !   3. LOG: Write: Main output file open ( unit = IW , file = infos % log_filename , position = \"append\" ) !   Load basis set basis => infos % basis basis % atoms => infos % atoms !   Allocate memory nbf = basis % nbf nbf2 = nbf * ( nbf + 1 ) / 2 write ( iw , '(2/)' ) write ( iw , '(4x,a)' ) '========================' write ( iw , '(4x,a)' ) 'Electric moment analysis' write ( iw , '(4x,a)' ) '========================' call flush ( iw ) nat = ubound ( basis % atoms % zn , 1 ) allocate ( mints ( nbf2 , 19 ), source = 0.0d0 , stat = ok ) if ( ok /= 0 ) call show_message ( 'Cannot allocate memory' , WITH_ABORT ) call tagarray_get_data ( infos % dat , OQP_DM_A , dmat_a , status ) call check_status ( status , module_name , subroutine_name , OQP_DM_A ) if ( urohf ) then call tagarray_get_data ( infos % dat , OQP_DM_B , dmat_b , status ) call check_status ( status , module_name , subroutine_name , OQP_DM_B ) endif com = 0 do i = 1 , nat com = com + basis % atoms % xyz (:, i ) * basis % atoms % mass ( i ) end do com = com / sum ( basis % atoms % mass ) call multipole_integrals ( basis , mints , com , 3 ) dip = 0 qxyz = 0 oxyz = 0 do i = 1 , nat dr = infos % atoms % xyz (:, i ) - com z = infos % atoms % zn ( i ) - infos % basis % ecp_zn_num ( i ) dip = dip + z * dr qxyz ( XX_ ) = qxyz ( XX_ ) + z * dr ( X__ ) * dr ( X__ ) qxyz ( YY_ ) = qxyz ( YY_ ) + z * dr ( Y__ ) * dr ( Y__ ) qxyz ( ZZ_ ) = qxyz ( ZZ_ ) + z * dr ( Z__ ) * dr ( Z__ ) qxyz ( XY_ ) = qxyz ( XY_ ) + z * dr ( X__ ) * dr ( Y__ ) qxyz ( XZ_ ) = qxyz ( XZ_ ) + z * dr ( X__ ) * dr ( Z__ ) qxyz ( YZ_ ) = qxyz ( YZ_ ) + z * dr ( Y__ ) * dr ( Z__ ) oxyz ( XXX ) = oxyz ( XXX ) + z * dr ( X__ ) * dr ( X__ ) * dr ( X__ ) oxyz ( YYY ) = oxyz ( YYY ) + z * dr ( Y__ ) * dr ( Y__ ) * dr ( Y__ ) oxyz ( ZZZ ) = oxyz ( ZZZ ) + z * dr ( Z__ ) * dr ( Z__ ) * dr ( Z__ ) oxyz ( XXY ) = oxyz ( XXY ) + z * dr ( X__ ) * dr ( X__ ) * dr ( Y__ ) oxyz ( XXZ ) = oxyz ( XXZ ) + z * dr ( X__ ) * dr ( X__ ) * dr ( Z__ ) oxyz ( YYX ) = oxyz ( YYX ) + z * dr ( Y__ ) * dr ( Y__ ) * dr ( X__ ) oxyz ( YYZ ) = oxyz ( YYZ ) + z * dr ( Y__ ) * dr ( Y__ ) * dr ( Z__ ) oxyz ( ZZX ) = oxyz ( ZZX ) + z * dr ( Z__ ) * dr ( Z__ ) * dr ( X__ ) oxyz ( ZZY ) = oxyz ( ZZY ) + z * dr ( Z__ ) * dr ( Z__ ) * dr ( Y__ ) oxyz ( XYZ ) = oxyz ( XYZ ) + z * dr ( X__ ) * dr ( Y__ ) * dr ( Z__ ) end do do i = 1 , 3 dip ( i ) = dip ( i ) - traceprod_sym_packed ( mints (:, i ), dmat_a , nbf ) end do do i = 1 , 6 qxyz ( i ) = qxyz ( i ) - traceprod_sym_packed ( mints (:, 3 + i ), dmat_a , nbf ) end do do i = 1 , 10 oxyz ( i ) = oxyz ( i ) - traceprod_sym_packed ( mints (:, 9 + i ), dmat_a , nbf ) end do if ( urohf ) then do i = 1 , 3 dip ( i ) = dip ( i ) - traceprod_sym_packed ( mints (:, i ), dmat_b , nbf ) end do do i = 1 , 6 qxyz ( i ) = qxyz ( i ) - traceprod_sym_packed ( mints (:, 3 + i ), dmat_b , nbf ) end do do i = 1 , 10 oxyz ( i ) = oxyz ( i ) - traceprod_sym_packed ( mints (:, 9 + i ), dmat_b , nbf ) end do end if dip = dip * AU_TO_DEBYE ! Assemble quadrupole tensor: ! Q_ab = 1/2 * ( 3 * r_a * r_b - r&#94;2 * \\delta(a,b) ) quad ( X__ , X__ ) = 0.5 * ( 2 * qxyz ( XX_ ) - ( qxyz ( YY_ ) + qxyz ( ZZ_ ))) quad ( X__ , Y__ ) = 0.5 * ( 3 * qxyz ( XY_ ) ) quad ( X__ , Z__ ) = 0.5 * ( 3 * qxyz ( XZ_ ) ) quad ( Y__ , Y__ ) = 0.5 * ( 2 * qxyz ( YY_ ) - ( qxyz ( XX_ ) + qxyz ( ZZ_ ))) quad ( Y__ , Z__ ) = 0.5 * ( 3 * qxyz ( YZ_ ) ) quad ( Z__ , Z__ ) = 0.5 * ( 2 * qxyz ( ZZ_ ) - ( qxyz ( XX_ ) + qxyz ( YY_ ))) call triangular_to_full ( quad , 3 , 'u' ) quad = quad * AU_TO_BUCK ! Assemble octopole tensor: ! O_abc = 1/2*(5*r_a*r_b*r_c - r&#94;2*(r_a*\\delta(b,c)+r_b*\\delta(a,c)+r_c*\\delta(a,b)) oct ( XXX ) = 0.5 * ( 2 * oxyz ( XXX ) - 3 * ( oxyz ( YYX ) + oxyz ( ZZX ))) oct ( YYY ) = 0.5 * ( 2 * oxyz ( YYY ) - 3 * ( oxyz ( XXY ) + oxyz ( ZZY ))) oct ( ZZZ ) = 0.5 * ( 2 * oxyz ( ZZZ ) - 3 * ( oxyz ( YYZ ) + oxyz ( XXZ ))) oct ( XXY ) = 0.5 * ( 4 * oxyz ( XXY ) - ( oxyz ( YYY ) + oxyz ( ZZY ))) oct ( XXZ ) = 0.5 * ( 4 * oxyz ( XXZ ) - ( oxyz ( YYZ ) + oxyz ( ZZZ ))) oct ( YYX ) = 0.5 * ( 4 * oxyz ( YYX ) - ( oxyz ( XXX ) + oxyz ( ZZX ))) oct ( YYZ ) = 0.5 * ( 4 * oxyz ( YYZ ) - ( oxyz ( XXZ ) + oxyz ( ZZZ ))) oct ( ZZX ) = 0.5 * ( 4 * oxyz ( ZZX ) - ( oxyz ( XXX ) + oxyz ( YYX ))) oct ( ZZY ) = 0.5 * ( 4 * oxyz ( ZZY ) - ( oxyz ( XXY ) + oxyz ( YYY ))) oct ( XYZ ) = 0.5 * ( 5 * oxyz ( XYZ ) ) oct = oct * AU_TO_OCT write ( iw , '(/1x,a)' ) 'At point (Bohr):' write ( iw , '(4x,40x,3(a8,7x))' ) 'X' , 'Y' , 'Z' write ( iw , '(4x,40x,3f15.8,sp,f12.5)' ) com write ( iw , '(/4x,a)' ) 'electric charge (a.u.):' write ( iw , '(4x,34x,a6,sp,f12.5)' ) 'C_o' , real ( infos % mol_prop % charge ) write ( iw , '(/4x,a)' ) 'electric dipole (Debye):' write ( iw , '(4x,40x,3(a8,7x),a10)' ) 'X' , 'Y' , 'Z' , 'Norm' write ( iw , '(4x,34x,a6,4f15.8)' ) 'D_o' , dip , norm2 ( dip ) write ( iw , '(/4x,a)' ) 'electric quadrupole (Buckingham):' write ( iw , '(4x,40x,3(a8,7x))' ) 'X' , 'Y' , 'Z' write ( iw , '(4x,34x,a6,3F15.8)' ) 'Q_X' , quad (:, 1 ) write ( iw , '(4x,34x,a6,3f15.8)' ) 'Q_Y' , quad (:, 2 ) write ( iw , '(4x,34x,a6,3f15.8)' ) 'Q_Z' , quad (:, 3 ) write ( iw , '(/4x,a)' ) 'electric octupole (Buckingham*Angstrom):' write ( iw , '(4x,34x,a6,*(F15.8))' ) 'O_xxx' , oct ( XXX ) write ( iw , '(4x,34x,a6,*(F15.8))' ) 'O_xxy' , oct ( XXY ) write ( iw , '(4x,34x,a6,*(F15.8))' ) 'O_xxz' , oct ( XXZ ) write ( iw , '(4x,34x,a6,*(F15.8))' ) 'O_xyy' , oct ( YYX ) write ( iw , '(4x,34x,a6,*(F15.8))' ) 'O_xyz' , oct ( XYZ ) write ( iw , '(4x,34x,a6,*(F15.8))' ) 'O_xzz' , oct ( ZZX ) write ( iw , '(4x,34x,a6,*(F15.8))' ) 'O_yyy' , oct ( YYY ) write ( iw , '(4x,34x,a6,*(F15.8))' ) 'O_yyz' , oct ( YYZ ) write ( iw , '(4x,34x,a6,*(F15.8))' ) 'O_zzy' , oct ( ZZY ) write ( iw , '(4x,34x,a6,*(F15.8))' ) 'O_zzz' , oct ( ZZZ ) close ( iw ) end subroutine electric_moments subroutine electric_moments_excited ( infos ) use io_constants , only : iw use oqp_tagarray_driver use basis_tools , only : basis_set use messages , only : show_message , with_abort use types , only : information use strings , only : Cstring , fstring use mathlib , only : traceprod_sym_packed , triangular_to_full use int1 , only : multipole_integrals use physical_constants , only : AU_TO_DEBYE , AU_TO_BUCK , AU_TO_OCT use xyz_order implicit none character ( len =* ), parameter :: subroutine_name = \"electric_moments_excited\" type ( information ), target , intent ( inout ) :: infos integer :: nbf , nbf2 , ok logical :: urohf type ( basis_set ), pointer :: basis real ( kind = 8 ), allocatable :: mints (:,:) real ( kind = 8 ), allocatable :: dens_ex (:) real ( kind = 8 ) :: com ( 3 ), dip ( 3 ), qxyz ( 6 ), quad ( 3 , 3 ), dr ( 3 ), z real ( kind = 8 ) :: oxyz ( 10 ), oct ( 10 ) integer :: nat , i , istate real ( kind = 8 ), contiguous , pointer :: dmat_a (:), dmat_b (:) real ( kind = 8 ), contiguous , pointer :: td_p (:,:) integer ( 4 ) :: status urohf = infos % control % scftype == 2 . or . infos % control % scftype == 3 open ( unit = IW , file = infos % log_filename , position = \"append\" ) basis => infos % basis basis % atoms => infos % atoms nbf = basis % nbf nbf2 = nbf * ( nbf + 1 ) / 2 istate = infos % tddft % target_state write ( iw , '(2/)' ) write ( iw , '(4x,a)' ) '=================================================' write ( iw , '(4x,a,i4)' ) 'Electric moment analysis for excited state ' , istate write ( iw , '(4x,a)' ) '     (using relaxed one-particle density)       ' write ( iw , '(4x,a)' ) '=================================================' call flush ( iw ) nat = ubound ( basis % atoms % zn , 1 ) allocate ( mints ( nbf2 , 19 ), source = 0.0d0 , stat = ok ) if ( ok /= 0 ) call show_message ( 'Cannot allocate mints' , WITH_ABORT ) allocate ( dens_ex ( nbf2 ), source = 0.0d0 , stat = ok ) if ( ok /= 0 ) call show_message ( 'Cannot allocate dens_ex' , WITH_ABORT ) !   Ground-state density call tagarray_get_data ( infos % dat , OQP_DM_A , dmat_a , status ) call check_status ( status , module_name , subroutine_name , OQP_DM_A ) dens_ex = dmat_a if ( urohf ) then call tagarray_get_data ( infos % dat , OQP_DM_B , dmat_b , status ) call check_status ( status , module_name , subroutine_name , OQP_DM_B ) dens_ex = dens_ex + dmat_b end if call tagarray_get_data ( infos % dat , OQP_TD_P , td_p , status ) call check_status ( status , module_name , subroutine_name , OQP_TD_P ) dens_ex = dens_ex + td_p (:, 1 ) + td_p (:, 2 ) com = 0 do i = 1 , nat com = com + basis % atoms % xyz (:, i ) * basis % atoms % mass ( i ) end do com = com / sum ( basis % atoms % mass ) call multipole_integrals ( basis , mints , com , 3 ) dip = 0 qxyz = 0 oxyz = 0 do i = 1 , nat dr = infos % atoms % xyz (:, i ) - com z = infos % atoms % zn ( i ) - infos % basis % ecp_zn_num ( i ) dip = dip + z * dr qxyz ( XX_ ) = qxyz ( XX_ ) + z * dr ( X__ ) * dr ( X__ ) qxyz ( YY_ ) = qxyz ( YY_ ) + z * dr ( Y__ ) * dr ( Y__ ) qxyz ( ZZ_ ) = qxyz ( ZZ_ ) + z * dr ( Z__ ) * dr ( Z__ ) qxyz ( XY_ ) = qxyz ( XY_ ) + z * dr ( X__ ) * dr ( Y__ ) qxyz ( XZ_ ) = qxyz ( XZ_ ) + z * dr ( X__ ) * dr ( Z__ ) qxyz ( YZ_ ) = qxyz ( YZ_ ) + z * dr ( Y__ ) * dr ( Z__ ) oxyz ( XXX ) = oxyz ( XXX ) + z * dr ( X__ ) * dr ( X__ ) * dr ( X__ ) oxyz ( YYY ) = oxyz ( YYY ) + z * dr ( Y__ ) * dr ( Y__ ) * dr ( Y__ ) oxyz ( ZZZ ) = oxyz ( ZZZ ) + z * dr ( Z__ ) * dr ( Z__ ) * dr ( Z__ ) oxyz ( XXY ) = oxyz ( XXY ) + z * dr ( X__ ) * dr ( X__ ) * dr ( Y__ ) oxyz ( XXZ ) = oxyz ( XXZ ) + z * dr ( X__ ) * dr ( X__ ) * dr ( Z__ ) oxyz ( YYX ) = oxyz ( YYX ) + z * dr ( Y__ ) * dr ( Y__ ) * dr ( X__ ) oxyz ( YYZ ) = oxyz ( YYZ ) + z * dr ( Y__ ) * dr ( Y__ ) * dr ( Z__ ) oxyz ( ZZX ) = oxyz ( ZZX ) + z * dr ( Z__ ) * dr ( Z__ ) * dr ( X__ ) oxyz ( ZZY ) = oxyz ( ZZY ) + z * dr ( Z__ ) * dr ( Z__ ) * dr ( Y__ ) oxyz ( XYZ ) = oxyz ( XYZ ) + z * dr ( X__ ) * dr ( Y__ ) * dr ( Z__ ) end do do i = 1 , 3 dip ( i ) = dip ( i ) - traceprod_sym_packed ( mints (:, i ), dens_ex , nbf ) end do do i = 1 , 6 qxyz ( i ) = qxyz ( i ) - traceprod_sym_packed ( mints (:, 3 + i ), dens_ex , nbf ) end do do i = 1 , 10 oxyz ( i ) = oxyz ( i ) - traceprod_sym_packed ( mints (:, 9 + i ), dens_ex , nbf ) end do dip = dip * AU_TO_DEBYE quad ( X__ , X__ ) = 0.5 * ( 2 * qxyz ( XX_ ) - ( qxyz ( YY_ ) + qxyz ( ZZ_ ))) quad ( X__ , Y__ ) = 0.5 * ( 3 * qxyz ( XY_ ) ) quad ( X__ , Z__ ) = 0.5 * ( 3 * qxyz ( XZ_ ) ) quad ( Y__ , Y__ ) = 0.5 * ( 2 * qxyz ( YY_ ) - ( qxyz ( XX_ ) + qxyz ( ZZ_ ))) quad ( Y__ , Z__ ) = 0.5 * ( 3 * qxyz ( YZ_ ) ) quad ( Z__ , Z__ ) = 0.5 * ( 2 * qxyz ( ZZ_ ) - ( qxyz ( XX_ ) + qxyz ( YY_ ))) call triangular_to_full ( quad , 3 , 'u' ) quad = quad * AU_TO_BUCK oct ( XXX ) = 0.5 * ( 2 * oxyz ( XXX ) - 3 * ( oxyz ( YYX ) + oxyz ( ZZX ))) oct ( YYY ) = 0.5 * ( 2 * oxyz ( YYY ) - 3 * ( oxyz ( XXY ) + oxyz ( ZZY ))) oct ( ZZZ ) = 0.5 * ( 2 * oxyz ( ZZZ ) - 3 * ( oxyz ( YYZ ) + oxyz ( XXZ ))) oct ( XXY ) = 0.5 * ( 4 * oxyz ( XXY ) - ( oxyz ( YYY ) + oxyz ( ZZY ))) oct ( XXZ ) = 0.5 * ( 4 * oxyz ( XXZ ) - ( oxyz ( YYZ ) + oxyz ( ZZZ ))) oct ( YYX ) = 0.5 * ( 4 * oxyz ( YYX ) - ( oxyz ( XXX ) + oxyz ( ZZX ))) oct ( YYZ ) = 0.5 * ( 4 * oxyz ( YYZ ) - ( oxyz ( XXZ ) + oxyz ( ZZZ ))) oct ( ZZX ) = 0.5 * ( 4 * oxyz ( ZZX ) - ( oxyz ( XXX ) + oxyz ( YYX ))) oct ( ZZY ) = 0.5 * ( 4 * oxyz ( ZZY ) - ( oxyz ( XXY ) + oxyz ( YYY ))) oct ( XYZ ) = 0.5 * ( 5 * oxyz ( XYZ ) ) oct = oct * AU_TO_OCT write ( iw , '(/1x,a,i4)' ) 'Excited state index: ' , istate write ( iw , '( 1x,a)' ) 'Density used: relaxed (P_ground + dP_relaxed)' write ( iw , '(/1x,a)' ) 'At point (Bohr):' write ( iw , '(4x,40x,3(a8,7x))' ) 'X' , 'Y' , 'Z' write ( iw , '(4x,40x,3f15.8,sp,f12.5)' ) com write ( iw , '(/4x,a)' ) 'electric charge (a.u.):' write ( iw , '(4x,34x,a6,sp,f12.5)' ) 'C_o' , real ( infos % mol_prop % charge ) write ( iw , '(/4x,a)' ) 'electric dipole (Debye) - excited state:' write ( iw , '(4x,40x,3(a8,7x),a10)' ) 'X' , 'Y' , 'Z' , 'Norm' write ( iw , '(4x,34x,a6,4f15.8)' ) 'D_ex' , dip , norm2 ( dip ) write ( iw , '(/4x,a)' ) 'electric quadrupole (Buckingham) - excited state:' write ( iw , '(4x,40x,3(a8,7x))' ) 'X' , 'Y' , 'Z' write ( iw , '(4x,34x,a6,3F15.8)' ) 'Q_X' , quad (:, 1 ) write ( iw , '(4x,34x,a6,3f15.8)' ) 'Q_Y' , quad (:, 2 ) write ( iw , '(4x,34x,a6,3f15.8)' ) 'Q_Z' , quad (:, 3 ) write ( iw , '(/4x,a)' ) 'electric octupole (Buckingham*Angstrom) - excited state:' write ( iw , '(4x,34x,a6,*(F15.8))' ) 'O_xxx' , oct ( XXX ) write ( iw , '(4x,34x,a6,*(F15.8))' ) 'O_xxy' , oct ( XXY ) write ( iw , '(4x,34x,a6,*(F15.8))' ) 'O_xxz' , oct ( XXZ ) write ( iw , '(4x,34x,a6,*(F15.8))' ) 'O_xyy' , oct ( YYX ) write ( iw , '(4x,34x,a6,*(F15.8))' ) 'O_xyz' , oct ( XYZ ) write ( iw , '(4x,34x,a6,*(F15.8))' ) 'O_xzz' , oct ( ZZX ) write ( iw , '(4x,34x,a6,*(F15.8))' ) 'O_yyy' , oct ( YYY ) write ( iw , '(4x,34x,a6,*(F15.8))' ) 'O_yyz' , oct ( YYZ ) write ( iw , '(4x,34x,a6,*(F15.8))' ) 'O_zzy' , oct ( ZZY ) write ( iw , '(4x,34x,a6,*(F15.8))' ) 'O_zzz' , oct ( ZZZ ) close ( iw ) deallocate ( mints , dens_ex ) end subroutine electric_moments_excited end module electric_moments_mod","tags":"","url":"sourcefile/electric_moments.f90.html"},{"title":"dft_gridint_phi_cache.F90 – OpenQP Fortran API","text":"Source Code !> @brief Cross-iteration cache of the collocation matrix Phi (AO values and !>        derivatives on the quadrature grid) used by the DFT XC build. !> !> @details The collocation block Phi[mu,i] = phi_mu(r_i) (and its grid !>   derivatives), together with the grid weights and the per-slice !>   significant-AO pruning metadata, depends ONLY on geometry + basis + grid !>   + integration thresholds -- NOT on the electron density. It is therefore !>   identical on every SCF iteration, yet the native grid loop recomputes it !>   (compAOs / pruneAOs) on every Fock build. This module stores the !>   post-pruning Phi block per grid slice once per geometry and replays it on !>   subsequent iterations, mirroring the incremental reuse OpenQP already does !>   for the J/K (HF) part of the Fock matrix. !> !>   The cache is OPT-IN (env var OQP_XC_PHI_CACHE) and is only populated by the !>   repeated SCF energy/Fock build (mod_dft_gridint_energy::dmatd_blk); one-shot !>   consumers (gradients, response) never set the opt-in flag. Validity is keyed !>   by a geometry hash + derivative order + DFT threshold, so any change !>   transparently rebuilds the cache. The replayed Phi is bit-for-bit identical !>   to the recomputed Phi, so the converged energy/gradient are unchanged. !> !> @author Claude (Anthropic), 2026 module mod_dft_gridint_phi_cache use precision , only : fp , i8b implicit none private !> @brief Cached collocation data for a single grid slice type :: phi_slice_t logical :: stored = . false . !< this slice was populated during the build pass logical :: skip = . false . !< slice contributes nothing (empty or fully pruned) integer :: numPts = 0 !< number of significant grid points in the slice integer :: numAOs_p = 0 !< effective leading AO dimension (pruned or full) logical :: skip_p = . true . !< .true. if AO pruning was skipped (dense slice) integer , allocatable :: indices_p (:) !< significant AO indices (numAOs_p) real ( fp ), allocatable :: ao (:) !< compacted Phi block (numAOs_p*numPts*numAOVecs) real ( fp ), allocatable :: wts (:) !< grid weights (numPts) end type !> @brief Geometry-keyed cache of the collocation matrix across SCF iterations type , public :: phi_cache_t logical :: active = . false . !< this run participates in caching logical :: replay = . false . !< .true. => load cached Phi; .false. => build it logical :: ready = . false . !< cache is fully populated and valid integer :: nSlices = 0 integer :: numAOVecs = 0 integer :: numAOs = 0 ! validity signature integer ( i8b ) :: sig_geom = 0_i8b integer :: sig_vecs = 0 integer :: sig_natoms = 0 integer :: sig_nmolpts = 0 !< grid identity: total quadrature points real ( fp ) :: sig_thr = - 1.0_fp integer ( i8b ) :: nbytes = 0_i8b type ( phi_slice_t ), allocatable :: slices (:) contains procedure :: begin_run procedure :: finish_run procedure :: store procedure :: get_meta procedure :: get_bulk procedure :: free end type !> Module-global singleton: persists across run_xc calls / SCF iterations type ( phi_cache_t ), public , save :: g_phi_cache public :: phi_cache_geom_hash public :: phi_cache_env_enabled contains !> @brief Deterministic 64-bit hash of the molecular geometry (FNV-1a over the !>        raw IEEE bits of every coordinate). Any coordinate change invalidates. pure function phi_cache_geom_hash ( xyz ) result ( h ) real ( fp ), intent ( in ) :: xyz (:,:) integer ( i8b ) :: h integer ( i8b ) :: bits integer :: i , j h = - 3750763034362895579_i8b ! FNV-1a 64-bit offset basis (1469598103934665603 as signed) do j = 1 , size ( xyz , 2 ) do i = 1 , size ( xyz , 1 ) bits = transfer ( real ( xyz ( i , j ), fp ), 1_i8b ) h = ieor ( h , bits ) h = h * 1099511628211_i8b ! FNV-1a 64-bit prime (modular wraparound is fine) end do end do end function !> @brief Is the Phi cache enabled via the environment? (cached after first read) function phi_cache_env_enabled () result ( en ) logical :: en logical , save :: known = . false . logical , save :: value = . false . character ( len = 32 ) :: s integer :: st , ln if (. not . known ) then call get_environment_variable ( 'OQP_XC_PHI_CACHE' , s , length = ln , status = st ) if ( st == 0 . and . ln > 0 ) then s = adjustl ( s ) value = ( trim ( s ) == '1' . or . trim ( s ) == 'true' . or . trim ( s ) == 'TRUE' & . or . trim ( s ) == 'on' . or . trim ( s ) == 'ON' . or . trim ( s ) == 'yes' & . or . trim ( s ) == 'YES' . or . trim ( s ) == 'T' . or . trim ( s ) == 't' ) end if known = . true . end if en = value end function !> @brief Decide build/replay mode for the current run and (re)allocate as needed. !> @param[in] enable      master on/off (env AND opt-in caller) !> @param[in] nSlices     number of grid slices !> @param[in] nMolPts     total quadrature points (grid-identity discriminator) !> @param[in] numAOs      number of basis functions !> @param[in] numAOVecs   AO vectors per point (1=val, 4=+grad, 10=+2nd der) !> @param[in] natoms      number of atoms !> @param[in] geom_hash   geometry hash (see phi_cache_geom_hash) !> @param[in] thr         DFT integration threshold (affects nonzero-point set) !> !> @note nMolPts is an explicit grid-identity key so a mid-run grid swap (e.g. !>   the coarse->fine XC ramp, OQP_XC_C2F) can never be mistaken for a cache hit: !>   with a user-fixed dft_threshold the thr/AO/atom/geom signatures are identical !>   across the coarse and fine grids, leaving nSlices as the only other guard; !>   the two grids' point counts differ even if their slice counts collide. subroutine begin_run ( self , enable , nSlices , nMolPts , numAOs , numAOVecs , natoms , geom_hash , thr ) class ( phi_cache_t ), intent ( inout ) :: self logical , intent ( in ) :: enable integer , intent ( in ) :: nSlices , nMolPts , numAOs , numAOVecs , natoms integer ( i8b ), intent ( in ) :: geom_hash real ( fp ), intent ( in ) :: thr logical :: match self % active = enable self % replay = . false . if (. not . enable ) return match = self % ready & . and . self % nSlices == nSlices & . and . self % sig_nmolpts == nMolPts & . and . self % numAOs == numAOs & . and . self % numAOVecs == numAOVecs & . and . self % sig_natoms == natoms & . and . self % sig_geom == geom_hash & . and . self % sig_thr == thr if ( match ) then self % replay = . true . return end if ! (Re)build: drop any stale cache and prepare fresh per-slice storage. call self % free () self % nSlices = nSlices self % sig_nmolpts = nMolPts self % numAOs = numAOs self % numAOVecs = numAOVecs self % sig_natoms = natoms self % sig_geom = geom_hash self % sig_thr = thr allocate ( self % slices ( nSlices )) self % ready = . false . self % replay = . false . end subroutine !> @brief Finalize a build pass: mark the cache ready and tally its footprint. subroutine finish_run ( self ) class ( phi_cache_t ), intent ( inout ) :: self integer :: i if (. not . self % active ) return if ( self % replay ) return self % nbytes = 0_i8b do i = 1 , self % nSlices if ( allocated ( self % slices ( i )% ao )) self % nbytes = self % nbytes + 8_i8b * size ( self % slices ( i )% ao , kind = i8b ) if ( allocated ( self % slices ( i )% wts )) self % nbytes = self % nbytes + 8_i8b * size ( self % slices ( i )% wts , kind = i8b ) end do self % ready = . true . end subroutine !> @brief Store one slice's post-pruning collocation block (build pass). !> @param[in] iSlice     slice index !> @param[in] skip       whether the slice contributes nothing !> @param[in] numPts     significant points in the slice !> @param[in] numAOs_p   effective leading AO dimension !> @param[in] skip_p     whether pruning was skipped !> @param[in] indices_p  significant AO indices (length >= numAOs_p) !> @param[in] ao         flat AO memory (xce%aoMem_); first numAOs_p*numPts*numAOVecs used !> @param[in] wts        grid weights (length >= numPts) subroutine store ( self , iSlice , skip , numPts , numAOs_p , skip_p , indices_p , ao , wts ) class ( phi_cache_t ), intent ( inout ) :: self integer , intent ( in ) :: iSlice , numPts , numAOs_p logical , intent ( in ) :: skip , skip_p integer , intent ( in ) :: indices_p (:) real ( fp ), intent ( in ) :: ao (:) real ( fp ), intent ( in ) :: wts (:) integer :: n associate ( s => self % slices ( iSlice )) s % stored = . true . s % skip = skip if ( skip ) return s % numPts = numPts s % numAOs_p = numAOs_p s % skip_p = skip_p n = numAOs_p * numPts * self % numAOVecs ! Significant-AO indices are only consumed by the pruned (sparse) scatter ! path; the dense path adds the full block, so skip storing them there. if (. not . skip_p ) s % indices_p = indices_p ( 1 : numAOs_p ) s % ao = ao ( 1 : n ) s % wts = wts ( 1 : numPts ) end associate end subroutine !> @brief Read a slice's scalar metadata (replay pass, phase 1). subroutine get_meta ( self , iSlice , skip , numPts , numAOs_p , skip_p ) class ( phi_cache_t ), intent ( in ) :: self integer , intent ( in ) :: iSlice logical , intent ( out ) :: skip , skip_p integer , intent ( out ) :: numPts , numAOs_p associate ( s => self % slices ( iSlice )) if (. not . s % stored ) then ! defensive: treat unpopulated slice as empty skip = . true .; numPts = 0 ; numAOs_p = 0 ; skip_p = . true . return end if skip = s % skip numPts = s % numPts numAOs_p = s % numAOs_p skip_p = s % skip_p end associate end subroutine !> @brief Copy a slice's bulk data back into the engine arrays (replay, phase 2). !> @param[out] indices_p  receives significant AO indices (first numAOs_p) !> @param[out] ao         receives the Phi block into xce%aoMem_ (first n) !> @param[out] wts        receives grid weights into xce%xyzw(:,4) (first numPts) subroutine get_bulk ( self , iSlice , indices_p , ao , wts ) class ( phi_cache_t ), intent ( in ) :: self integer , intent ( in ) :: iSlice integer , intent ( out ) :: indices_p (:) real ( fp ), intent ( out ) :: ao (:) real ( fp ), intent ( out ) :: wts (:) integer :: n , np associate ( s => self % slices ( iSlice )) np = s % numAOs_p n = np * s % numPts * self % numAOVecs if (. not . s % skip_p ) indices_p ( 1 : np ) = s % indices_p ( 1 : np ) ao ( 1 : n ) = s % ao ( 1 : n ) wts ( 1 : s % numPts ) = s % wts ( 1 : s % numPts ) end associate end subroutine !> @brief Release all cached storage and reset to the empty/invalid state. subroutine free ( self ) class ( phi_cache_t ), intent ( inout ) :: self if ( allocated ( self % slices )) deallocate ( self % slices ) self % ready = . false . self % replay = . false . self % nSlices = 0 self % nbytes = 0_i8b end subroutine end module mod_dft_gridint_phi_cache","tags":"","url":"sourcefile/dft_gridint_phi_cache.f90.html"},{"title":"radial_grid_types.F90 – OpenQP Fortran API","text":"Source Code module dft_radial_grid_types use precision , only : dp implicit none private public :: get_radial_grid public :: dft_radial_grid_mhl public :: dft_radial_grid_mk3 public :: dft_radial_grid_ta public :: dft_radial_grid_becke public :: dft_radial_grid_map_uniform public :: dft_radial_grid_map_cheb2 !> No grid integer , parameter :: dft_radial_grid_none = - 1 !> Murray-Handy-Laming grid integer , parameter :: dft_radial_grid_mhl = 0 !> Mura-Knowles Log3 grid integer , parameter :: dft_radial_grid_mk3 = 1 !> Treutler-Ahlrichs grid integer , parameter :: dft_radial_grid_ta = 2 !> Becke grid integer , parameter :: dft_radial_grid_becke = 3 !> Use default mapping integer , parameter :: dft_radial_grid_map_default = 0 !> Map the uniform grid integer , parameter :: dft_radial_grid_map_uniform = 1 !> Map the Chebyshev 2nd kind grid integer , parameter :: dft_radial_grid_map_cheb2 = 2 !> @brief Base class for radial grids calculation type , abstract :: rad_grid_transform_t real ( kind = dp ) :: interval ( 2 ) integer :: map_grid = 0 contains procedure , nopass :: empty => rad_grid_transform_t_empty procedure ( set_radial_grid ), deferred :: set procedure , nopass :: query => base_query procedure ( int_1d_transformation ), deferred :: transform end type abstract interface subroutine set_radial_grid ( this , map_grid , opt ) import class ( rad_grid_transform_t ) :: this integer , optional :: map_grid real ( kind = dp ), optional :: opt end subroutine function int_1d_transformation ( this , r ) result ( rdr ) import class ( rad_grid_transform_t ) :: this real ( kind = dp ), intent ( inout ) :: r !< root real ( kind = dp ) :: rdr ( 2 ) !< transformed root and the derivative end function end interface type , extends ( rad_grid_transform_t ) :: mhl_grid real ( kind = dp ) :: mr contains procedure , pass :: set => mhl_set procedure , nopass :: query => mhl_query procedure , pass :: transform => mhl_transform end type type , extends ( rad_grid_transform_t ) :: mk3_grid real ( kind = dp ) :: alpha0 contains procedure :: set => mk3_set procedure , nopass :: query => mk3_query procedure :: transform => mk3_transform end type type , extends ( rad_grid_transform_t ) :: ta_grid real ( kind = dp ) :: pwr contains procedure :: set => ta_set procedure , nopass :: query => ta_query procedure :: transform => ta_transform end type type , extends ( rad_grid_transform_t ) :: becke_grid contains procedure :: set => becke_set procedure , nopass :: query => becke_query procedure :: transform => becke_transform end type contains !> @brief Set the radial points and weights !> @param ptrad [inout]  quadrature points !> @param wtrad [inout]  quadrature weights !> @param rad_grid_type [in]  type of radial grid !> @param rad_grid_type [in]  which quadrature to map on the selected grid subroutine get_radial_grid ( ptrad , wtrad , nrad , rad_grid_type , map_grid ) real ( kind = dp ), intent ( inout ) :: ptrad ( nrad ), wtrad ( nrad ) integer , intent ( in ) :: nrad , rad_grid_type integer , intent ( in ), optional :: map_grid real ( kind = dp ) :: rdr ( 2 ) integer :: i class ( rad_grid_transform_t ), allocatable :: rad_grid_transform select case ( rad_grid_type ) case ( dft_radial_grid_mhl ) allocate ( mhl_grid :: rad_grid_transform ) case ( dft_radial_grid_mk3 ) allocate ( mk3_grid :: rad_grid_transform ) case ( dft_radial_grid_ta ) allocate ( ta_grid :: rad_grid_transform ) case ( dft_radial_grid_becke ) allocate ( becke_grid :: rad_grid_transform ) !   Unknown grid type case default write ( * , * ) 'unknown radial grid type =' , rad_grid_type call abort end select call rad_grid_transform % set ( map_grid ) select case ( rad_grid_transform % map_grid ) case ( dft_radial_grid_map_uniform ) call getuniform ( nrad , ptrad , wtrad , rad_grid_transform % interval ) case ( dft_radial_grid_map_cheb2 ) call getcheb2 ( nrad , ptrad , wtrad , rad_grid_transform % interval ) !   Unknown map_grid type case default write ( * , * ) 'unknown map grid type =' , rad_grid_transform % map_grid call abort end select !   Apply variable transformation and scale weights of the original !   quadrature do i = 1 , nrad rdr = rad_grid_transform % transform ( ptrad ( i )) ptrad ( i ) = rdr ( 1 ) wtrad ( i ) = rdr ( 2 ) * wtrad ( i ) end do !   Include spherical r**2 factor wtrad = wtrad * ptrad ** 2 end subroutine !---------------------------------------------------------------------- !> @brief  Murray-Handy-Laming grid variable transformation. !> @detail  This grid is based on the following variable transformation: !>   ri = R0 * (r / (1-r) )**m_r !>   to map interval (0, +1) to (0, +inf). !>   R0 is a scaling coefficient a.k.a. Bragg-Slater radius function mhl_transform ( this , r ) result ( rdr ) class ( mhl_grid ) :: this real ( kind = dp ), intent ( inout ) :: r !< root real ( kind = dp ) :: rdr ( 2 ) rdr ( 1 ) = ( r / ( 1.0d0 - r )) ** this % mr ! r rdr ( 2 ) = this % mr * r ** ( this % mr - 1 ) / ( 1.0d0 - r ) ** ( this % mr + 1 ) ! dr end function !> @brief  Murray-Handy-Laming grid init subroutine mhl_set ( this , map_grid , opt ) class ( mhl_grid ) :: this integer , optional :: map_grid real ( kind = dp ), optional :: opt !   Murray-Handy-Laming grid parameter `m_r`: integer , parameter :: m_r = 2 this % mr = m_r if ( present ( opt )) this % mr = opt !   Default uniform grid this % map_grid = dft_radial_grid_map_uniform if ( present ( map_grid )) then if ( map_grid /= dft_radial_grid_map_default ) this % map_grid = map_grid end if this % interval = [ 0.0d0 , 1.0d0 ] end subroutine subroutine mhl_query ( grid_type , map_default ) integer , optional :: grid_type integer , optional :: map_default grid_type = dft_radial_grid_mhl map_default = dft_radial_grid_map_uniform end subroutine !---------------------------------------------------------------------- !> @brief  Mura-Knowles Log-3 grid !> @detail  This grid is based on the following variable transformation: !>   r_i = -alpha*log(1-(x_i)**3), !>   Alpha is a scaling factor !>   In the original paper authors suggest alpha=7.0 for 1st and 2nd groups !>   of periodic table and alpha=5.0 otherwise. Here different value !>   is used: !>   alpha=alpha0*Rbs, !>   where Rbs is Bragg-Slater radius. Similar approach is used in NWChem. function mk3_transform ( this , r ) result ( rdr ) class ( mk3_grid ) :: this real ( kind = dp ), intent ( inout ) :: r !< root real ( kind = dp ) :: rdr ( 2 ) real ( kind = dp ) :: y , dy y = 1.0d0 - r ** 3 dy = 3.0d0 * r ** 2 rdr ( 1 ) = - this % alpha0 * log ( y ) ! r rdr ( 2 ) = this % alpha0 * dy / y ! dr end function !> @brief  Mura-Knowles Log-3 grid init subroutine mk3_set ( this , map_grid , opt ) class ( mk3_grid ) :: this integer , optional :: map_grid real ( kind = dp ), optional :: opt this % alpha0 = 3.95d0 if ( present ( opt )) this % alpha0 = opt !   Default uniform grid this % map_grid = dft_radial_grid_map_uniform if ( present ( map_grid )) then if ( map_grid /= dft_radial_grid_map_default ) this % map_grid = map_grid end if this % interval = [ 0.0d0 , 1.0d0 ] end subroutine subroutine mk3_query ( grid_type , map_default ) integer , optional :: grid_type integer , optional :: map_default grid_type = dft_radial_grid_mhl map_default = dft_radial_grid_map_uniform end subroutine !---------------------------------------------------------------------- !> @brief  Treutler-Ahlrichs grid variable transformation. !> @detail  This grid is based on the following variable transformation: !>   ri = R0/log(2) * (1+(xi))**ta_pow * log(2/(1-xi)) !>   to map interval (-1, +1) to (0, +inf). !>   In the original paper, Chebyshev 2nd kind grid is !>   used. R0 are per-atom scaling coefficients. function ta_transform ( this , r ) result ( rdr ) class ( ta_grid ) :: this real ( kind = dp ), intent ( inout ) :: r !< root real ( kind = dp ) :: rdr ( 2 ) real ( kind = dp ), parameter :: log2m1 = 1.0d0 / log ( 2.0d0 ) real ( kind = dp ) :: tpow , tlog tpow = ( 1.0d0 + r ) ** this % pwr tlog = log ( 2.0d0 / ( 1.0d0 - r )) rdr ( 1 ) = log2m1 * tpow * tlog ! r rdr ( 2 ) = log2m1 * ( this % pwr * tpow * tlog / ( 1.0d0 + r ) + tpow / ( 1.0d0 - r )) ! dr end function !> @brief  Treutler-Ahlrichs grid init subroutine ta_set ( this , map_grid , opt ) class ( ta_grid ) :: this integer , optional :: map_grid real ( kind = dp ), optional :: opt !   Treutler-Ahlrichs grid parameter: real ( kind = dp ), parameter :: ta_pow = 0.6d0 this % pwr = ta_pow if ( present ( opt )) this % pwr = opt !   Default Chebyshev grid this % map_grid = dft_radial_grid_map_cheb2 if ( present ( map_grid )) then if ( map_grid /= dft_radial_grid_map_default ) this % map_grid = map_grid end if this % interval = [ - 1.0d0 , 1.0d0 ] end subroutine subroutine ta_query ( grid_type , map_default ) integer , optional :: grid_type integer , optional :: map_default grid_type = dft_radial_grid_mhl map_default = dft_radial_grid_map_cheb2 end subroutine !---------------------------------------------------------------------- !> @brief  Becke grid variable transformation. !> @detail  This grid is based on the following variable transformation: !>   ri = R0*(1+xi)/(1-xi) !>   to map interval (-1, +1) to (0, +inf). !>   In the original paper, Chebyshev 2nd kind grid is !>   used. R0 are per-atom scaling coefficients. function becke_transform ( this , r ) result ( rdr ) class ( becke_grid ) :: this real ( kind = dp ), intent ( inout ) :: r !< root real ( kind = dp ) :: rdr ( 2 ) call this % empty !dummy, avoid warnings rdr ( 1 ) = ( 1.0d0 + r ) / ( 1.0d0 - r ) ! r rdr ( 2 ) = 2.0d0 / ( 1.0d0 - r ) ** 2 ! dr end function !> @brief  Becke grid init subroutine becke_set ( this , map_grid , opt ) class ( becke_grid ) :: this integer , optional :: map_grid real ( kind = dp ), optional :: opt if ( present ( opt )) continue !   Default Chebyshev grid this % map_grid = dft_radial_grid_map_cheb2 if ( present ( map_grid )) then if ( map_grid /= dft_radial_grid_map_default ) this % map_grid = map_grid end if this % interval = [ - 1.0d0 , 1.0d0 ] end subroutine subroutine becke_query ( grid_type , map_default ) integer , optional :: grid_type integer , optional :: map_default grid_type = dft_radial_grid_mhl map_default = dft_radial_grid_map_cheb2 end subroutine !---------------------------------------------------------------------- ! Helper subroutines !---------------------------------------------------------------------- !> @brief Get Chebyshev 2nd kind grid for numerical integration !> @param n [in] order !> @param r [out] roots !> @param w [out] weights !> @param d [in] optional initial interval subroutine getcheb2 ( n , r , w , d ) integer :: n !< order real ( kind = dp ), intent ( out ) :: r (:) !< roots real ( kind = dp ), intent ( out ) :: w (:) !< weights real ( kind = dp ), intent ( in ), optional :: d ( 2 ) !< initial interval real ( kind = dp ), parameter :: d0 ( 2 ) = [ - 1.0d0 , 1.0d0 ] real ( kind = dp ), parameter :: pi = 3.141592653589793238d0 integer :: i r = [( cos ( pi * ( n - i + 1.0d0 ) / ( n + 1 )), i = 1 , n )] ! to ensure ascending root order w = [( pi / ( n + 1 ) * sin ( pi * ( n - i + 1.0d0 ) / ( n + 1 )), i = 1 , n )] if ( present ( d )) call linear_map ( r , w , d0 , d ) end subroutine !---------------------------------------------------------------------- !> @brief Get uniform grid for numerical integration !> @param n [in] order !> @param r [out] roots !> @param w [out] weights !> @param d [in] optional initial interval subroutine getuniform ( n , r , w , d ) integer :: n !< order real ( kind = dp ), intent ( out ) :: r (:) !< roots real ( kind = dp ), intent ( out ) :: w (:) !< weights real ( kind = dp ), intent ( in ), optional :: d ( 2 ) !< initial interval real ( kind = dp ), parameter :: d0 ( 2 ) = [ 0.0d0 , 1.0d0 ] integer :: i r = [( i * 1.0d0 / ( n + 1 ), i = 1 , n )] w = [( 1.0d0 / ( n + 1 ), i = 1 , n )] if ( present ( d )) call linear_map ( r , w , d0 , d ) end subroutine !---------------------------------------------------------------------- !> @brief Linear map of roots and weights to a new interval !> @param r [out] roots !> @param w [out] weights !> @param d0 [in] interval to map from !> @param d [in] interval to map to subroutine linear_map ( r , w , d0 , d ) real ( kind = dp ), intent ( inout ) :: r (:) !< roots real ( kind = dp ), intent ( inout ) :: w (:) !< weights real ( kind = dp ), intent ( in ) :: d0 ( 2 ) !< initial interval real ( kind = dp ), intent ( in ) :: d ( 2 ) !< new interval r = ( d ( 2 ) - d ( 1 )) / ( d0 ( 2 ) - d0 ( 1 )) * ( r - d0 ( 1 )) + d ( 1 ) w = ( d ( 2 ) - d ( 1 )) / ( d0 ( 2 ) - d0 ( 1 )) * w end subroutine !---------------------------------------------------------------------- !---------------------------------------------------------------------- subroutine rad_grid_transform_t_empty end subroutine subroutine base_query ( grid_type , map_default ) integer , optional :: grid_type integer , optional :: map_default grid_type = dft_radial_grid_none map_default = dft_radial_grid_map_default end subroutine end module","tags":"","url":"sourcefile/radial_grid_types.f90.html"},{"title":"grd2_rys.F90 – OpenQP Fortran API","text":"Source Code module grd2_rys use precision , only : dp use basis_tools , only : basis_set use constants , only : bas_mxang , bas_mxcart , num_cart_bf , cart_x , cart_y , cart_z integer , parameter :: MAXCONTR = 120 logical , parameter :: skips ( 4 , 16 ) = reshape ([& . true . , . true . , . true . , . true . , & !  1      ( 1, 1 | 1, 1 ) . true . , . true . , . true . , . false ., & !  2      ( 1, 1 | 1, 2 ) . true . , . true . , . false ., . true . , & !  3      ( 1, 1 | 2, 1 ) . true . , . true . , . false ., . false ., & !  4      ( 1, 1 | 2, 2 ) . true . , . true . , . false ., . false ., & !  5      ( 1, 1 | 2, 3 ) . true . , . false ., . true . , . true . , & !  6      ( 1, 2 | 1, 1 ) . true . , . false ., . true . , . false ., & !  7      ( 1, 2 | 1, 2 ) . true . , . false ., . true . , . false ., & !  8      ( 1, 2 | 1, 3 ) . true . , . false ., . false ., . true . , & !  9      ( 1, 2 | 2, 1 ) . true . , . false ., . false ., . true . , & !  10     ( 1, 2 | 3, 1 ) . false ., . true . , . true . , . true . , & !  11     ( 1, 2 | 2, 2 ) . false ., . true . , . true . , . false ., & !  12     ( 1, 2 | 2, 3 ) . false ., . true . , . false ., . true . , & !  13     ( 1, 2 | 3, 2 ) . false ., . false ., . true . , . true . , & !  14     ( 1, 2 | 3, 3 ) . false ., . false ., . false ., . true . , & !  15     ( 1, 2 | 3, 4 ) . false ., . false ., . false ., . false . & !  16 ], shape ( skips )) type grd2_int_data_t logical :: skip ( 4 ) integer :: id ( 4 ) integer :: at ( 4 ) integer :: am ( 4 ) integer :: nbf ( 4 ) integer :: der ( 4 ) integer :: nder integer :: nroots integer :: invtyp logical :: iandj , kandl , same real ( kind = dp ), allocatable :: gijkl (:) real ( kind = dp ), allocatable :: gnkl (:) real ( kind = dp ), allocatable :: gnm (:) real ( kind = dp ), allocatable :: dij (:,:) real ( kind = dp ), allocatable :: dkl (:,:) real ( kind = dp ), allocatable :: b00 (:) real ( kind = dp ), allocatable :: b01 (:) real ( kind = dp ), allocatable :: b10 (:) real ( kind = dp ), allocatable :: c00 (:) real ( kind = dp ), allocatable :: d00 (:) real ( kind = dp ), allocatable :: f00 (:) real ( kind = dp ), allocatable :: abv (:,:) real ( kind = dp ), allocatable :: PQ (:,:) real ( kind = dp ), allocatable :: PB (:,:) real ( kind = dp ), allocatable :: QD (:,:) real ( kind = dp ), allocatable :: rw (:,:) real ( kind = dp ), allocatable :: ai (:) real ( kind = dp ), allocatable :: aj (:) real ( kind = dp ), allocatable :: ak (:) real ( kind = dp ), allocatable :: al (:) real ( kind = dp ), allocatable :: fi (:) real ( kind = dp ), allocatable :: fj (:) real ( kind = dp ), allocatable :: fk (:) real ( kind = dp ), allocatable :: fl (:) integer :: ijklxyz ( 4 , BAS_MXCART , 4 ) real ( kind = dp ) :: fd ( 3 , 4 ) real ( kind = dp ) :: fd2 ( 3 , 4 , 3 , 4 ) ! Second-derivative 1D integral arrays (allocated only when nder>=2). ! f2tmp is scratch; f2_cc' holds d&#94;2/d(center c)d(center c') of the ! 4-center 1D integrals, stored in the same layout as fi/fj/fk/fl. real ( kind = dp ), allocatable :: f2tmp (:) real ( kind = dp ), allocatable :: f2_11 (:), f2_12 (:), f2_13 (:), f2_14 (:) real ( kind = dp ), allocatable :: f2_22 (:), f2_23 (:), f2_24 (:) real ( kind = dp ), allocatable :: f2_33 (:), f2_34 (:) real ( kind = dp ), allocatable :: f2_44 (:) real ( kind = dp ) :: dtol real ( kind = dp ) :: dabcut contains procedure :: init => gdat_init procedure :: clean => gdat_clean procedure :: set_ids => gdat_set_ids end type type soc2e_int_data_t integer :: id ( 4 ) integer :: at ( 4 ) integer :: am ( 4 ) integer :: nbf ( 4 ) integer :: nder = 1 ! derivatives only on IJ (electron 1) integer :: nroots real ( kind = dp ), allocatable :: gijkl (:) real ( kind = dp ), allocatable :: gnkl (:) real ( kind = dp ), allocatable :: gnm (:) real ( kind = dp ), allocatable :: dij (:,:) real ( kind = dp ), allocatable :: dkl (:,:) real ( kind = dp ), allocatable :: b00 (:) real ( kind = dp ), allocatable :: b01 (:) real ( kind = dp ), allocatable :: b10 (:) real ( kind = dp ), allocatable :: c00 (:) real ( kind = dp ), allocatable :: d00 (:) real ( kind = dp ), allocatable :: f00 (:) real ( kind = dp ), allocatable :: abv (:,:) real ( kind = dp ), allocatable :: PQ (:,:) real ( kind = dp ), allocatable :: PB (:,:) real ( kind = dp ), allocatable :: QD (:,:) real ( kind = dp ), allocatable :: rw (:,:) real ( kind = dp ), allocatable :: ai (:) real ( kind = dp ), allocatable :: aj (:) real ( kind = dp ), allocatable :: ak (:) real ( kind = dp ), allocatable :: al (:) real ( kind = dp ), allocatable :: fi (:) real ( kind = dp ), allocatable :: fj (:) integer :: ijklxyz ( 4 , BAS_MXCART , 4 ) integer :: ao_offset ( 4 ) real ( kind = dp ) :: dtol real ( kind = dp ) :: dabcut contains procedure :: init => soc2e_gdat_init procedure :: clean => soc2e_gdat_clean procedure :: set_ids => soc2e_gdat_set_ids end type logical :: dbg = . false . private public :: grd2_int_data_t public :: grd2_rys_compute public :: soc2e_int_data_t public :: soc2e_rys_compute public :: soc2e_driver public :: grd2_rys_hess_compute contains subroutine gdat_init ( gdat , maxang , nder , & dtol , dabcut , & stat ) implicit none class ( grd2_int_data_t ), intent ( inout ) :: gdat integer , intent ( in ) :: maxang , nder real ( kind = dp ), intent ( in ) :: dtol , dabcut integer , intent ( out ) :: stat integer :: mxbra , mxcart , mxrys gdat % nder = nder gdat % dtol = dtol gdat % dabcut = dabcut ** 2 mxrys = ( 4 * maxang + 2 + gdat % nder ) / 2 mxcart = maxang + 1 + nder mxbra = 2 * mxcart - 1 allocate (& gdat % gijkl ( mxcart ** 4 * MAXCONTR * 3 ), & gdat % gnkl ( mxcart ** 2 * mxbra * MAXCONTR * 3 ), & gdat % gnm ( mxbra ** 2 * MAXCONTR * 3 ), & gdat % dij ( 3 , mxcart ** 2 * MAXCONTR ), & gdat % dkl ( 3 , mxbra * MAXCONTR ), & gdat % b00 ( mxrys * MAXCONTR ), & gdat % b01 ( mxrys * MAXCONTR ), & gdat % b10 ( mxrys * MAXCONTR ), & gdat % c00 ( mxrys * MAXCONTR * 3 ), & gdat % d00 ( mxrys * MAXCONTR * 3 ), & gdat % f00 ( mxrys * MAXCONTR * 3 ), & gdat % abv ( 6 , MAXCONTR ), & gdat % PQ ( 3 , MAXCONTR ), & gdat % PB ( 3 , MAXCONTR ), & gdat % QD ( 3 , MAXCONTR ), & gdat % rw ( mxrys * 2 , MAXCONTR ), & gdat % ai ( MAXCONTR ), & gdat % aj ( MAXCONTR ), & gdat % ak ( MAXCONTR ), & gdat % al ( MAXCONTR ), & gdat % fi ( mxcart ** 4 * MAXCONTR * 3 ), & gdat % fj ( mxcart ** 4 * MAXCONTR * 3 ), & gdat % fk ( mxcart ** 4 * MAXCONTR * 3 ), & gdat % fl ( mxcart ** 4 * MAXCONTR * 3 ), & stat = stat ) !   Second-derivative work arrays (Hessian path only) if ( nder >= 2 ) then allocate (& gdat % f2tmp ( mxcart ** 4 * MAXCONTR * 3 ), & gdat % f2_11 ( mxcart ** 4 * MAXCONTR * 3 ), & gdat % f2_12 ( mxcart ** 4 * MAXCONTR * 3 ), & gdat % f2_13 ( mxcart ** 4 * MAXCONTR * 3 ), & gdat % f2_14 ( mxcart ** 4 * MAXCONTR * 3 ), & gdat % f2_22 ( mxcart ** 4 * MAXCONTR * 3 ), & gdat % f2_23 ( mxcart ** 4 * MAXCONTR * 3 ), & gdat % f2_24 ( mxcart ** 4 * MAXCONTR * 3 ), & gdat % f2_33 ( mxcart ** 4 * MAXCONTR * 3 ), & gdat % f2_34 ( mxcart ** 4 * MAXCONTR * 3 ), & gdat % f2_44 ( mxcart ** 4 * MAXCONTR * 3 ), & stat = stat ) end if end subroutine gdat_init subroutine gdat_clean ( gdat ) implicit none class ( grd2_int_data_t ), intent ( inout ) :: gdat if ( allocated ( gdat % gijkl )) deallocate ( gdat % gijkl ) if ( allocated ( gdat % gnkl )) deallocate ( gdat % gnkl ) if ( allocated ( gdat % gnm )) deallocate ( gdat % gnm ) if ( allocated ( gdat % dij )) deallocate ( gdat % dij ) if ( allocated ( gdat % dkl )) deallocate ( gdat % dkl ) if ( allocated ( gdat % b00 )) deallocate ( gdat % b00 ) if ( allocated ( gdat % b01 )) deallocate ( gdat % b01 ) if ( allocated ( gdat % b10 )) deallocate ( gdat % b10 ) if ( allocated ( gdat % c00 )) deallocate ( gdat % c00 ) if ( allocated ( gdat % d00 )) deallocate ( gdat % d00 ) if ( allocated ( gdat % f00 )) deallocate ( gdat % f00 ) if ( allocated ( gdat % abv )) deallocate ( gdat % abv ) if ( allocated ( gdat % PQ )) deallocate ( gdat % PQ ) if ( allocated ( gdat % PB )) deallocate ( gdat % PB ) if ( allocated ( gdat % QD )) deallocate ( gdat % QD ) if ( allocated ( gdat % rw )) deallocate ( gdat % rw ) if ( allocated ( gdat % ai )) deallocate ( gdat % ai ) if ( allocated ( gdat % aj )) deallocate ( gdat % aj ) if ( allocated ( gdat % ak )) deallocate ( gdat % ak ) if ( allocated ( gdat % al )) deallocate ( gdat % al ) if ( allocated ( gdat % fi )) deallocate ( gdat % fi ) if ( allocated ( gdat % fj )) deallocate ( gdat % fj ) if ( allocated ( gdat % fk )) deallocate ( gdat % fk ) if ( allocated ( gdat % fl )) deallocate ( gdat % fl ) if ( allocated ( gdat % f2tmp )) deallocate ( gdat % f2tmp ) if ( allocated ( gdat % f2_11 )) deallocate ( gdat % f2_11 ) if ( allocated ( gdat % f2_12 )) deallocate ( gdat % f2_12 ) if ( allocated ( gdat % f2_13 )) deallocate ( gdat % f2_13 ) if ( allocated ( gdat % f2_14 )) deallocate ( gdat % f2_14 ) if ( allocated ( gdat % f2_22 )) deallocate ( gdat % f2_22 ) if ( allocated ( gdat % f2_23 )) deallocate ( gdat % f2_23 ) if ( allocated ( gdat % f2_24 )) deallocate ( gdat % f2_24 ) if ( allocated ( gdat % f2_33 )) deallocate ( gdat % f2_33 ) if ( allocated ( gdat % f2_34 )) deallocate ( gdat % f2_34 ) if ( allocated ( gdat % f2_44 )) deallocate ( gdat % f2_44 ) end subroutine gdat_clean subroutine gdat_set_ids ( gdat , basis , i , j , k , l ) implicit none class ( grd2_int_data_t ), intent ( inout ) :: gdat type ( basis_set ), intent ( in ) :: basis integer , intent ( in ) :: i , j , k , l integer :: id ( 4 ), am ( 4 ), flips ( 4 ), tmp ( 2 ), same ! Permute shells so L_i < L_j, L_k < L_l, L_i < L_j flips = [ 1 , 2 , 3 , 4 ] id = [ i , j , k , l ] am = basis % am ([ i , j , k , l ]) if ( am ( 1 ) > am ( 2 )) flips ( 1 : 2 ) = [ 2 , 1 ] if ( am ( 3 ) > am ( 4 )) flips ( 3 : 4 ) = [ 4 , 3 ] if ( max ( am ( 1 ), am ( 2 )) > max ( am ( 3 ), am ( 4 ))) then tmp = flips ( 1 : 2 ) flips ( 1 : 2 ) = flips ( 3 : 4 ) flips ( 3 : 4 ) = tmp end if gdat % id = id ( flips ) gdat % am = am ( flips ) gdat % at = basis % origin ( gdat % id ) ! Compute translation invariance class of the integral: same = 0 if ( gdat % at ( 1 ) /= gdat % at ( 2 )) same = same + 32 if ( gdat % at ( 1 ) /= gdat % at ( 3 )) same = same + 16 if ( gdat % at ( 1 ) /= gdat % at ( 4 )) same = same + 8 if ( gdat % at ( 2 ) /= gdat % at ( 3 )) same = same + 4 if ( gdat % at ( 2 ) /= gdat % at ( 4 )) same = same + 2 if ( gdat % at ( 3 ) /= gdat % at ( 4 )) same = same + 1 select case ( same ) case ( 0 ); gdat % invtyp = 1 !  ( 1, 1 | 1, 1 ) case ( 11 ); gdat % invtyp = 2 !  ( 1, 1 | 1, 2 ) case ( 21 ); gdat % invtyp = 3 !  ( 1, 1 | 2, 1 ) case ( 30 ); gdat % invtyp = 4 !  ( 1, 1 | 2, 2 ) case ( 31 ); gdat % invtyp = 5 !  ( 1, 1 | 2, 3 ) case ( 38 ); gdat % invtyp = 6 !  ( 1, 2 | 1, 1 ) case ( 45 ); gdat % invtyp = 7 !  ( 1, 2 | 1, 2 ) case ( 47 ); gdat % invtyp = 8 !  ( 1, 2 | 1, 3 ) case ( 51 ); gdat % invtyp = 9 !  ( 1, 2 | 2, 1 ) case ( 55 ); gdat % invtyp = 10 !  ( 1, 2 | 3, 1 ) case ( 56 ); gdat % invtyp = 11 !  ( 1, 2 | 2, 2 ) case ( 59 ); gdat % invtyp = 12 !  ( 1, 2 | 2, 3 ) case ( 61 ); gdat % invtyp = 13 !  ( 1, 2 | 3, 2 ) case ( 62 ); gdat % invtyp = 14 !  ( 1, 2 | 3, 3 ) !case(63); gdat%invtyp = 15 !  ( 1, 2 | 3, 4 ) case default ; gdat % invtyp = 15 end select !   For debugging purposes calculate all terms if ( dbg ) gdat % invtyp = 16 gdat % skip = skips (:, gdat % invtyp ) end subroutine gdat_set_ids subroutine grd2_rys_compute ( gdat , ppairs , dab , dabmax , mu2 ) use int2_pairs , only : int2_pair_storage , int2_cutoffs_t implicit none type ( grd2_int_data_t ) :: gdat type ( int2_pair_storage ), intent ( in ) :: ppairs real ( kind = dp ), intent ( in ) :: dabmax real ( kind = dp ), intent ( in ) :: dab ( * ) real ( kind = dp ), intent ( in ), optional :: mu2 integer :: ijg , klg , maxgg , mmax , ng integer :: nimax , njmax , nkmax , nlmax , nmax real ( kind = dp ) :: aa , ab , aandb1 , bb , da , db , test real ( kind = dp ) :: pfac , rho real ( kind = dp ) :: p ( 3 ), q ( 3 ) logical :: last integer :: id1 , id2 , ppid_p , ppid_q , npp_p , npp_q real ( kind = dp ) :: mu2_1 ! Range-separation parameter for Erfc-attenuated integrals mu2_1 = 0 if ( present ( mu2 )) mu2_1 = 1.0d0 / mu2 !   Prepare shell block call set_shells ( gdat ) id1 = maxval ( gdat % id ( 1 : 2 )) id2 = minval ( gdat % id ( 1 : 2 )) npp_p = ppairs % ppid ( 1 , id1 * ( id1 - 1 ) / 2 + id2 ) ppid_p = ppairs % ppid ( 2 , id1 * ( id1 - 1 ) / 2 + id2 ) id1 = maxval ( gdat % id ( 3 : 4 )) id2 = minval ( gdat % id ( 3 : 4 )) npp_q = ppairs % ppid ( 1 , id1 * ( id1 - 1 ) / 2 + id2 ) ppid_q = ppairs % ppid ( 2 , id1 * ( id1 - 1 ) / 2 + id2 ) if ( npp_p * npp_q == 0 ) return nimax = gdat % am ( 1 ) + gdat % der ( 1 ) + 1 njmax = gdat % am ( 2 ) + gdat % der ( 2 ) + 1 nkmax = gdat % am ( 3 ) + gdat % der ( 3 ) + 1 nlmax = gdat % am ( 4 ) + gdat % der ( 4 ) + 1 nmax = gdat % am ( 1 ) + gdat % am ( 2 ) + 1 + min ( gdat % der ( 1 ) + gdat % der ( 2 ), gdat % nder ) mmax = gdat % am ( 3 ) + gdat % am ( 4 ) + 1 + min ( gdat % der ( 3 ) + gdat % der ( 4 ), gdat % nder ) maxgg = MAXCONTR / gdat % nroots !   Pair of k,l primitives gdat % fd = 0 ng = 0 do klg = 1 , npp_q db = ppairs % k ( ppid_q - 1 + klg ) * ppairs % ginv ( ppid_q - 1 + klg ) bb = ppairs % g ( ppid_q - 1 + klg ) q = ppairs % P (:, ppid_q - 1 + klg ) !     Pair of i,j primitives do ijg = 1 , npp_p da = ppairs % k ( ppid_p - 1 + ijg ) * ppairs % ginv ( ppid_p - 1 + ijg ) aa = ppairs % g ( ppid_p - 1 + ijg ) p = ppairs % P (:, ppid_p - 1 + ijg ) ! 2nd term is used for Erfc-attenuated integrals ! It is zero for regular integrals ab = ( aa + bb ) + aa * bb * mu2_1 pfac = da * db test = pfac * pfac if ( test < gdat % dtol * ab ) cycle if ( test * dabmax * dabmax < gdat % dabcut * ab ) cycle aandb1 = 1.0_dp / ab rho = aa * bb * aandb1 ng = ng + 1 gdat % abv ( 1 , ng ) = ppairs % ginv ( ppid_p - 1 + ijg ) gdat % abv ( 2 , ng ) = ppairs % ginv ( ppid_q - 1 + klg ) gdat % abv ( 3 , ng ) = rho gdat % abv ( 4 , ng ) = pfac * sqrt ( aandb1 ) gdat % abv ( 5 , ng ) = aandb1 gdat % abv ( 6 , ng ) = rho * sum (( p - q ) ** 2 ) gdat % ai ( ng ) = 2 * ppairs % alpha_a ( ppid_p - 1 + ijg ) gdat % aj ( ng ) = 2 * ppairs % alpha_b ( ppid_p - 1 + ijg ) gdat % ak ( ng ) = 2 * ppairs % alpha_a ( ppid_q - 1 + klg ) gdat % al ( ng ) = 2 * ppairs % alpha_b ( ppid_q - 1 + klg ) gdat % PQ (:, ng ) = p - q if ( nmax > 1 ) gdat % pb (:, ng ) = ppairs % PB (:, ppid_p - 1 + ijg ) if ( mmax > 1 ) gdat % qd (:, ng ) = ppairs % PB (:, ppid_q - 1 + klg ) gdat % dij (:, ng ) = ppairs % PA (:, ppid_p - 1 + ijg ) - ppairs % PB (:, ppid_p - 1 + ijg ) gdat % dkl (:, ng ) = ppairs % PA (:, ppid_q - 1 + klg ) - ppairs % PB (:, ppid_q - 1 + klg ) last = klg == npp_q . and . ijg == npp_p if ( ng == maxgg . or . last ) then if ( ng == 0 ) return call compute_grd_ints ( gdat , dab , & ng , nmax , mmax , nimax , njmax , nkmax , nlmax ) ng = 0 end if end do end do !   Process derivative integrals call apply_translation_invariance ( gdat ) end subroutine grd2_rys_compute subroutine compute_grd_ints ( gdat , dab , ng , nmax , mmax , nimax , njmax , nkmax , nlmax ) type ( grd2_int_data_t ), intent ( inout ) :: gdat real ( kind = dp ), intent ( in ) :: dab ( * ) integer :: mmax , ng integer :: nimax , njmax , nkmax , nlmax , nmax !   Compute roots and weights for quadrature call compute_rys_rw ( gdat , gdat % rw , ng ) !   Compute coefficients for recursion formulae call compute_coefficients ( gdat % b00 , gdat % b01 , gdat % b10 , & gdat % c00 , gdat % d00 , gdat % f00 , & gdat % abv , gdat % pq , gdat % pb , gdat % qd , gdat % rw , nmax , mmax , ng , gdat % nroots ) !   Compute x, y, z integrals (2 centers, 2-d ) call compute_xyz_p0q0 ( gdat % gnm , ng * gdat % nroots , nmax , mmax , & gdat % b00 , gdat % b01 , gdat % b10 , gdat % c00 , gdat % d00 , gdat % f00 ) !   Compute x, y, z integrals (4 centers, 2-d) call compute_xyz_ijkl ( gdat % gijkl , gdat % gnkl , gdat % gnm , & ng , gdat % nroots , nmax , mmax , nimax , njmax , nkmax , nlmax , & gdat % dij , gdat % dkl ) !   Compute x, y, z integrals for derivatives call compute_der_xyz_ijkl ( gdat , gdat % gijkl , & ng , gdat % nroots * 3 , nimax , njmax , nkmax , nlmax , & gdat % ai , gdat % aj , gdat % ak , gdat % al , gdat % fi , gdat % fj , gdat % fk , gdat % fl ) !   compute derivative integrals call compute_der_ijkl ( gdat , ng * gdat % nroots , gdat % ijklxyz , gdat % gijkl , & gdat % fi , gdat % fj , gdat % fk , gdat % fl , dab , gdat % fd ) end subroutine subroutine set_shells ( gdat ) implicit none type ( grd2_int_data_t ) :: gdat integer :: ish , jsh , ksh , lsh ish = gdat % id ( 1 ) jsh = gdat % id ( 2 ) ksh = gdat % id ( 3 ) lsh = gdat % id ( 4 ) gdat % iandj = ish == jsh gdat % kandl = ksh == lsh gdat % same = ish == ksh . and . jsh == lsh gdat % nbf = num_cart_bf ( gdat % am ) gdat % der (:) = gdat % nder if ( gdat % skip ( 1 )) gdat % der ( 1 ) = 0 if ( gdat % skip ( 2 )) gdat % der ( 2 ) = 0 if ( gdat % skip ( 3 )) gdat % der ( 3 ) = 0 if ( gdat % skip ( 4 )) gdat % der ( 4 ) = 0 !   Set number of quadrature points gdat % nroots = ( sum ( gdat % am ) + 2 + gdat % nder ) / 2 !   Prepare indices for pairs of (i,j) functions call prepare_xyz_ids ( gdat ) end subroutine set_shells subroutine prepare_xyz_ids ( gdat ) implicit none class ( grd2_int_data_t ), intent ( inout ) :: gdat integer :: i , nj , nk , nl , njkl , nkl nj = gdat % am ( 2 ) + gdat % der ( 2 ) + 1 nk = gdat % am ( 3 ) + gdat % der ( 3 ) + 1 nl = gdat % am ( 4 ) + gdat % der ( 4 ) + 1 njkl = nl * nk * nj do i = 1 , gdat % nbf ( 1 ) gdat % ijklxyz ( 1 , i , 1 ) = cart_x ( i , gdat % am ( 1 )) * njkl gdat % ijklxyz ( 2 , i , 1 ) = cart_y ( i , gdat % am ( 1 )) * njkl gdat % ijklxyz ( 3 , i , 1 ) = cart_z ( i , gdat % am ( 1 )) * njkl end do nkl = nl * nk do i = 1 , gdat % nbf ( 2 ) gdat % ijklxyz ( 1 , i , 2 ) = cart_x ( i , gdat % am ( 2 )) * nkl gdat % ijklxyz ( 2 , i , 2 ) = cart_y ( i , gdat % am ( 2 )) * nkl gdat % ijklxyz ( 3 , i , 2 ) = cart_z ( i , gdat % am ( 2 )) * nkl end do !   Prepare indices for pairs of (k,l) functions do i = 1 , gdat % nbf ( 3 ) gdat % ijklxyz ( 1 , i , 3 ) = cart_x ( i , gdat % am ( 3 )) * nl gdat % ijklxyz ( 2 , i , 3 ) = cart_y ( i , gdat % am ( 3 )) * nl gdat % ijklxyz ( 3 , i , 3 ) = cart_z ( i , gdat % am ( 3 )) * nl end do do i = 1 , gdat % nbf ( 4 ) gdat % ijklxyz ( 1 , i , 4 ) = cart_x ( i , gdat % am ( 4 )) + 1 gdat % ijklxyz ( 2 , i , 4 ) = cart_y ( i , gdat % am ( 4 )) + 1 gdat % ijklxyz ( 3 , i , 4 ) = cart_z ( i , gdat % am ( 4 )) + 1 end do end subroutine subroutine compute_rys_rw ( gdat , rwv , numg ) use rys , only : rys_root_t implicit none class ( grd2_int_data_t ), intent ( inout ) :: gdat real ( kind = dp ), intent ( out ) :: rwv ( 2 , numg , * ) integer , intent ( in ) :: numg type ( rys_root_t ) :: root integer :: ng root % nroots = gdat % nroots do ng = 1 , numg root % x = gdat % abv ( 6 , ng ) call root % evaluate rwv ( 1 , ng , 1 : gdat % nroots ) = root % u ( 1 : gdat % nroots ) rwv ( 2 , ng , 1 : gdat % nroots ) = root % w ( 1 : gdat % nroots ) end do end subroutine compute_rys_rw !> @brief Compute Rys quadrature roots and weights for the 2e SOC integrals !> @details !>  Wrapper around the Rys root/weight evaluator for the SOC case. !>  The number of roots is increased by one relative to the standard 2e case !>  to accommodate the higher-order numerator arising from the angular momentum !>  operator: ⟨μν|r&#94;{-3} L|λσ⟩ ~ ⟨∂μ|r&#94;{-1}|∂σ⟩. !> !> @param[inout] gdat   SOC integral data structure (nroots is read from gdat) !> @param[out]   rwv    Roots and weights array (2*nroots x ng) !> @param[in]    numg   Number of primitive pairs in the current batch subroutine soc2e_compute_rys_rw ( gdat , rwv , numg ) use rys , only : rys_root_t implicit none type ( soc2e_int_data_t ), intent ( inout ) :: gdat real ( kind = dp ), intent ( out ) :: rwv ( 2 , numg , * ) integer , intent ( in ) :: numg type ( rys_root_t ) :: root integer :: ng root % nroots = gdat % nroots do ng = 1 , numg root % x = gdat % abv ( 6 , ng ) call root % evaluate rwv ( 1 , ng , 1 : gdat % nroots ) = root % u ( 1 : gdat % nroots ) rwv ( 2 , ng , 1 : gdat % nroots ) = root % w ( 1 : gdat % nroots ) end do end subroutine soc2e_compute_rys_rw subroutine compute_coefficients ( b00 , b01 , b10 , c00 , d00 , f00 , abv , pq , pb , qd , rwv , nmax , mmax , numg , nroots ) implicit none real ( kind = dp ) :: b00 ( numg , * ), b01 ( numg , * ), b10 ( numg , * ) !numg*nroots real ( kind = dp ) :: c00 ( numg , nroots , * ) !numg*nroots*3 real ( kind = dp ) :: d00 ( numg , nroots , * ) !numg*nroots*3 real ( kind = dp ) :: f00 ( numg , nroots , * ) !numg*nroots*3 real ( kind = dp ) :: abv ( 6 , * ), pq ( 3 , * ), pb ( 3 , * ), qd ( 3 , * ) real ( kind = dp ) :: rwv ( 2 , numg , * ) !rwv(2,numg,nroots) integer :: mmax , nmax integer :: numg , nroots integer :: nr , ng real ( kind = dp ) :: a1 , b1 , ab1 real ( kind = dp ) :: pfac , rho , t2 , t2ar , t2br , uu , ww do nr = 1 , nroots do ng = 1 , numg a1 = abv ( 1 , ng ) b1 = abv ( 2 , ng ) rho = abv ( 3 , ng ) pfac = abv ( 4 , ng ) ab1 = abv ( 5 , ng ) uu = rwv ( 1 , ng , nr ) ww = rwv ( 2 , ng , nr ) f00 ( ng , nr , 1 ) = ww * pfac f00 ( ng , nr , 2 ) = 1.0_dp f00 ( ng , nr , 3 ) = 1.0_dp t2 = uu / ( uu + 1 ) t2ar = t2 * rho * a1 t2br = t2 * rho * b1 b00 ( ng , nr ) = 0.5_dp * ab1 * t2 b01 ( ng , nr ) = 0.5_dp * b1 * ( 1.0_dp - t2br ) b10 ( ng , nr ) = 0.5_dp * a1 * ( 1.0_dp - t2ar ) if ( mmax > 1 ) then d00 ( ng , nr , 1 ) = qd ( 1 , ng ) + t2br * pq ( 1 , ng ) d00 ( ng , nr , 2 ) = qd ( 2 , ng ) + t2br * pq ( 2 , ng ) d00 ( ng , nr , 3 ) = qd ( 3 , ng ) + t2br * pq ( 3 , ng ) end if if ( nmax > 1 ) then c00 ( ng , nr , 1 ) = pb ( 1 , ng ) - t2ar * pq ( 1 , ng ) c00 ( ng , nr , 2 ) = pb ( 2 , ng ) - t2ar * pq ( 2 , ng ) c00 ( ng , nr , 3 ) = pb ( 3 , ng ) - t2ar * pq ( 3 , ng ) end if end do end do end subroutine compute_coefficients subroutine compute_xyz_p0q0 ( gnm , ng , nmax , mmax , b00 , b01 , b10 , c00 , d00 , f00 ) implicit none real ( kind = dp ) :: gnm ( ng , 3 , nmax , * ) real ( kind = dp ) :: c00 ( ng , * ), d00 ( ng , * ), f00 ( ng , * ) real ( kind = dp ) :: b00 ( * ), b01 ( * ), b10 ( * ) integer :: ng , nmax , mmax integer :: m , n , xyz !   G(0,0) gnm (: ng ,:, 1 , 1 ) = f00 (:,: 3 ) if ( max ( nmax , mmax ) == 1 ) return if ( nmax > 1 ) then !     g(1,0) = c00 * g(0,0) gnm (: ng , 1 : 3 , 2 , 1 ) = c00 (: ng , 1 : 3 ) * gnm (: ng , 1 : 3 , 1 , 1 ) end if if ( mmax > 1 ) then !     g(0,1) = d00 * g(0,0) gnm (: ng , 1 : 3 , 1 , 2 ) = d00 (: ng , 1 : 3 ) * gnm (: ng , 1 : 3 , 1 , 1 ) if ( nmax > 1 ) then !       g(1,1) = b00 * g(0,0) + d00 * g(1,0) do xyz = 1 , 3 gnm (: ng , xyz , 2 , 2 ) = b00 (: ng ) * gnm (: ng , xyz , 1 , 1 ) & + d00 (: ng , xyz ) * gnm (: ng , xyz , 2 , 1 ) end do end if end if if ( nmax > 2 ) then !     g(n+1,0) = n * b10 * g(n-1,0) + c00 * g(n,0) do n = 2 , nmax - 1 do xyz = 1 , 3 gnm (: ng , xyz , n + 1 , 1 ) = ( n - 1 ) * b10 (: ng ) * gnm (: ng , xyz , n - 1 , 1 ) & + c00 (: ng , xyz ) * gnm (: ng , xyz , n , 1 ) end do end do if ( mmax > 1 ) then !       g(n,1) = n * b00 * g(n-1,0) + d00 * g(n,0) do n = 2 , nmax - 1 do xyz = 1 , 3 gnm (: ng , xyz , n + 1 , 2 ) = n * b00 (: ng ) * gnm (: ng , xyz , n , 1 ) & + d00 (: ng , xyz ) * gnm (: ng , xyz , n + 1 , 1 ) end do end do end if end if if ( mmax < 3 ) return !   g(0,m+1) = m * b01 * g(0,m-1) + d00 * g(o,m) do m = 2 , mmax - 1 do xyz = 1 , 3 gnm (: ng , xyz , 1 , m + 1 ) = ( m - 1 ) * b01 (: ng ) * gnm (: ng , xyz , 1 , m - 1 ) & + d00 (: ng , xyz ) * gnm (: ng , xyz , 1 , m ) end do end do if ( nmax < 2 ) return !   g(1,m) = m * b00 * g(0,m-1) + c00 * g(0,m) do m = 2 , mmax - 1 do xyz = 1 , 3 gnm (: ng , xyz , 2 , m + 1 ) = m * b00 (: ng ) * gnm (: ng , xyz , 1 , m ) & + c00 (: ng , xyz ) * gnm (: ng , xyz , 1 , m + 1 ) end do end do if ( nmax < 3 ) return !   g(n+1,m) = n * b10 * g(n-1,m  ) !            +     c00 * g(n  ,m  ) !            + m * b00 * g(n  ,m-1) do m = 2 , mmax - 1 do n = 2 , nmax - 1 do xyz = 1 , 3 gnm (:, xyz , n + 1 , m + 1 ) = ( n - 1 ) * b10 (: ng ) * gnm (: ng , xyz , n - 1 , m + 1 ) & + c00 (: ng , xyz ) * gnm (: ng , xyz , n , m + 1 ) & + m * b00 (: ng ) * gnm (: ng , xyz , n , m ) end do end do end do end subroutine compute_xyz_p0q0 subroutine compute_xyz_ijkl ( ijkl , gnkl , gnm , ng , nr , nmax , mmax , nimax , njmax , nkmax , nlmax , dij , dkl ) implicit none real ( kind = dp ) :: ijkl ( ng , nr , 3 , nlmax , nkmax , njmax , * ) real ( kind = dp ) :: gnkl ( ng , nr , 3 , nlmax , nkmax , * ) real ( kind = dp ) :: gnm ( ng , nr , 3 , nmax , * ) ! gnm(ng,nmax,mmax) real ( kind = dp ) :: dij ( 3 , * ) ! dij(ng) real ( kind = dp ) :: dkl ( 3 , * ) ! dkl(ng) integer :: ng , nr , nmax , mmax , nimax , njmax , nkmax , nlmax integer :: ni , nk , nl , ig , m1 , n1 , xyz , n , m , ir real ( kind = dp ) :: dt ( ng , 3 ) !   Transposed pair-distance coefficients: contiguous along the batch index, !   so the recursions below run on stride-1 vectors of length ng. do ig = 1 , ng dt ( ig , 1 ) = dkl ( 1 , ig ) dt ( ig , 2 ) = dkl ( 2 , ig ) dt ( ig , 3 ) = dkl ( 3 , ig ) end do !   g(n,k,l) do nk = 1 , nkmax do nl = 1 , nlmax gnkl (:,:,:, nl , nk ,: nmax ) = gnm (:,:,:,:, nl ) end do if ( nk == nkmax ) cycle m1 = mmax - nk !     m ascending: iteration m reads column m+1 before it is overwritten, !     reproducing the whole-array statement semantics. do m = 1 , m1 do n = 1 , nmax do xyz = 1 , 3 do ir = 1 , nr gnm (:, ir , xyz , n , m ) = dt (:, xyz ) * gnm (:, ir , xyz , n , m ) & + gnm (:, ir , xyz , n , m + 1 ) end do end do end do end do end do do ig = 1 , ng dt ( ig , 1 ) = dij ( 1 , ig ) dt ( ig , 2 ) = dij ( 2 , ig ) dt ( ig , 3 ) = dij ( 3 , ig ) end do !   g(i,j,k,l) do ni = 1 , nimax ijkl (:,:,:,:,:, 1 : njmax , ni ) = gnkl (:,:,:,:,:, 1 : njmax ) if ( ni == nimax ) cycle n1 = nmax - ni do n = 1 , n1 do nk = 1 , nkmax do nl = 1 , nlmax do xyz = 1 , 3 do ir = 1 , nr gnkl (:, ir , xyz , nl , nk , n ) = dt (:, xyz ) * gnkl (:, ir , xyz , nl , nk , n ) & + gnkl (:, ir , xyz , nl , nk , n + 1 ) end do end do end do end do end do end do end subroutine compute_xyz_ijkl subroutine compute_der_xyz_ijkl ( gdat , g , & ng , nr3 , nimax , njmax , nkmax , nlmax , aai , aaj , aak , aal , fi , fj , fk , fl ) implicit none type ( grd2_int_data_t ) :: gdat integer :: ng , nr3 , nimax , njmax , nkmax , nlmax real ( kind = dp ) :: g ( * ) real ( kind = dp ) :: aai ( * ) !   aai(ng) real ( kind = dp ) :: aaj ( * ) !   aaj(ng) real ( kind = dp ) :: aak ( * ) !   aak(ng) real ( kind = dp ) :: aal ( * ) !   aal(ng) real ( kind = dp ) :: fi ( * ), fj ( * ), fk ( * ), fl ( * ) integer :: ni , nj , nk , nl ni = gdat % am ( 1 ) + 1 nj = gdat % am ( 2 ) + 1 nk = gdat % am ( 3 ) + 1 nl = gdat % am ( 4 ) + 1 !     Apply the first-derivative operator !         d/d(center) = 2*alpha * raise - power * lower !     along each center's 1D-integral index. The shared kernel views the !     (ng,nr3,nlmax,nkmax,njmax,nimax) arrays as (ng, mid, axis, post) so all !     updates run on contiguous stride-1 vectors of length ng. if (. not . gdat % skip ( 1 )) & ! FI: axis = i (outermost) call deriv_axis_1d ( g , fi , ng , nr3 * nlmax * nkmax * njmax , nimax , 1 , & ni , aai ) if (. not . gdat % skip ( 2 )) & ! FJ: axis = j call deriv_axis_1d ( g , fj , ng , nr3 * nlmax * nkmax , njmax , nimax , & nj , aaj ) if (. not . gdat % skip ( 3 )) & ! FK: axis = k call deriv_axis_1d ( g , fk , ng , nr3 * nlmax , nkmax , njmax * nimax , & nk , aak ) if (. not . gdat % skip ( 4 )) & ! FL: axis = l (innermost after nr3) call deriv_axis_1d ( g , fl , ng , nr3 , nlmax , nkmax * njmax * nimax , & nl , aal ) end subroutine compute_der_xyz_ijkl !> @brief Apply the single-center first-derivative operator along one axis of !>        a 4-center 1D-integral array, vectorized over the contiguous !>        primitive-batch index. !> @details g and f are interpreted as (ng, mid, nax, npost), where `mid` and !>        `npost` are the products of the extents below/above the derivative !>        axis. f(:,m,a,p) = g(:,m,a+1,p)*aa - (a-1)*g(:,m,a-1,p) for !>        a = 1..nphys (the a=1 lowering term vanishes). subroutine deriv_axis_1d ( g , f , ng , mid , nax , npost , nphys , aa ) implicit none integer , intent ( in ) :: ng , mid , nax , npost , nphys real ( kind = dp ), intent ( in ) :: g ( ng , mid , nax , npost ) real ( kind = dp ), intent ( out ) :: f ( ng , mid , nax , npost ) real ( kind = dp ), intent ( in ) :: aa ( ng ) integer :: m , a , p do p = 1 , npost do m = 1 , mid f (:, m , 1 , p ) = g (:, m , 2 , p ) * aa end do do a = 2 , nphys do m = 1 , mid f (:, m , a , p ) = g (:, m , a + 1 , p ) * aa - g (:, m , a - 1 , p ) * ( a - 1 ) end do end do end do end subroutine deriv_axis_1d subroutine compute_der_ijkl ( gdat , ngnr ,& ijklxyz , g0 , fi , fj , fk , fl , den , fd ) implicit none type ( grd2_int_data_t ) :: gdat integer :: ngnr integer :: ijklxyz (:,:,:) real ( kind = dp ), target :: den ( * ) real ( kind = dp ) :: g0 ( ngnr , 3 , * ) real ( kind = dp ) :: fi ( ngnr , 3 , * ), fj ( ngnr , 3 , * ) real ( kind = dp ) :: fk ( ngnr , 3 , * ), fl ( ngnr , 3 , * ) real ( kind = dp ) :: fd ( 3 , 4 ) integer :: i , j , k , l integer :: nx , ny , nz real ( kind = dp ), pointer :: pd (:,:,:,:) real ( kind = dp ) :: yz ( ngnr ), xz ( ngnr ), xy ( ngnr ) pd ( 1 : gdat % nbf ( 4 ), 1 : gdat % nbf ( 3 ), 1 : gdat % nbf ( 2 ), 1 : gdat % nbf ( 1 )) => den ( 1 : product ( gdat % nbf )) do i = 1 , gdat % nbf ( 1 ) do j = 1 , gdat % nbf ( 2 ) do k = 1 , gdat % nbf ( 3 ) do l = 1 , gdat % nbf ( 4 ) nx = ijklxyz ( 1 , i , 1 ) + ijklxyz ( 1 , j , 2 ) + ijklxyz ( 1 , k , 3 ) + ijklxyz ( 1 , l , 4 ) ny = ijklxyz ( 2 , i , 1 ) + ijklxyz ( 2 , j , 2 ) + ijklxyz ( 2 , k , 3 ) + ijklxyz ( 2 , l , 4 ) nz = ijklxyz ( 3 , i , 1 ) + ijklxyz ( 3 , j , 2 ) + ijklxyz ( 3 , k , 3 ) + ijklxyz ( 3 , l , 4 ) associate ( x => g0 (:, 1 , nx ) & , y => g0 (:, 2 , ny ) & , z => g0 (:, 3 , nz ) & , df => pd ( l , k , j , i ) & ) !             Hoist the pair products: they are shared by all four centers. yz = y * z xz = x * z xy = x * y if (. not . gdat % skip ( 1 )) then fd ( 1 , 1 ) = fd ( 1 , 1 ) + df * sum ( fi (:, 1 , nx ) * yz ) fd ( 2 , 1 ) = fd ( 2 , 1 ) + df * sum ( fi (:, 2 , ny ) * xz ) fd ( 3 , 1 ) = fd ( 3 , 1 ) + df * sum ( fi (:, 3 , nz ) * xy ) end if if (. not . gdat % skip ( 2 )) then fd ( 1 , 2 ) = fd ( 1 , 2 ) + df * sum ( fj (:, 1 , nx ) * yz ) fd ( 2 , 2 ) = fd ( 2 , 2 ) + df * sum ( fj (:, 2 , ny ) * xz ) fd ( 3 , 2 ) = fd ( 3 , 2 ) + df * sum ( fj (:, 3 , nz ) * xy ) end if if (. not . gdat % skip ( 3 )) then fd ( 1 , 3 ) = fd ( 1 , 3 ) + df * sum ( fk (:, 1 , nx ) * yz ) fd ( 2 , 3 ) = fd ( 2 , 3 ) + df * sum ( fk (:, 2 , ny ) * xz ) fd ( 3 , 3 ) = fd ( 3 , 3 ) + df * sum ( fk (:, 3 , nz ) * xy ) end if if (. not . gdat % skip ( 4 )) then fd ( 1 , 4 ) = fd ( 1 , 4 ) + df * sum ( fl (:, 1 , nx ) * yz ) fd ( 2 , 4 ) = fd ( 2 , 4 ) + df * sum ( fl (:, 2 , ny ) * xz ) fd ( 3 , 4 ) = fd ( 3 , 4 ) + df * sum ( fl (:, 3 , nz ) * xy ) end if end associate end do end do end do end do end subroutine compute_der_ijkl !############################################################################### !   Second-derivative (Hessian) skeleton: analytic 2e ERI second derivatives !############################################################################### subroutine grd2_rys_hess_compute ( gdat , ppairs , dab , dabmax , mu2 ) !   Mirror of grd2_rys_compute, but accumulates the per-quartet second !   derivative block gdat%fd2(3,4,3,4) instead of the gradient gdat%fd(3,4). !   All four centers are differentiated explicitly (no translation-invariance !   recovery); the only post-processing is the permutational multiplicity !   halving identical to the gradient path. use int2_pairs , only : int2_pair_storage implicit none type ( grd2_int_data_t ) :: gdat type ( int2_pair_storage ), intent ( in ) :: ppairs real ( kind = dp ), intent ( in ) :: dabmax real ( kind = dp ), intent ( in ) :: dab ( * ) real ( kind = dp ), intent ( in ), optional :: mu2 integer :: ijg , klg , maxgg , mmax , ng integer :: nimax , njmax , nkmax , nlmax , nmax real ( kind = dp ) :: aa , ab , aandb1 , bb , da , db , test real ( kind = dp ) :: pfac , rho real ( kind = dp ) :: p ( 3 ), q ( 3 ) logical :: last integer :: id1 , id2 , ppid_p , ppid_q , npp_p , npp_q real ( kind = dp ) :: mu2_1 mu2_1 = 0 if ( present ( mu2 )) mu2_1 = 1.0d0 / mu2 call set_shells ( gdat ) id1 = maxval ( gdat % id ( 1 : 2 )) id2 = minval ( gdat % id ( 1 : 2 )) npp_p = ppairs % ppid ( 1 , id1 * ( id1 - 1 ) / 2 + id2 ) ppid_p = ppairs % ppid ( 2 , id1 * ( id1 - 1 ) / 2 + id2 ) id1 = maxval ( gdat % id ( 3 : 4 )) id2 = minval ( gdat % id ( 3 : 4 )) npp_q = ppairs % ppid ( 1 , id1 * ( id1 - 1 ) / 2 + id2 ) ppid_q = ppairs % ppid ( 2 , id1 * ( id1 - 1 ) / 2 + id2 ) if ( npp_p * npp_q == 0 ) return nimax = gdat % am ( 1 ) + gdat % der ( 1 ) + 1 njmax = gdat % am ( 2 ) + gdat % der ( 2 ) + 1 nkmax = gdat % am ( 3 ) + gdat % der ( 3 ) + 1 nlmax = gdat % am ( 4 ) + gdat % der ( 4 ) + 1 nmax = gdat % am ( 1 ) + gdat % am ( 2 ) + 1 + min ( gdat % der ( 1 ) + gdat % der ( 2 ), gdat % nder ) mmax = gdat % am ( 3 ) + gdat % am ( 4 ) + 1 + min ( gdat % der ( 3 ) + gdat % der ( 4 ), gdat % nder ) maxgg = MAXCONTR / gdat % nroots gdat % fd2 = 0 ng = 0 do klg = 1 , npp_q db = ppairs % k ( ppid_q - 1 + klg ) * ppairs % ginv ( ppid_q - 1 + klg ) bb = ppairs % g ( ppid_q - 1 + klg ) q = ppairs % P (:, ppid_q - 1 + klg ) do ijg = 1 , npp_p da = ppairs % k ( ppid_p - 1 + ijg ) * ppairs % ginv ( ppid_p - 1 + ijg ) aa = ppairs % g ( ppid_p - 1 + ijg ) p = ppairs % P (:, ppid_p - 1 + ijg ) ab = ( aa + bb ) + aa * bb * mu2_1 pfac = da * db test = pfac * pfac if ( test < gdat % dtol * ab ) cycle if ( test * dabmax * dabmax < gdat % dabcut * ab ) cycle aandb1 = 1.0_dp / ab rho = aa * bb * aandb1 ng = ng + 1 gdat % abv ( 1 , ng ) = ppairs % ginv ( ppid_p - 1 + ijg ) gdat % abv ( 2 , ng ) = ppairs % ginv ( ppid_q - 1 + klg ) gdat % abv ( 3 , ng ) = rho gdat % abv ( 4 , ng ) = pfac * sqrt ( aandb1 ) gdat % abv ( 5 , ng ) = aandb1 gdat % abv ( 6 , ng ) = rho * sum (( p - q ) ** 2 ) gdat % ai ( ng ) = 2 * ppairs % alpha_a ( ppid_p - 1 + ijg ) gdat % aj ( ng ) = 2 * ppairs % alpha_b ( ppid_p - 1 + ijg ) gdat % ak ( ng ) = 2 * ppairs % alpha_a ( ppid_q - 1 + klg ) gdat % al ( ng ) = 2 * ppairs % alpha_b ( ppid_q - 1 + klg ) gdat % PQ (:, ng ) = p - q if ( nmax > 1 ) gdat % pb (:, ng ) = ppairs % PB (:, ppid_p - 1 + ijg ) if ( mmax > 1 ) gdat % qd (:, ng ) = ppairs % PB (:, ppid_q - 1 + klg ) gdat % dij (:, ng ) = ppairs % PA (:, ppid_p - 1 + ijg ) - ppairs % PB (:, ppid_p - 1 + ijg ) gdat % dkl (:, ng ) = ppairs % PA (:, ppid_q - 1 + klg ) - ppairs % PB (:, ppid_q - 1 + klg ) last = klg == npp_q . and . ijg == npp_p if ( ng == maxgg . or . last ) then if ( ng == 0 ) return call compute_grd2_ints ( gdat , dab , & ng , nmax , mmax , nimax , njmax , nkmax , nlmax ) ng = 0 end if end do end do !   Permutational multiplicity (same correction as the gradient path) if ( gdat % iandj ) gdat % fd2 = 0.5_dp * gdat % fd2 if ( gdat % kandl ) gdat % fd2 = 0.5_dp * gdat % fd2 if ( gdat % same ) gdat % fd2 = 0.5_dp * gdat % fd2 end subroutine grd2_rys_hess_compute subroutine compute_grd2_ints ( gdat , dab , ng , nmax , mmax , nimax , njmax , nkmax , nlmax ) type ( grd2_int_data_t ), intent ( inout ) :: gdat real ( kind = dp ), intent ( in ) :: dab ( * ) integer :: mmax , ng integer :: nimax , njmax , nkmax , nlmax , nmax call compute_rys_rw ( gdat , gdat % rw , ng ) call compute_coefficients ( gdat % b00 , gdat % b01 , gdat % b10 , & gdat % c00 , gdat % d00 , gdat % f00 , & gdat % abv , gdat % pq , gdat % pb , gdat % qd , gdat % rw , nmax , mmax , ng , gdat % nroots ) call compute_xyz_p0q0 ( gdat % gnm , ng * gdat % nroots , nmax , mmax , & gdat % b00 , gdat % b01 , gdat % b10 , gdat % c00 , gdat % d00 , gdat % f00 ) call compute_xyz_ijkl ( gdat % gijkl , gdat % gnkl , gdat % gnm , & ng , gdat % nroots , nmax , mmax , nimax , njmax , nkmax , nlmax , & gdat % dij , gdat % dkl ) !   First derivatives (all four centers) call compute_der_xyz_ijkl ( gdat , gdat % gijkl , & ng , gdat % nroots * 3 , nimax , njmax , nkmax , nlmax , & gdat % ai , gdat % aj , gdat % ak , gdat % al , gdat % fi , gdat % fj , gdat % fk , gdat % fl ) !   Second-derivative 1D arrays (10 unique center pairs) call compute_der2_xyz_ijkl ( gdat , & ng , gdat % nroots * 3 , nimax , njmax , nkmax , nlmax ) !   Contract with density into the per-quartet second-derivative block call compute_der2_ijkl ( gdat , ng * gdat % nroots , gdat % ijklxyz , gdat % gijkl , & gdat % fi , gdat % fj , gdat % fk , gdat % fl , & gdat % f2_11 , gdat % f2_12 , gdat % f2_13 , gdat % f2_14 , & gdat % f2_22 , gdat % f2_23 , gdat % f2_24 , & gdat % f2_33 , gdat % f2_34 , gdat % f2_44 , & dab , gdat % fd2 ) end subroutine compute_grd2_ints subroutine der_center ( src , dst , ng , nr3 , nlmax , nkmax , njmax , nimax , & active , aa , imax , jmax , kmax , lmax ) !   Apply the single-center first-derivative operator !       d/d(center) = 2*alpha * raise  -  power * lower !   to a 4-center 1D integral array (g layout), filling dst over the !   requested physical index ranges. Composing this operator twice (or on !   two different centers) yields the second-derivative arrays. implicit none integer , intent ( in ) :: ng , nr3 , nlmax , nkmax , njmax , nimax integer , intent ( in ) :: active , imax , jmax , kmax , lmax real ( kind = dp ), intent ( in ) :: src ( ng , nr3 , nlmax , nkmax , njmax , nimax ) real ( kind = dp ), intent ( out ) :: dst ( ng , nr3 , nlmax , nkmax , njmax , nimax ) real ( kind = dp ), intent ( in ) :: aa ( * ) integer :: i , j , k , l , n select case ( active ) case ( 1 ) ! d/d center 1 (i index) do i = 1 , imax do j = 1 , jmax do k = 1 , kmax do l = 1 , lmax if ( i == 1 ) then do n = 1 , ng dst ( n ,:, l , k , j , 1 ) = src ( n ,:, l , k , j , 2 ) * aa ( n ) end do else do n = 1 , ng dst ( n ,:, l , k , j , i ) = src ( n ,:, l , k , j , i + 1 ) * aa ( n ) - src ( n ,:, l , k , j , i - 1 ) * ( i - 1 ) end do end if end do end do end do end do case ( 2 ) ! d/d center 2 (j index) do i = 1 , imax do j = 1 , jmax do k = 1 , kmax do l = 1 , lmax if ( j == 1 ) then do n = 1 , ng dst ( n ,:, l , k , 1 , i ) = src ( n ,:, l , k , 2 , i ) * aa ( n ) end do else do n = 1 , ng dst ( n ,:, l , k , j , i ) = src ( n ,:, l , k , j + 1 , i ) * aa ( n ) - src ( n ,:, l , k , j - 1 , i ) * ( j - 1 ) end do end if end do end do end do end do case ( 3 ) ! d/d center 3 (k index) do i = 1 , imax do j = 1 , jmax do k = 1 , kmax do l = 1 , lmax if ( k == 1 ) then do n = 1 , ng dst ( n ,:, l , 1 , j , i ) = src ( n ,:, l , 2 , j , i ) * aa ( n ) end do else do n = 1 , ng dst ( n ,:, l , k , j , i ) = src ( n ,:, l , k + 1 , j , i ) * aa ( n ) - src ( n ,:, l , k - 1 , j , i ) * ( k - 1 ) end do end if end do end do end do end do case ( 4 ) ! d/d center 4 (l index) do i = 1 , imax do j = 1 , jmax do k = 1 , kmax do l = 1 , lmax if ( l == 1 ) then do n = 1 , ng dst ( n ,:, 1 , k , j , i ) = src ( n ,:, 2 , k , j , i ) * aa ( n ) end do else do n = 1 , ng dst ( n ,:, l , k , j , i ) = src ( n ,:, l + 1 , k , j , i ) * aa ( n ) - src ( n ,:, l - 1 , k , j , i ) * ( l - 1 ) end do end if end do end do end do end do end select end subroutine der_center subroutine compute_der2_xyz_ijkl ( gdat , ng , nr3 , nimax , njmax , nkmax , nlmax ) !   Build the 10 unique center-pair second-derivative 1D integral arrays by !   composing the single-center first-derivative operator (der_center). implicit none type ( grd2_int_data_t ) :: gdat integer , intent ( in ) :: ng , nr3 , nimax , njmax , nkmax , nlmax integer :: ni , nj , nk , nl ni = gdat % am ( 1 ) + 1 nj = gdat % am ( 2 ) + 1 nk = gdat % am ( 3 ) + 1 nl = gdat % am ( 4 ) + 1 !   Same-center second derivatives: apply the operator twice (via scratch). !   f2_11 = d/di ( d/di g ) call der_center ( gdat % gijkl , gdat % f2tmp , ng , nr3 , nlmax , nkmax , njmax , nimax , & 1 , gdat % ai , ni + 1 , nj , nk , nl ) call der_center ( gdat % f2tmp , gdat % f2_11 , ng , nr3 , nlmax , nkmax , njmax , nimax , & 1 , gdat % ai , ni , nj , nk , nl ) !   f2_22 = d/dj ( d/dj g ) call der_center ( gdat % gijkl , gdat % f2tmp , ng , nr3 , nlmax , nkmax , njmax , nimax , & 2 , gdat % aj , ni , nj + 1 , nk , nl ) call der_center ( gdat % f2tmp , gdat % f2_22 , ng , nr3 , nlmax , nkmax , njmax , nimax , & 2 , gdat % aj , ni , nj , nk , nl ) !   f2_33 = d/dk ( d/dk g ) call der_center ( gdat % gijkl , gdat % f2tmp , ng , nr3 , nlmax , nkmax , njmax , nimax , & 3 , gdat % ak , ni , nj , nk + 1 , nl ) call der_center ( gdat % f2tmp , gdat % f2_33 , ng , nr3 , nlmax , nkmax , njmax , nimax , & 3 , gdat % ak , ni , nj , nk , nl ) !   f2_44 = d/dl ( d/dl g ) call der_center ( gdat % gijkl , gdat % f2tmp , ng , nr3 , nlmax , nkmax , njmax , nimax , & 4 , gdat % al , ni , nj , nk , nl + 1 ) call der_center ( gdat % f2tmp , gdat % f2_44 , ng , nr3 , nlmax , nkmax , njmax , nimax , & 4 , gdat % al , ni , nj , nk , nl ) !   Mixed-center second derivatives: apply the second center's operator to the !   already-formed first-derivative array (fi/fj/fk/fl). call der_center ( gdat % fi , gdat % f2_12 , ng , nr3 , nlmax , nkmax , njmax , nimax , & 2 , gdat % aj , ni , nj , nk , nl ) call der_center ( gdat % fi , gdat % f2_13 , ng , nr3 , nlmax , nkmax , njmax , nimax , & 3 , gdat % ak , ni , nj , nk , nl ) call der_center ( gdat % fi , gdat % f2_14 , ng , nr3 , nlmax , nkmax , njmax , nimax , & 4 , gdat % al , ni , nj , nk , nl ) call der_center ( gdat % fj , gdat % f2_23 , ng , nr3 , nlmax , nkmax , njmax , nimax , & 3 , gdat % ak , ni , nj , nk , nl ) call der_center ( gdat % fj , gdat % f2_24 , ng , nr3 , nlmax , nkmax , njmax , nimax , & 4 , gdat % al , ni , nj , nk , nl ) call der_center ( gdat % fk , gdat % f2_34 , ng , nr3 , nlmax , nkmax , njmax , nimax , & 4 , gdat % al , ni , nj , nk , nl ) end subroutine compute_der2_xyz_ijkl subroutine compute_der2_ijkl ( gdat , ngnr , ijklxyz , g0 , fi , fj , fk , fl , & f2_11 , f2_12 , f2_13 , f2_14 , f2_22 , f2_23 , f2_24 , & f2_33 , f2_34 , f2_44 , den , fd2 ) !   Contract the 1D first/second derivative arrays with the 2-body density to !   form the per-quartet second-derivative block fd2(a1,c1,a2,c2). implicit none type ( grd2_int_data_t ) :: gdat integer :: ngnr integer :: ijklxyz (:,:,:) real ( kind = dp ), target :: den ( * ) real ( kind = dp ) :: g0 ( ngnr , 3 , * ) real ( kind = dp ) :: fi ( ngnr , 3 , * ), fj ( ngnr , 3 , * ), fk ( ngnr , 3 , * ), fl ( ngnr , 3 , * ) real ( kind = dp ) :: f2_11 ( ngnr , 3 , * ), f2_12 ( ngnr , 3 , * ), f2_13 ( ngnr , 3 , * ) real ( kind = dp ) :: f2_14 ( ngnr , 3 , * ), f2_22 ( ngnr , 3 , * ), f2_23 ( ngnr , 3 , * ) real ( kind = dp ) :: f2_24 ( ngnr , 3 , * ), f2_33 ( ngnr , 3 , * ), f2_34 ( ngnr , 3 , * ) real ( kind = dp ) :: f2_44 ( ngnr , 3 , * ) real ( kind = dp ) :: fd2 ( 3 , 4 , 3 , 4 ) integer :: i , j , k , l integer :: noff ( 3 ) integer :: c1 , c2 , a1 , a2 , a3 , o1 , o2 real ( kind = dp ) :: df , val real ( kind = dp ), pointer :: pd (:,:,:,:) pd ( 1 : gdat % nbf ( 4 ), 1 : gdat % nbf ( 3 ), 1 : gdat % nbf ( 2 ), 1 : gdat % nbf ( 1 )) => den ( 1 : product ( gdat % nbf )) do i = 1 , gdat % nbf ( 1 ) do j = 1 , gdat % nbf ( 2 ) do k = 1 , gdat % nbf ( 3 ) do l = 1 , gdat % nbf ( 4 ) noff ( 1 ) = ijklxyz ( 1 , i , 1 ) + ijklxyz ( 1 , j , 2 ) + ijklxyz ( 1 , k , 3 ) + ijklxyz ( 1 , l , 4 ) noff ( 2 ) = ijklxyz ( 2 , i , 1 ) + ijklxyz ( 2 , j , 2 ) + ijklxyz ( 2 , k , 3 ) + ijklxyz ( 2 , l , 4 ) noff ( 3 ) = ijklxyz ( 3 , i , 1 ) + ijklxyz ( 3 , j , 2 ) + ijklxyz ( 3 , k , 3 ) + ijklxyz ( 3 , l , 4 ) df = pd ( l , k , j , i ) do c1 = 1 , 4 do a1 = 1 , 3 do c2 = 1 , 4 do a2 = 1 , 3 if ( a1 == a2 ) then ! both derivatives act on the same 1D direction factor o1 = mod ( a1 , 3 ) + 1 o2 = mod ( a1 + 1 , 3 ) + 1 val = df * sum ( f2pick ( c1 , c2 , a1 , noff ( a1 )) & * g0 (:, o1 , noff ( o1 )) * g0 (:, o2 , noff ( o2 )) ) else ! different direction factors: product of first derivatives a3 = 6 - a1 - a2 val = df * sum ( f1pick ( c1 , a1 , noff ( a1 )) & * f1pick ( c2 , a2 , noff ( a2 )) * g0 (:, a3 , noff ( a3 )) ) end if fd2 ( a1 , c1 , a2 , c2 ) = fd2 ( a1 , c1 , a2 , c2 ) + val end do end do end do end do end do end do end do end do contains function f1pick ( c , d , o ) result ( v ) integer , intent ( in ) :: c , d , o real ( kind = dp ) :: v ( ngnr ) select case ( c ) case ( 1 ); v = fi (:, d , o ) case ( 2 ); v = fj (:, d , o ) case ( 3 ); v = fk (:, d , o ) case ( 4 ); v = fl (:, d , o ) end select end function f1pick function f2pick ( ca , cb , d , o ) result ( v ) integer , intent ( in ) :: ca , cb , d , o real ( kind = dp ) :: v ( ngnr ) integer :: lo , hi lo = min ( ca , cb ); hi = max ( ca , cb ) select case ( lo * 10 + hi ) case ( 11 ); v = f2_11 (:, d , o ) case ( 12 ); v = f2_12 (:, d , o ) case ( 13 ); v = f2_13 (:, d , o ) case ( 14 ); v = f2_14 (:, d , o ) case ( 22 ); v = f2_22 (:, d , o ) case ( 23 ); v = f2_23 (:, d , o ) case ( 24 ); v = f2_24 (:, d , o ) case ( 33 ); v = f2_33 (:, d , o ) case ( 34 ); v = f2_34 (:, d , o ) case ( 44 ); v = f2_44 (:, d , o ) end select end function f2pick end subroutine compute_der2_ijkl subroutine apply_translation_invariance ( gdat ) implicit none type ( grd2_int_data_t ) :: gdat if ( gdat % nder == 0 ) return !   Translational invariance for gradient elements associate ( fd => gdat % fd ) if ( gdat % iandj ) fd = 0.5 * fd if ( gdat % kandl ) fd = 0.5 * fd if ( gdat % same ) fd = 0.5 * fd select case ( gdat % invtyp ) case ( 2 ) ; fd (:, 1 ) = - fd (:, 4 ) case ( 3 ) ; fd (:, 1 ) = - fd (:, 3 ) case ( 4 , 5 ) ; fd (:, 1 ) = - ( fd (:, 3 ) + fd (:, 4 )) case ( 6 ) ; fd (:, 1 ) = - fd (:, 2 ) case ( 7 , 8 ) ; fd (:, 1 ) = - ( fd (:, 2 ) + fd (:, 4 )) case ( 9 , 10 ) ; fd (:, 1 ) = - ( fd (:, 2 ) + fd (:, 3 )) case ( 11 ) ; fd (:, 2 ) = - fd (:, 1 ) case ( 12 ) ; fd (:, 2 ) = - ( fd (:, 1 ) + fd (:, 4 )) case ( 13 ) ; fd (:, 2 ) = - ( fd (:, 1 ) + fd (:, 3 )) case ( 14 ) ; fd (:, 3 ) = - ( fd (:, 1 ) + fd (:, 2 )) case ( 15 ) ; fd (:, 4 ) = - ( fd (:, 1 ) + fd (:, 2 ) + fd (:, 3 )) end select end associate end subroutine apply_translation_invariance !> @brief Allocate and initialise the 2e SOC integral data structure !> @details !>  Extends gdat_init for the 2e mean-field SOC case. Allocates the standard !>  Rys quadrature work arrays (b00, b01, b10, c00, d00, f00, rw, abv, PQ, PB, QD, !>  gnm, gnkl, gijkl, dij, dkl) plus fi and fj which hold the derivative-shifted !>  integrals needed by the SOC recurrence (fi = d/dA phi_i, fj = d/dB phi_j). !>  Sizes are determined by maxang and gdat%nder. !> !> @param[inout] gdat    SOC integral data structure (soc2e_int_data_t) !> @param[in]    maxang  Maximum angular momentum in the basis !> @param[in]    dtol    Distance screening threshold !> @param[in]    dabcut  |AB|&#94;2 cut-off for shell-pair prescreening !> @param[out]   stat    Allocate status (0 = success) subroutine soc2e_gdat_init ( gdat , maxang , dtol , dabcut , stat ) implicit none class ( soc2e_int_data_t ), intent ( inout ) :: gdat integer , intent ( in ) :: maxang real ( kind = dp ), intent ( in ) :: dtol , dabcut integer , intent ( out ) :: stat integer :: mxbra , mxcart , mxrys gdat % dtol = dtol gdat % dabcut = dabcut ** 2 mxrys = ( 4 * maxang + 2 + gdat % nder ) / 2 mxcart = maxang + 1 + gdat % nder mxbra = 2 * mxcart - 1 allocate (& gdat % gijkl ( mxcart ** 4 * MAXCONTR * 3 ), & gdat % gnkl ( mxcart ** 2 * mxbra * MAXCONTR * 3 ), & gdat % gnm ( mxbra ** 2 * MAXCONTR * 3 ), & gdat % dij ( 3 , mxcart ** 2 * MAXCONTR ), & gdat % dkl ( 3 , mxbra * MAXCONTR ), & gdat % b00 ( mxrys * MAXCONTR ), & gdat % b01 ( mxrys * MAXCONTR ), & gdat % b10 ( mxrys * MAXCONTR ), & gdat % c00 ( mxrys * MAXCONTR * 3 ), & gdat % d00 ( mxrys * MAXCONTR * 3 ), & gdat % f00 ( mxrys * MAXCONTR * 3 ), & gdat % abv ( 6 , MAXCONTR ), & gdat % PQ ( 3 , MAXCONTR ), & gdat % PB ( 3 , MAXCONTR ), & gdat % QD ( 3 , MAXCONTR ), & gdat % rw ( mxrys * 2 , MAXCONTR ), & gdat % ai ( MAXCONTR ), & gdat % aj ( MAXCONTR ), & gdat % ak ( MAXCONTR ), & gdat % al ( MAXCONTR ), & gdat % fi ( mxcart ** 4 * MAXCONTR * 3 ), & gdat % fj ( mxcart ** 4 * MAXCONTR * 3 ), & stat = stat ) end subroutine soc2e_gdat_init !> @brief Deallocate all arrays in the 2e SOC integral data structure !> @param[inout] gdat  SOC integral data structure to be cleaned subroutine soc2e_gdat_clean ( gdat ) implicit none class ( soc2e_int_data_t ), intent ( inout ) :: gdat if ( allocated ( gdat % gijkl )) deallocate ( gdat % gijkl ) if ( allocated ( gdat % gnkl )) deallocate ( gdat % gnkl ) if ( allocated ( gdat % gnm )) deallocate ( gdat % gnm ) if ( allocated ( gdat % dij )) deallocate ( gdat % dij ) if ( allocated ( gdat % dkl )) deallocate ( gdat % dkl ) if ( allocated ( gdat % b00 )) deallocate ( gdat % b00 ) if ( allocated ( gdat % b01 )) deallocate ( gdat % b01 ) if ( allocated ( gdat % b10 )) deallocate ( gdat % b10 ) if ( allocated ( gdat % c00 )) deallocate ( gdat % c00 ) if ( allocated ( gdat % d00 )) deallocate ( gdat % d00 ) if ( allocated ( gdat % f00 )) deallocate ( gdat % f00 ) if ( allocated ( gdat % abv )) deallocate ( gdat % abv ) if ( allocated ( gdat % PQ )) deallocate ( gdat % PQ ) if ( allocated ( gdat % PB )) deallocate ( gdat % PB ) if ( allocated ( gdat % QD )) deallocate ( gdat % QD ) if ( allocated ( gdat % rw )) deallocate ( gdat % rw ) if ( allocated ( gdat % ai )) deallocate ( gdat % ai ) if ( allocated ( gdat % aj )) deallocate ( gdat % aj ) if ( allocated ( gdat % ak )) deallocate ( gdat % ak ) if ( allocated ( gdat % al )) deallocate ( gdat % al ) if ( allocated ( gdat % fi )) deallocate ( gdat % fi ) if ( allocated ( gdat % fj )) deallocate ( gdat % fj ) end subroutine soc2e_gdat_clean !> @brief Store shell quartet (i,j,k,l) metadata in the SOC integral data structure !> @details !>  Records angular momenta, AO offsets, and contraction degrees for the four !>  shells of the current quartet. Called once per quartet before soc2e_rys_compute. !> !> @param[inout] gdat   SOC integral data structure !> @param[in]    basis  Basis set descriptor !> @param[in]    i,j,k,l  Shell indices of the current quartet (1-based) subroutine soc2e_gdat_set_ids ( gdat , basis , i , j , k , l ) implicit none class ( soc2e_int_data_t ), intent ( inout ) :: gdat type ( basis_set ), intent ( in ) :: basis integer , intent ( in ) :: i , j , k , l integer :: id ( 4 ), am ( 4 ), flips ( 4 ), tmp ( 2 ) flips = [ 1 , 2 , 3 , 4 ] id = [ i , j , k , l ] am = basis % am ([ i , j , k , l ]) ! Sort within IJ pair and within KL pair only ! Never swap IJ with KL: derivatives are on IJ side only if ( am ( 1 ) > am ( 2 )) flips ( 1 : 2 ) = [ 2 , 1 ] if ( am ( 3 ) > am ( 4 )) flips ( 3 : 4 ) = [ 4 , 3 ] gdat % id = id ( flips ) gdat % am = am ( flips ) gdat % at = basis % origin ( gdat % id ) gdat % ao_offset = basis % ao_offset ( gdat % id ) end subroutine soc2e_gdat_set_ids !> @brief Set shell parameters for a given quartet in the SOC integral data structure !> @details !>  Mirrors gdat_set_ids but with a SOC-specific shell ordering constraint: !>  shells i,j (bra) may be swapped to put lower-am shell first, and similarly !>  for k,l (ket), but the bra-ket pair is never exchanged because the derivative !>  recurrence (d/dA phi_i) acts only on the bra side. !> !> @param[inout] gdat  SOC integral data structure subroutine soc2e_set_shells ( gdat ) implicit none type ( soc2e_int_data_t ) :: gdat gdat % nbf = num_cart_bf ( gdat % am ) gdat % nroots = ( sum ( gdat % am ) + 2 + gdat % nder ) / 2 call soc2e_prepare_xyz_ids ( gdat ) end subroutine soc2e_set_shells !> @brief Prepare Cartesian index tables for the 2e SOC integral recurrence !> @details !>  Builds the ijklxyz index array that maps each Cartesian component (nx,ny,nz) !>  of each shell function to a flat position in the integral array. Also sets !>  nroots (number of Rys roots) from the total angular momentum of the quartet. !>  Analogous to prepare_xyz_ids but extended to include the derivative index !>  dimension needed for d/dA phi_i and d/dB phi_j. !> !> @param[inout] gdat  SOC integral data structure subroutine soc2e_prepare_xyz_ids ( gdat ) implicit none type ( soc2e_int_data_t ) :: gdat integer :: i , nj , nk , nl , njkl , nkl integer :: nd nd = gdat % nder nj = gdat % am ( 2 ) + nd + 1 nk = gdat % am ( 3 ) + 1 ! no derivative on KL nl = gdat % am ( 4 ) + 1 ! no derivative on KL njkl = nl * nk * nj do i = 1 , gdat % nbf ( 1 ) gdat % ijklxyz ( 1 , i , 1 ) = cart_x ( i , gdat % am ( 1 )) * njkl gdat % ijklxyz ( 2 , i , 1 ) = cart_y ( i , gdat % am ( 1 )) * njkl gdat % ijklxyz ( 3 , i , 1 ) = cart_z ( i , gdat % am ( 1 )) * njkl end do nkl = nl * nk do i = 1 , gdat % nbf ( 2 ) gdat % ijklxyz ( 1 , i , 2 ) = cart_x ( i , gdat % am ( 2 )) * nkl gdat % ijklxyz ( 2 , i , 2 ) = cart_y ( i , gdat % am ( 2 )) * nkl gdat % ijklxyz ( 3 , i , 2 ) = cart_z ( i , gdat % am ( 2 )) * nkl end do do i = 1 , gdat % nbf ( 3 ) gdat % ijklxyz ( 1 , i , 3 ) = cart_x ( i , gdat % am ( 3 )) * nl gdat % ijklxyz ( 2 , i , 3 ) = cart_y ( i , gdat % am ( 3 )) * nl gdat % ijklxyz ( 3 , i , 3 ) = cart_z ( i , gdat % am ( 3 )) * nl end do do i = 1 , gdat % nbf ( 4 ) gdat % ijklxyz ( 1 , i , 4 ) = cart_x ( i , gdat % am ( 4 )) + 1 gdat % ijklxyz ( 2 , i , 4 ) = cart_y ( i , gdat % am ( 4 )) + 1 gdat % ijklxyz ( 3 , i , 4 ) = cart_z ( i , gdat % am ( 4 )) + 1 end do end subroutine soc2e_prepare_xyz_ids !> @brief Compute 2e SOC AO integrals for a shell quartet (i,j,k,l) via Rys quadrature !> @details !>  Outer loop over primitive pairs on the bra (ij) and ket (kl) sides. !>  For each pair batch, calls: !>    soc2e_compute_rys_rw   -- Rys roots and weights !>    compute_coefficients   -- recursion coefficients (b00, b01, b10, c00, d00, f00) !>    compute_xyz_p0q0       -- base integrals [p0|q0] in gnm !>    compute_soc2e_xyz      -- apply derivative recurrence to get Cartesian ints !>    compute_soc2e_ao       -- contract with density and accumulate into wao !>  Prescreening is applied via the Schwarz bound gmax * dabmax. !> !> @param[inout] gdat   SOC integral data structure (set for the current quartet) !> @param[in]    ppairs Shell-pair list with pre-screened primitive pairs !> @param[in]    gmax   Maximum Schwarz estimate over all ket pairs (for screening) !> @param[in]    den    ROHF density matrix (nbf x nbf) !> @param[inout] wao    2e SOC AO contribution matrix (3 x nbf x nbf); accumulated subroutine soc2e_rys_compute ( gdat , ppairs , gmax , den , wao ) use int2_pairs , only : int2_pair_storage implicit none type ( soc2e_int_data_t ), intent ( inout ) :: gdat type ( int2_pair_storage ), intent ( in ) :: ppairs real ( kind = dp ), intent ( in ) :: gmax real ( kind = dp ), intent ( in ) :: den (:,:) real ( kind = dp ), intent ( inout ) :: wao (:,:,:) integer :: ijg , klg , maxgg , mmax , ng integer :: nimax , njmax , nkmax , nlmax , nmax real ( kind = dp ) :: aa , ab , aandb1 , bb , da , db , test real ( kind = dp ) :: pfac , rho real ( kind = dp ) :: p ( 3 ), q ( 3 ) logical :: last integer :: id1 , id2 , ppid_p , ppid_q , npp_p , npp_q integer :: mk , ml , ao_k , ao_l real ( kind = dp ) :: dabmax call soc2e_set_shells ( gdat ) ! Density screening bound.  It must cover ALL density blocks contracted ! in compute_soc2e_ao: the Coulomb term uses D(K,L), while the exchange ! terms use the cross blocks D(I,L), D(J,L), D(I,K), D(J,K).  Screening ! on the ket block alone silently drops the exchange contributions ! whenever D(K,L) ~ 0 although the cross blocks are finite (e.g. the ! s-p blocks of a spherical atom are exactly zero), which under-screens ! the SOC (C atom 3P spacing 22.3 instead of 16.4 cm-1). dabmax = 0.0_dp do mk = 1 , gdat % nbf ( 3 ) ao_k = gdat % ao_offset ( 3 ) - 1 + mk do ml = 1 , gdat % nbf ( 4 ) dabmax = max ( dabmax , abs ( den ( gdat % ao_offset ( 4 ) - 1 + ml , ao_k ))) end do do ml = 1 , gdat % nbf ( 1 ) dabmax = max ( dabmax , abs ( den ( gdat % ao_offset ( 1 ) - 1 + ml , ao_k ))) end do do ml = 1 , gdat % nbf ( 2 ) dabmax = max ( dabmax , abs ( den ( gdat % ao_offset ( 2 ) - 1 + ml , ao_k ))) end do end do do mk = 1 , gdat % nbf ( 4 ) ao_l = gdat % ao_offset ( 4 ) - 1 + mk do ml = 1 , gdat % nbf ( 1 ) dabmax = max ( dabmax , abs ( den ( gdat % ao_offset ( 1 ) - 1 + ml , ao_l ))) end do do ml = 1 , gdat % nbf ( 2 ) dabmax = max ( dabmax , abs ( den ( gdat % ao_offset ( 2 ) - 1 + ml , ao_l ))) end do end do if ( dabmax * gmax < 5.0d-11 ) return id1 = maxval ( gdat % id ( 1 : 2 )) id2 = minval ( gdat % id ( 1 : 2 )) npp_p = ppairs % ppid ( 1 , id1 * ( id1 - 1 ) / 2 + id2 ) ppid_p = ppairs % ppid ( 2 , id1 * ( id1 - 1 ) / 2 + id2 ) id1 = maxval ( gdat % id ( 3 : 4 )) id2 = minval ( gdat % id ( 3 : 4 )) npp_q = ppairs % ppid ( 1 , id1 * ( id1 - 1 ) / 2 + id2 ) ppid_q = ppairs % ppid ( 2 , id1 * ( id1 - 1 ) / 2 + id2 ) if ( npp_p * npp_q == 0 ) return nimax = gdat % am ( 1 ) + gdat % nder + 1 njmax = gdat % am ( 2 ) + gdat % nder + 1 nkmax = gdat % am ( 3 ) + 1 ! no derivative on KL nlmax = gdat % am ( 4 ) + 1 ! no derivative on KL nmax = gdat % am ( 1 ) + gdat % am ( 2 ) + 1 + gdat % nder mmax = gdat % am ( 3 ) + gdat % am ( 4 ) + 1 ! no extra for KL maxgg = MAXCONTR / gdat % nroots ng = 0 do klg = 1 , npp_q db = ppairs % k ( ppid_q - 1 + klg ) * ppairs % ginv ( ppid_q - 1 + klg ) bb = ppairs % g ( ppid_q - 1 + klg ) q = ppairs % P (:, ppid_q - 1 + klg ) do ijg = 1 , npp_p da = ppairs % k ( ppid_p - 1 + ijg ) * ppairs % ginv ( ppid_p - 1 + ijg ) aa = ppairs % g ( ppid_p - 1 + ijg ) p = ppairs % P (:, ppid_p - 1 + ijg ) ab = aa + bb pfac = da * db test = pfac * pfac if ( test < gdat % dtol * ab ) cycle if ( test * dabmax * dabmax < gdat % dabcut * ab ) cycle aandb1 = 1.0_dp / ab rho = aa * bb * aandb1 ng = ng + 1 gdat % abv ( 1 , ng ) = ppairs % ginv ( ppid_p - 1 + ijg ) gdat % abv ( 2 , ng ) = ppairs % ginv ( ppid_q - 1 + klg ) gdat % abv ( 3 , ng ) = rho gdat % abv ( 4 , ng ) = pfac * sqrt ( aandb1 ) gdat % abv ( 5 , ng ) = aandb1 gdat % abv ( 6 , ng ) = rho * sum (( p - q ) ** 2 ) gdat % ai ( ng ) = 2 * ppairs % alpha_a ( ppid_p - 1 + ijg ) gdat % aj ( ng ) = 2 * ppairs % alpha_b ( ppid_p - 1 + ijg ) gdat % ak ( ng ) = 2 * ppairs % alpha_a ( ppid_q - 1 + klg ) gdat % al ( ng ) = 2 * ppairs % alpha_b ( ppid_q - 1 + klg ) gdat % PQ (:, ng ) = p - q if ( nmax > 1 ) gdat % PB (:, ng ) = ppairs % PB (:, ppid_p - 1 + ijg ) if ( mmax > 1 ) gdat % QD (:, ng ) = ppairs % PB (:, ppid_q - 1 + klg ) gdat % dij (:, ng ) = ppairs % PA (:, ppid_p - 1 + ijg ) - ppairs % PB (:, ppid_p - 1 + ijg ) gdat % dkl (:, ng ) = ppairs % PA (:, ppid_q - 1 + klg ) - ppairs % PB (:, ppid_q - 1 + klg ) last = klg == npp_q . and . ijg == npp_p if ( ng == maxgg . or . last ) then if ( ng == 0 ) return call compute_soc2e_ints ( gdat , den , wao , & ng , nmax , mmax , nimax , njmax , nkmax , nlmax ) ng = 0 end if end do end do end subroutine soc2e_rys_compute !> @brief Evaluate 2e SOC integrals for one primitive batch after Rys setup !> @details !>  Called from soc2e_rys_compute after Rys roots/weights and recursion !>  coefficients are ready in gdat. Evaluates the base integrals [p0|q0] !>  via compute_xyz_p0q0, then calls compute_soc2e_xyz (derivative recurrence) !>  and compute_soc2e_ao (density contraction and accumulation into wao). !> !> @param[inout] gdat              SOC integral data structure !> @param[in]    den               ROHF density matrix (nbf x nbf) !> @param[inout] wao               2e SOC AO matrix (3 x nbf x nbf) !> @param[in]    ng                Number of primitive pairs in this batch !> @param[in]    nmax, mmax        Maximum angular momentum orders for the recursion !> @param[in]    nimax..nlmax      Per-shell Cartesian dimension bounds subroutine compute_soc2e_ints ( gdat , den , wao , & ng , nmax , mmax , nimax , njmax , nkmax , nlmax ) type ( soc2e_int_data_t ), intent ( inout ) :: gdat real ( kind = dp ), intent ( in ) :: den (:,:) real ( kind = dp ), intent ( inout ) :: wao (:,:,:) integer , intent ( in ) :: ng , nmax , mmax integer , intent ( in ) :: nimax , njmax , nkmax , nlmax !   Compute roots and weights for quadrature call soc2e_compute_rys_rw ( gdat , gdat % rw , ng ) !   Compute coefficients for recursion formulae call compute_coefficients ( gdat % b00 , gdat % b01 , gdat % b10 , & gdat % c00 , gdat % d00 , gdat % f00 , & gdat % abv , gdat % pq , gdat % pb , gdat % qd , gdat % rw , nmax , mmax , ng , gdat % nroots ) !   Compute x, y, z integrals (2 centers) call compute_xyz_p0q0 ( gdat % gnm , ng * gdat % nroots , nmax , mmax , & gdat % b00 , gdat % b01 , gdat % b10 , gdat % c00 , gdat % d00 , gdat % f00 ) !   Compute x, y, z integrals (4 centers) call compute_xyz_ijkl ( gdat % gijkl , gdat % gnkl , gdat % gnm , & ng , gdat % nroots , nmax , mmax , nimax , njmax , nkmax , nlmax , & gdat % dij , gdat % dkl ) !   Compute SOC derivative integrals (IJ side only) call compute_soc2e_xyz ( gdat , gdat % gijkl , & ng , gdat % nroots * 3 , nimax , njmax , nkmax , nlmax , & gdat % ai , gdat % aj , gdat % fi , gdat % fj ) call compute_soc2e_ao ( gdat , ng , gdat % nroots * 3 , gdat % ijklxyz , & gdat % gijkl , gdat % fi , gdat % fj , den , wao ) end subroutine compute_soc2e_ints !> @brief Apply derivative recurrence to build Cartesian 2e SOC integrals !> @details !>  Uses the relation d/dA phi_i(A) = i*phi_{i-1}(A) - 2*alpha*phi_{i+1}(A) !>  (identical to GAMESS XYZ2E, routines XINTI/XINTJ) to build the fi and fj !>  arrays from the base integrals g0. These are subsequently contracted in !>  compute_soc2e_ao to form the mean-field SOC AO matrix element. !> !> @param[inout] gdat             SOC integral data structure !> @param[inout] g                Base Cartesian integral array (in/out) !> @param[in]    ng, nr3          Batch size and Cartesian xyz dimension !> @param[in]    nimax..nlmax     Per-shell Cartesian dimension bounds !> @param[in]    aai, aaj         Exponents for shells i and j !> @param[out]   fi               d/dA integrals (derivative on shell i side) !> @param[out]   fj               d/dB integrals (derivative on shell j side) subroutine compute_soc2e_xyz ( gdat , g , & ng , nr3 , nimax , njmax , nkmax , nlmax , & aai , aaj , fi , fj ) implicit none type ( soc2e_int_data_t ) :: gdat integer , intent ( in ) :: ng , nr3 , nimax , njmax , nkmax , nlmax real ( kind = dp ) :: g ( ng , nr3 , nlmax , nkmax , njmax , * ) real ( kind = dp ) :: aai ( * ), aaj ( * ) real ( kind = dp ) :: fi ( ng , nr3 , nlmax , nkmax , njmax , * ) real ( kind = dp ) :: fj ( ng , nr3 , nlmax , nkmax , njmax , * ) integer :: i , j , n integer :: ni , nj ni = gdat % am ( 1 ) + 1 nj = gdat % am ( 2 ) + 1 !   FI: derivative over I index (electron 1, shell i) do n = 1 , ng fi ( n ,:,:,:,:, 1 ) = - g ( n ,:,:,:,:, 2 ) * aai ( n ) end do if ( ni /= 1 ) then do i = 2 , ni do n = 1 , ng fi ( n ,:,:,:,:, i ) = g ( n ,:,:,:,:, i - 1 ) * ( i - 1 ) & - g ( n ,:,:,:,:, i + 1 ) * aai ( n ) end do end do end if !   FJ: derivative over J index (electron 1, shell j) do i = 1 , nimax do n = 1 , ng fj ( n ,:,:,:, 1 , i ) = - g ( n ,:,:,:, 2 , i ) * aaj ( n ) end do end do if ( nj /= 1 ) then do i = 1 , nimax do j = 2 , nj do n = 1 , ng fj ( n ,:,:,:, j , i ) = g ( n ,:,:,:, j - 1 , i ) * ( j - 1 ) & - g ( n ,:,:,:, j + 1 , i ) * aaj ( n ) end do end do end do end if end subroutine compute_soc2e_xyz !  subroutine compute_soc2e_ao(gdat, ngnr, ijklxyz, g0, fi, fj, den, wao) !> @brief Contract 2e SOC integrals with the density matrix and accumulate into wao !> @details !>  Implements the mean-field contraction of the two-electron SOC integrals: !>    W_x(mu,nu) += sum_{lambda,sigma} P(lambda,sigma) * [d_y phi_mu  | r&#94;{-1} | d_z phi_sigma] * D(nu,lambda) !>                                                      - [d_z phi_mu  | r&#94;{-1} | d_y phi_sigma] * D(nu,lambda) !>  (and cyclic permutations for Wy, Wz). The derivative integrals fi (on shell i) !>  and fj (on shell j) are provided by compute_soc2e_xyz. The routine exploits !>  8-fold permutation symmetry (IJ <-> JI, KL <-> LK, IJ <-> KL) to reduce cost. !> !> @param[inout] gdat    SOC integral data structure (shell quartet metadata) !> @param[in]    ng      Number of primitive pairs in this batch !> @param[in]    nr3     xyz dimension of the integral arrays (3 for x,y,z) !> @param[in]    ijklxyz Cartesian index table from soc2e_prepare_xyz_ids !> @param[in]    g0      Base (unshifted) Cartesian integrals !> @param[in]    fi      Derivative integrals d/dA on shell i !> @param[in]    fj      Derivative integrals d/dB on shell j !> @param[in]    den     ROHF density matrix (nbf x nbf) !> @param[inout] wao     2e SOC AO matrix (3 x nbf x nbf); Lx,Ly,Lz accumulated subroutine compute_soc2e_ao ( gdat , ng , nr3 , ijklxyz , g0 , fi , fj , den , wao ) implicit none integer , intent ( in ) :: ng , nr3 real ( kind = dp ), intent ( in ) :: g0 ( ng , nr3 , * ) real ( kind = dp ), intent ( in ) :: fi ( ng , nr3 , * ) real ( kind = dp ), intent ( in ) :: fj ( ng , nr3 , * ) type ( soc2e_int_data_t ), intent ( inout ) :: gdat integer , intent ( in ) :: ijklxyz (:,:,:) real ( kind = dp ), intent ( in ) :: den (:,:) real ( kind = dp ), intent ( inout ) :: wao (:,:,:) integer :: r , rx , ry , rz integer :: i , j , k , l integer :: nx , ny , nz integer :: ao_I , ao_J , ao_K , ao_L integer :: pi , pj , pk , pl integer :: jmax real ( kind = dp ) :: sol ( 3 ), val2 , val3 , val4 logical :: same_KL , same_IJ ao_I = gdat % ao_offset ( 1 ) - 1 ao_J = gdat % ao_offset ( 2 ) - 1 ao_K = gdat % ao_offset ( 3 ) - 1 ao_L = gdat % ao_offset ( 4 ) - 1 !   Check if KL shells are the same — determines if off-diagonal KL factor applies same_KL = ( gdat % id ( 3 ) == gdat % id ( 4 )) same_IJ = ( gdat % id ( 1 ) == gdat % id ( 2 )) do i = 1 , gdat % nbf ( 1 ) pi = ao_I + i if ( same_IJ ) then jmax = i - 1 else jmax = gdat % nbf ( 2 ) end if do j = 1 , jmax !gdat%nbf(2) pj = ao_J + j do k = 1 , gdat % nbf ( 3 ) pk = ao_K + k do l = 1 , gdat % nbf ( 4 ) pl = ao_L + l nx = ijklxyz ( 1 , i , 1 ) + ijklxyz ( 1 , j , 2 ) + ijklxyz ( 1 , k , 3 ) + ijklxyz ( 1 , l , 4 ) !+ 1 ny = ijklxyz ( 2 , i , 1 ) + ijklxyz ( 2 , j , 2 ) + ijklxyz ( 2 , k , 3 ) + ijklxyz ( 2 , l , 4 ) !+ 1 nz = ijklxyz ( 3 , i , 1 ) + ijklxyz ( 3 , j , 2 ) + ijklxyz ( 3 , k , 3 ) + ijklxyz ( 3 , l , 4 ) !+ 1 sol = 0.0_dp do r = 1 , nr3 / 3 rx = r ry = nr3 / 3 + r rz = 2 * ( nr3 / 3 ) + r sol ( 1 ) = sol ( 1 ) + sum (( fi (:, ry , ny ) * fj (:, rz , nz ) - fj (:, ry , ny ) * fi (:, rz , nz )) * g0 (:, rx , nx )) sol ( 2 ) = sol ( 2 ) + sum (( fi (:, rz , nz ) * fj (:, rx , nx ) - fj (:, rz , nz ) * fi (:, rx , nx )) * g0 (:, ry , ny )) sol ( 3 ) = sol ( 3 ) + sum (( fi (:, rx , nx ) * fj (:, ry , ny ) - fj (:, rx , nx ) * fi (:, ry , ny )) * g0 (:, rz , nz )) end do sol = - sol !           ---- Coulomb 21 ---- !           W(I,J) += 2*(1+delta_KL)*D(K,L)*VAL !           W(J,I) -= 2*(1+delta_KL)*D(K,L)*VAL val2 = den ( pk , pl ) * 2.0_dp if (. not . same_KL ) val2 = val2 * 2.0_dp wao (:, pi , pj ) = wao (:, pi , pj ) + val2 * sol wao (:, pj , pi ) = wao (:, pj , pi ) - val2 * sol !           ---- Exchange 12 ---- !           W(K,J) += -3*D(I,L)*VAL !           W(K,I) -= -3*D(J,L)*VAL val3 = - 3.0_dp wao (:, pk , pj ) = wao (:, pk , pj ) + val3 * den ( pi , pl ) * sol wao (:, pk , pi ) = wao (:, pk , pi ) - val3 * den ( pj , pl ) * sol if (. not . same_KL ) then !             W(L,J) += -3*D(I,K)*VAL !             W(L,I) -= -3*D(J,K)*VAL wao (:, pl , pj ) = wao (:, pl , pj ) + val3 * den ( pi , pk ) * sol wao (:, pl , pi ) = wao (:, pl , pi ) - val3 * den ( pj , pk ) * sol end if !           ---- Exchange 21 ---- !           W(I,L) += -3*D(K,J)*VAL !           W(J,L) -= -3*D(K,I)*VAL val4 = - 3.0_dp wao (:, pi , pl ) = wao (:, pi , pl ) + val4 * den ( pk , pj ) * sol wao (:, pj , pl ) = wao (:, pj , pl ) - val4 * den ( pk , pi ) * sol if (. not . same_KL ) then !             W(I,K) += -3*D(L,J)*VAL !             W(J,K) -= -3*D(L,I)*VAL wao (:, pi , pk ) = wao (:, pi , pk ) + val4 * den ( pl , pj ) * sol wao (:, pj , pk ) = wao (:, pj , pk ) - val4 * den ( pl , pi ) * sol end if end do end do end do end do end subroutine compute_soc2e_ao !> @brief Top-level driver for the 2e mean-field SOC correction !> @details !>  Computes the mean-field two-electron spin-orbit coupling matrix in the AO basis: !>    W_x(mu,nu) = sum_{lambda,sigma} P(lambda,sigma) * !>                 [<d_y phi_mu | r&#94;{-1} | d_z phi_sigma> - <d_z phi_mu | r&#94;{-1} | d_y phi_sigma>] !>  (and cyclic permutations for Wy, Wz). The result is stored in wao(3, nbf, nbf). !> !>  Procedure: !>    1. Build shell-pair list with Schwarz prescreening (cutoff = 1e-10) !>    2. Compute Schwarz estimates for screening !>    3. Loop over shell quartet (ij, kl); for each quartet call soc2e_rys_compute !> !>  The physical identity used is: !>    <mu | Z * L_x / r&#94;3 | nu>  =  <d_y mu | 1/r | d_z nu> - <d_z mu | 1/r | d_y nu> !> !> @param[inout] infos  OQP information struct (basis, atoms, MPI info) !> @param[in]    basis  Basis set descriptor !> @param[in]    den    ROHF density matrix (nbf x nbf) !> @param[inout] wao    Output: 2e SOC AO matrix (3 x nbf x nbf), zero-initialised by caller subroutine soc2e_driver ( infos , basis , den , wao ) use types , only : information use int2_pairs , only : int2_pair_storage , int2_cutoffs_t use int2_compute , only : ints_exchange use parallel , only : par_env_t use constants , only : tol_int implicit none type ( information ), target , intent ( inout ) :: infos type ( basis_set ), intent ( in ) :: basis real ( kind = dp ), intent ( in ) :: den (:,:) real ( kind = dp ), intent ( inout ) :: wao (:,:,:) type ( soc2e_int_data_t ) :: gdat type ( int2_pair_storage ) :: ppairs type ( int2_cutoffs_t ) :: cutoffs type ( par_env_t ) :: pe real ( kind = dp ), allocatable :: schwarz_ints (:,:) real ( kind = dp ), allocatable :: den_phys (:,:) real ( kind = dp ) :: cutoff , dabcut , gmax real ( kind = dp ) :: dtol , rtol , zbig integer :: i , j , k , l , ij , kl , iok , mpi_ij integer iao , jao call pe % init ( infos % mpiinfo % comm , infos % mpiinfo % usempi ) cutoff = 1.0d-10 zbig = maxval ( basis % ex ) dabcut = 1.0d-11 if ( zbig > 1.0d+06 ) dabcut = dabcut / 10 if ( zbig > 1.0d+07 ) dabcut = dabcut / 10 dtol = 1 0.0d0 ** ( - tol_int ) rtol = log ( 1 0.0_dp ) * tol_int call cutoffs % set (& cutoff_integral_value = dabcut , & cutoff_exp = rtol , & cutoff_prefactor_pq = dtol , & cutoff_prefactor_p = dtol ) call ppairs % alloc ( basis , cutoffs ) call ppairs % compute ( basis , cutoffs ) allocate ( schwarz_ints ( basis % nshell , basis % nshell )) call ints_exchange ( basis , schwarz_ints ) dtol = dtol * dtol allocate ( den_phys ( basis % nbf , basis % nbf )) do jao = 1 , basis % nbf do iao = 1 , basis % nbf den_phys ( iao , jao ) = den ( iao , jao ) * basis % bfnrm ( iao ) * basis % bfnrm ( jao ) end do end do !$omp parallel & !$omp   firstprivate(gdat) & !$omp   private(i, j, k, l, ij, kl, gmax, iok, mpi_ij) & !$omp   reduction(+:wao) call gdat % init ( basis % mxam , dtol , dabcut , iok ) !$omp barrier if ( infos % mpiinfo % usempi ) mpi_ij = 0 do i = 1 , basis % nshell do j = 1 , i ij = i * ( i - 1 ) / 2 + j if ( ppairs % ppid ( 1 , ij ) == 0 ) cycle if ( infos % mpiinfo % usempi ) then mpi_ij = mpi_ij + 1 if ( mod ( mpi_ij , pe % size ) /= pe % rank ) cycle end if !$omp do schedule(dynamic) do k = 1 , basis % nshell do l = 1 , k kl = k * ( k - 1 ) / 2 + l if ( ppairs % ppid ( 1 , kl ) == 0 ) cycle gmax = schwarz_ints ( i , j ) * schwarz_ints ( k , l ) if ( gmax < cutoff ) cycle call gdat % set_ids ( basis , i , j , k , l ) call soc2e_rys_compute ( gdat , ppairs , gmax , den_phys , wao ) end do end do !$omp end do end do end do call gdat % clean () !$omp end parallel call pe % allreduce ( wao , size ( wao )) do jao = 1 , basis % nbf do iao = 1 , basis % nbf wao (:, iao , jao ) = wao (:, iao , jao ) * basis % bfnrm ( iao ) * basis % bfnrm ( jao ) end do end do call ppairs % clean () deallocate ( schwarz_ints ) deallocate ( den_phys ) end subroutine soc2e_driver end module grd2_rys","tags":"","url":"sourcefile/grd2_rys.f90.html"},{"title":"hf_hessian.F90 – OpenQP Fortran API","text":"Source Code module hf_hessian_mod implicit none character ( len =* ), parameter :: module_name = \"hf_hessian_mod\" contains !############################################################################### subroutine hf_hessian_C ( c_handle ) bind ( C , name = \"hf_hessian\" ) use c_interop , only : oqp_handle_t , oqp_handle_get_info use types , only : information type ( oqp_handle_t ) :: c_handle type ( information ), pointer :: inf inf => oqp_handle_get_info ( c_handle ) call hf_hessian ( inf ) end subroutine hf_hessian_C !############################################################################### subroutine hf_hessian ( infos ) ! Native OpenQP HF/DFT Hessian CPHF response prepass. ! ! This routine deliberately exercises the production Fortran CPHF/CPKS PCG ! solver for every Cartesian nuclear perturbation used by a ground-state ! analytic Hessian.  It builds the closed-shell occupied-virtual RHS from ! OpenQP derivative integrals and the current OpenQP SCF density/MOs, then ! calls cphf_solve on the full 3N RHS block and stores the native Hessian ! matrix in OQP::hf_hessian for the Python frequency driver. use precision , only : dp use types , only : information use basis_tools , only : basis_set use oqp_tagarray_driver , only : tagarray_get_data , OQP_DM_A , OQP_VEC_MO_A , OQP_E_MO_A , & OQP_hf_hessian , TA_TYPE_REAL64 use mathlib , only : unpack_matrix , pack_matrix use grd1 , only : der_overlap_matrix , der_kinetic_matrix , der_nucattr_matrix , hess_nn use fock_deriv_mod , only : fock_deriv_contract use scf_addons , only : fock_jk use cphf_mod , only : cphf_solve use io_constants , only : iw use messages , only : show_message , WITH_ABORT implicit none type ( information ), target , intent ( inout ) :: infos type ( basis_set ), pointer :: basis real ( kind = dp ), contiguous , pointer :: dmat_a (:), mo_a (:,:), eps (:) real ( kind = dp ), allocatable :: pfull (:,:), probe (:,:), gx (:,:) real ( kind = dp ), allocatable :: dSa (:,:,:,:), dTa (:,:,:,:), dVa (:,:,:,:) real ( kind = dp ), allocatable :: Sx (:,:), hx (:,:), F0x (:,:), Gd0 (:,:) real ( kind = dp ), allocatable :: d0 (:,:), d0p (:,:), gp (:,:), gfull (:,:) real ( kind = dp ), allocatable :: bvec (:,:), uvec (:,:), scr (:,:), col (:,:), hess_native (:,:) real ( kind = dp ), contiguous , pointer :: hess_store (:,:) real ( kind = dp ) :: hfscale integer :: nbf , nbf2 , nocc , nvir , natom , ncart integer :: i , j , a , mu , nu , ia , icart , kc , cc ! Unsupported-feature guards (apply to ALL references, RHF/RKS included). ! Effective-core-potential (ECP) second derivatives ARE supported: RHF/UHF ! contract the ECP skeleton d&#94;2 V_ECP/dR&#94;2 analytically (add_ecphess, libecpint ! deriv order 2) plus the ECP core-derivative in the CPHF response; ROHF folds ! the ECP gradient (add_ecpder) into its semi-numerical resp_grad. ! Range-separated (CAM/LC) functionals are also supported: the 2e derivative ! integrals are erfc-attenuation capable, so grd2_hess_driver (skeleton), ! grd2_driver (fock_deriv_contract response) and fock_jk (cphf) all run the ! long-range Coulomb + short-range erfc-exchange two-pass split when ! infos%dft%cam_flag is set. ! Open-shell (UHF/ROHF) dispatch.  The body below is the closed-shell ! (RHF/RKS) kernel: it reads only the alpha density/MOs (OQP_DM_A, mo_a, eps) ! and treats nocc as doubly occupied, so it must never run on an open-shell ! SCF.  UHF (scftype==2) -> hf_hessian_uhf, ROHF (scftype==3) -> hf_hessian_rohf ! (both HF and DFT, finite-difference validated). if ( infos % control % scftype == 2 ) then call hf_hessian_uhf ( infos ) return else if ( infos % control % scftype == 3 ) then call hf_hessian_rohf ( infos ) return else if ( infos % control % scftype > 3 ) then call show_message ( 'Native analytic Hessian supports RHF/RKS, UHF (HF) ' // & 'and ROHF (HF) references only for this scftype. Use [hess] ' // & 'type=numerical.' , WITH_ABORT ) end if basis => infos % basis basis % atoms => infos % atoms nbf = basis % nbf nbf2 = nbf * ( nbf + 1 ) / 2 nocc = infos % mol_prop % nocc nvir = nbf - nocc natom = size ( basis % atoms % xyz , 2 ) ncart = 3 * natom hfscale = 1.0_dp if ( infos % control % hamilton >= 20 ) hfscale = infos % dft % hfscale open ( unit = iw , file = infos % log_filename , position = \"append\" ) write ( iw , '(/,A)' ) 'PyOQP: Native OpenQP HF/DFT Hessian CPHF response prepass' write ( iw , '(A,I6,A,I6,A,I6,A,I6)' ) '  nbf=' , nbf , ' nocc=' , nocc , ' nvir=' , nvir , ' rhs=' , ncart write ( iw , '(A)' ) '  Storing native OpenQP HF/DFT analytic Hessian matrix in OQP::hf_hessian.' if ( nocc <= 0 . or . nvir <= 0 . or . ncart <= 0 ) then write ( iw , '(A)' ) '  Native CPHF prepass skipped: empty occupied/virtual/nuclear space.' close ( iw ) return end if call tagarray_get_data ( infos % dat , OQP_DM_A , dmat_a ) call tagarray_get_data ( infos % dat , OQP_VEC_MO_A , mo_a ) call tagarray_get_data ( infos % dat , OQP_E_MO_A , eps ) allocate ( pfull ( nbf , nbf )); call unpack_matrix ( dmat_a , pfull ) allocate ( dSa ( nbf , nbf , 3 , natom ), dTa ( nbf , nbf , 3 , natom ), dVa ( nbf , nbf , 3 , natom )) call der_overlap_matrix ( basis , dSa ) call der_kinetic_matrix ( basis , dTa ) call der_nucattr_matrix ( basis , basis % atoms % xyz , & basis % atoms % zn - basis % ecp_zn_num , dVa ) ! ECP-screened point charge ! der_* matrices are returned in the UNNORMALIZED basis; bring them into the ! same normalized (bfnrm) convention as the MO coefficients / density so the ! CPHF RHS and the response contractions are correct for d/f functions ! (bfnrm /= 1). Invisible for s/p-only bases (e.g. STO-3G). block integer :: kc2 , cc2 , mu2 , nu2 do kc2 = 1 , natom do cc2 = 1 , 3 do nu2 = 1 , nbf do mu2 = 1 , nbf dSa ( mu2 , nu2 , cc2 , kc2 ) = dSa ( mu2 , nu2 , cc2 , kc2 ) * basis % bfnrm ( mu2 ) * basis % bfnrm ( nu2 ) dTa ( mu2 , nu2 , cc2 , kc2 ) = dTa ( mu2 , nu2 , cc2 , kc2 ) * basis % bfnrm ( mu2 ) * basis % bfnrm ( nu2 ) dVa ( mu2 , nu2 , cc2 , kc2 ) = dVa ( mu2 , nu2 , cc2 , kc2 ) * basis % bfnrm ( mu2 ) * basis % bfnrm ( nu2 ) end do end do end do end do end block ! ECP first-derivative integrals enter the core-Hamiltonian derivative ! dHcore/dR (added into dVa, the nuclear-attraction derivative tensor), so the ! ECP contributes to the CPHF right-hand side and the orbital-relaxation ! response exactly as point-charge nuclear attraction does.  libecpint returns ! these already in the OpenQP normalized convention, hence added AFTER the ! bfnrm scaling above.  No-op for non-ECP bases. block use ecp_tool , only : ecp_deriv_ints real ( kind = dp ), allocatable :: dVecp (:,:,:,:) allocate ( dVecp ( nbf , nbf , 3 , natom )) call ecp_deriv_ints ( basis , basis % atoms % xyz , dVecp ) dVa = dVa + dVecp deallocate ( dVecp ) end block allocate ( scr ( nbf , nbf ), col ( nbf , nbf )) allocate ( Sx ( nbf , nbf ), hx ( nbf , nbf ), F0x ( nbf , nbf ), Gd0 ( nbf , nbf )) allocate ( probe ( nbf , nbf ), gx ( 3 , natom )) allocate ( d0 ( nbf , nbf ), d0p ( nbf2 , 1 ), gp ( nbf2 , 1 ), gfull ( nbf , nbf )) allocate ( bvec ( nocc * nvir , ncart ), uvec ( nocc * nvir , ncart ), source = 0.0_dp ) icart = 0 do kc = 1 , natom do cc = 1 , 3 icart = icart + 1 call mo_transform ( mo_a , dSa (:,:, cc , kc ), nbf , scr , col , Sx ) scr = dTa (:,:, cc , kc ) + dVa (:,:, cc , kc ) call mo_transform ( mo_a , scr , nbf , col , F0x , hx ) F0x = hx do a = 1 , nvir do i = 1 , nocc do mu = 1 , nbf do nu = 1 , nbf probe ( mu , nu ) = 0.5_dp * ( mo_a ( mu , nocc + a ) * mo_a ( nu , i ) + mo_a ( mu , i ) * mo_a ( nu , nocc + a ) ) end do end do call fock_deriv_contract ( infos , basis , pfull , probe , hfscale , gx ) F0x ( i , nocc + a ) = hx ( i , nocc + a ) + 2.0_dp * gx ( cc , kc ) end do end do ! --- XC contribution to the CPKS right-hand side (DFT only) ------------- ! The A-matrix (cphf_apbx) includes the XC kernel fxc, so the perturbation ! RHS must carry BOTH XC pieces or the relaxed response dPx is wrong (the ! HF response, ~2x too large for DFT): !   (i)  skeleton  dVxc/dR  (fixed orbitals, basis+grid move)  -> in F0x !   (ii) fxc[d0], d0 = reorthonormalization density            -> in Gd0 ! Both enter B_ai with the SAME (minus) sign as the other Fock terms, so ! they are captured together by ONE central FD of the XC Fock matrix ! (dftexcor) along the combined path: geometry R +/- h AND occupied MOs ! reorthonormalized by dmo_i = -1/2 sum_j C_j S&#94;x_ji.  dftexcor handles all ! density/spin scale factors internally, so no manual convention factors. if ( infos % control % hamilton == 20 ) then block use dft , only : dft_initialize , dftclean , dftexcor use mod_dft_molgrid , only : dft_grid_t type ( dft_grid_t ) :: mgr real ( dp ), allocatable :: dmoR (:,:), mop (:,:), frp (:), frm (:), dVxcR (:,:), hxcR (:,:) real ( dp ) :: hxr , telr , tknr , exr integer :: ir , jr allocate ( dmoR ( nbf , nocc ), mop ( nbf , nbf ), frp ( nbf2 ), frm ( nbf2 ), dVxcR ( nbf , nbf ), hxcR ( nbf , nbf )) hxr = 1.0d-3 dmoR = 0.0_dp do ir = 1 , nocc do jr = 1 , nocc dmoR (:, ir ) = dmoR (:, ir ) - 0.5_dp * mo_a (:, jr ) * Sx ( jr , ir ) end do end do basis % atoms % xyz ( cc , kc ) = basis % atoms % xyz ( cc , kc ) + hxr call basis % init_shell_centers () call dft_initialize ( infos , basis , mgr ) mop = mo_a ; mop (:, 1 : nocc ) = mo_a (:, 1 : nocc ) + hxr * dmoR frp = 0.0_dp call dftexcor ( basis , mgr , 1 , frp , frp , mop , mop , nbf , nbf2 , exr , telr , tknr , infos ) call dftclean ( infos ) basis % atoms % xyz ( cc , kc ) = basis % atoms % xyz ( cc , kc ) - 2 * hxr call basis % init_shell_centers () call dft_initialize ( infos , basis , mgr ) mop = mo_a ; mop (:, 1 : nocc ) = mo_a (:, 1 : nocc ) - hxr * dmoR frm = 0.0_dp call dftexcor ( basis , mgr , 1 , frm , frm , mop , mop , nbf , nbf2 , exr , telr , tknr , infos ) call dftclean ( infos ) basis % atoms % xyz ( cc , kc ) = basis % atoms % xyz ( cc , kc ) + hxr call basis % init_shell_centers () call unpack_from_packed (( frp - frm ) / ( 2 * hxr ), dVxcR , nbf ) call mo_transform ( mo_a , dVxcR , nbf , scr , col , hxcR ) do a = 1 , nvir do i = 1 , nocc F0x ( i , nocc + a ) = F0x ( i , nocc + a ) + hxcR ( i , nocc + a ) end do end do deallocate ( dmoR , mop , frp , frm , dVxcR , hxcR ) end block end if d0 = 0.0_dp do i = 1 , nocc do j = 1 , nocc do mu = 1 , nbf do nu = 1 , nbf d0 ( mu , nu ) = d0 ( mu , nu ) - 2.0_dp * Sx ( i , j ) * mo_a ( mu , i ) * mo_a ( nu , j ) end do end do end do end do call pack_matrix ( d0 , d0p (:, 1 )) gp = 0.0_dp call fock_jk ( basis , d = d0p , f = gp , scale_exch = hfscale , infos = infos ) call unpack_from_packed ( gp (:, 1 ), gfull , nbf ) call mo_transform ( mo_a , gfull , nbf , scr , col , Gd0 ) ia = 0 do a = 1 , nvir do i = 1 , nocc ia = ia + 1 bvec ( ia , icart ) = - F0x ( i , nocc + a ) + eps ( i ) * Sx ( i , nocc + a ) - Gd0 ( i , nocc + a ) end do end do end do end do call cphf_solve ( infos , ncart , bvec , uvec ) ! ===== CPHF orbital-relaxation response ===== ! H&#94;resp_xy = 4 Tr[F&#94;x dm1&#94;y] - 4 Tr[S&#94;x (eps.dm1&#94;y)] - 2 Tr[s1oo&#94;x mo_e1&#94;y] !   dm1&#94;y_pq      = sum_k dC&#94;y_pk C_qk                       (one-sided) !   mo_e1&#94;y_kl    = (h&#94;y + G[P]&#94;y + G[dP&#94;y])&#94;MO_kl - 1/2 (eps_k+eps_l) s1oo&#94;y_kl ! F&#94;x = h&#94;x + G[P]&#94;x; dC&#94;y from the validated CPHF amplitudes U&#94;y. The first ! two terms equal Tr[dP&#94;y F&#94;x] and the eps-weighted overlap term; the third ! is the FULL occ-occ energy-weighted term (the off-diagonal part is what a ! diagonal dε approximation misses). 2e traces use fock_deriv_contract ! (=1/2 Tr[M G[P]&#94;x]) and fock_jk (G[dP&#94;y]). allocate ( hess_native ( ncart , ncart ), source = 0.0_dp ) block real ( dp ), allocatable :: sflat (:,:,:), hflat (:,:,:) real ( dp ), allocatable :: dCx (:,:,:), dPx (:,:,:), Gdp (:,:,:) real ( dp ), allocatable :: s1oo (:,:,:), hMOoo (:,:,:), GdpMOoo (:,:,:), moe1a (:,:,:) real ( dp ), allocatable :: Mi (:,:), gxy (:,:), A2 (:,:), tGP (:,:), hresp (:,:) real ( dp ), allocatable :: s1 (:,:), s2 (:,:), bMO (:,:), dpp (:,:), gpp (:,:), gfl (:,:) real ( dp ), allocatable :: cocc (:,:), tmpno (:,:) real ( dp ) :: a1v , a3v , t3a , dcsx integer :: x , yy , ii , jj , kk , ll , aa , ia2 , mu2 , nu2 , ccx , kcx allocate ( sflat ( nbf , nbf , ncart ), hflat ( nbf , nbf , ncart )) do x = 1 , ncart ccx = mod ( x - 1 , 3 ) + 1 ; kcx = ( x - 1 ) / 3 + 1 sflat (:,:, x ) = dSa (:,:, ccx , kcx ) hflat (:,:, x ) = dTa (:,:, ccx , kcx ) + dVa (:,:, ccx , kcx ) end do allocate ( cocc ( nbf , nocc )); cocc = mo_a (:, 1 : nocc ) ! occ-occ MO blocks of S&#94;x and h&#94;x allocate ( s1oo ( nocc , nocc , ncart ), hMOoo ( nocc , nocc , ncart ), source = 0.0_dp ) allocate ( s1 ( nbf , nbf ), s2 ( nbf , nbf ), bMO ( nbf , nbf ), tmpno ( nbf , nocc )) do x = 1 , ncart call dgemm ( 'n' , 'n' , nbf , nocc , nbf , 1.0_dp , sflat (:,:, x ), nbf , cocc , nbf , 0.0_dp , tmpno , nbf ) call dgemm ( 't' , 'n' , nocc , nocc , nbf , 1.0_dp , cocc , nbf , tmpno , nbf , 0.0_dp , s1oo (:,:, x ), nocc ) call dgemm ( 'n' , 'n' , nbf , nocc , nbf , 1.0_dp , hflat (:,:, x ), nbf , cocc , nbf , 0.0_dp , tmpno , nbf ) call dgemm ( 't' , 'n' , nocc , nocc , nbf , 1.0_dp , cocc , nbf , tmpno , nbf , 0.0_dp , hMOoo (:,:, x ), nocc ) end do ! relaxed orbital derivative dC&#94;y, density dP&#94;y (total), response Fock G[dP&#94;y] allocate ( dCx ( nbf , nocc , ncart ), dPx ( nbf , nbf , ncart ), Gdp ( nbf , nbf , ncart ), source = 0.0_dp ) allocate ( GdpMOoo ( nocc , nocc , ncart ), source = 0.0_dp ) allocate ( dpp ( nbf2 , 1 ), gpp ( nbf2 , 1 ), gfl ( nbf , nbf )) do yy = 1 , ncart ia2 = 0 do aa = 1 , nvir do ii = 1 , nocc ia2 = ia2 + 1 dCx (:, ii , yy ) = dCx (:, ii , yy ) + mo_a (:, nocc + aa ) * uvec ( ia2 , yy ) end do end do do ii = 1 , nocc do jj = 1 , nocc dCx (:, ii , yy ) = dCx (:, ii , yy ) - 0.5_dp * mo_a (:, jj ) * s1oo ( jj , ii , yy ) end do end do do ii = 1 , nocc do mu2 = 1 , nbf do nu2 = 1 , nbf dPx ( mu2 , nu2 , yy ) = dPx ( mu2 , nu2 , yy ) & + 2.0_dp * ( dCx ( mu2 , ii , yy ) * mo_a ( nu2 , ii ) + mo_a ( mu2 , ii ) * dCx ( nu2 , ii , yy )) end do end do end do call pack_matrix ( dPx (:,:, yy ), dpp (:, 1 )) gpp = 0.0_dp call fock_jk ( basis , d = dpp , f = gpp , scale_exch = hfscale , infos = infos ) call unpack_from_packed ( gpp (:, 1 ), gfl , nbf ); Gdp (:,:, yy ) = gfl call dgemm ( 'n' , 'n' , nbf , nocc , nbf , 1.0_dp , gfl , nbf , cocc , nbf , 0.0_dp , tmpno , nbf ) call dgemm ( 't' , 'n' , nocc , nocc , nbf , 1.0_dp , cocc , nbf , tmpno , nbf , 0.0_dp , GdpMOoo (:,:, yy ), nocc ) end do ! mo_e1 without the G[P]&#94;y part (added via Mi trick in term3) allocate ( moe1a ( nocc , nocc , ncart )) do yy = 1 , ncart do ll = 1 , nocc do kk = 1 , nocc moe1a ( kk , ll , yy ) = hMOoo ( kk , ll , yy ) + GdpMOoo ( kk , ll , yy ) & - 0.5_dp * ( eps ( kk ) + eps ( ll )) * s1oo ( kk , ll , yy ) end do end do end do ! 2e traces: A2(x,y)=Tr[dP&#94;y G[P]&#94;x]; tGP(x,y)=Tr[M&#94;x G[P]&#94;y] ! with M&#94;x = sum_kl s1oo&#94;x_kl C_k C_l&#94;T allocate ( gxy ( 3 , natom ), A2 ( ncart , ncart ), tGP ( ncart , ncart ), Mi ( nbf , nbf ), source = 0.0_dp ) do yy = 1 , ncart gxy = 0.0_dp call fock_deriv_contract ( infos , basis , pfull , dPx (:,:, yy ), hfscale , gxy ) A2 (:, yy ) = 2.0_dp * reshape ( gxy , [ ncart ]) end do do x = 1 , ncart call dgemm ( 'n' , 'n' , nbf , nocc , nocc , 1.0_dp , cocc , nbf , s1oo (:,:, x ), nocc , 0.0_dp , tmpno , nbf ) call dgemm ( 'n' , 't' , nbf , nbf , nocc , 1.0_dp , tmpno , nbf , cocc , nbf , 0.0_dp , Mi , nbf ) gxy = 0.0_dp call fock_deriv_contract ( infos , basis , pfull , Mi , hfscale , gxy ) tGP ( x ,:) = 2.0_dp * reshape ( gxy , [ ncart ]) end do ! assemble response  hresp(x,y) = 4Tr[F&#94;x dm1&#94;y]-4Tr[S&#94;x eps.dm1&#94;y]-2Tr[s1oo&#94;x mo_e1&#94;y] !   = (Tr[dP&#94;y h&#94;x] + A2) - 4 A3 - 2 (sum_kl s1oo&#94;x_kl moe1a&#94;y_kl) - 2 tGP allocate ( hresp ( ncart , ncart ), source = 0.0_dp ) do x = 1 , ncart do yy = 1 , ncart a1v = sum ( dPx (:,:, yy ) * hflat (:,:, x )) a3v = 0.0_dp do ii = 1 , nocc dcsx = 0.0_dp do mu2 = 1 , nbf do nu2 = 1 , nbf dcsx = dcsx + dCx ( mu2 , ii , yy ) * sflat ( mu2 , nu2 , x ) * mo_a ( nu2 , ii ) end do end do a3v = a3v + eps ( ii ) * dcsx end do t3a = 0.0_dp do ll = 1 , nocc do kk = 1 , nocc t3a = t3a + s1oo ( kk , ll , x ) * moe1a ( kk , ll , yy ) end do end do hresp ( x , yy ) = ( a1v + A2 ( x , yy )) - 4.0_dp * a3v - 2.0_dp * t3a - 2.0_dp * tGP ( x , yy ) end do end do hess_native = 0.5_dp * ( hresp + transpose ( hresp )) ! --- DFT exchange-correlation second-derivative contribution ----------- ! The XC part of the Hessian is obtained by central finite differencing the ! analytic XC nuclear gradient (derexc_blk) over geometry while displacing ! the density by the analytic relaxed density derivative dP&#94;y. This adds ! both the XC skeleton (d2Exc/dR2 at fixed density) and the XC response ! (through dP&#94;y) in one shot, with no re-SCF. The HF-exchange fraction is ! already in the Coulomb/exchange terms above (hfscale); derexc_blk ! supplies the remaining DFT exchange-correlation functional. if ( infos % control % hamilton == 20 ) then block use dft , only : dft_initialize , dftclean , dftexcor use mod_dft_gridint_grad , only : derexc_blk use mod_dft_molgrid , only : dft_grid_t type ( dft_grid_t ) :: mg real ( dp ), allocatable :: dap (:,:), dedp (:,:), dedm (:,:) real ( dp ), allocatable :: mop (:,:), frp (:), frm (:), dFxc (:,:), dFoo (:,:) real ( dp ), allocatable :: tmpn (:,:), dHse (:,:), dHt3 (:,:) real ( dp ) :: hx , tele , tkin , eexc integer :: yy2 , ccy , kcy , nang , x2 , kk2 , ll2 hx = 1.0d-3 ; nang = maxval ( basis % am ) + 2 ! XC contribution split into a skeleton+density-response term and an ! energy-weighting term, realised through the OpenQP moving-grid XC ! machinery so it stays consistent with the OpenQP numerical Hessian: !   dHse : skeleton + density-response (term1).  Central FD of the analytic !          XC gradient (derexc) along the relaxed path R+lambda, P+lambda*dP. !          This is the genuine total derivative d/dR[g_XC(R,P(R))] of the !          OpenQP XC gradient, so the moving-grid weight derivatives are !          handled identically to the SCF/numerical-gradient convention. !   dHt3 : -2 Tr[s1oo&#94;x (vxc&#94;y+fxc[dP&#94;y])_oo], the XC part of the !          energy-weighted (mo_e1) term, from the FD of the XC Fock !          matrix (dftexcor) along the same relaxed orbital path. allocate ( dap ( nbf , nbf ), dedp ( 3 , natom ), dedm ( 3 , natom )) allocate ( mop ( nbf , nbf ), frp ( nbf2 ), frm ( nbf2 ), dFxc ( nbf , nbf ), dFoo ( nocc , nocc )) allocate ( tmpn ( nbf , nocc ), dHse ( ncart , ncart ), dHt3 ( ncart , ncart )) dHt3 = 0.0_dp ! warm-up to flush any stale grid state left by the CPHF solver call dft_initialize ( infos , basis , mg ); call dftclean ( infos ) do yy2 = 1 , ncart ccy = mod ( yy2 - 1 , 3 ) + 1 ; kcy = ( yy2 - 1 ) / 3 + 1 basis % atoms % xyz ( ccy , kcy ) = basis % atoms % xyz ( ccy , kcy ) + hx call basis % init_shell_centers () call dft_initialize ( infos , basis , mg ) dap = pfull + hx * dPx (:,:, yy2 ); dedp = 0.0_dp ! skeleton + density response call derexc_blk ( basis , mg , dap , dap , dedp , tele , tkin , nang , nbf , & infos % dft % grid_density_cutoff , . false ., infos ) mop = mo_a ; mop (:, 1 : nocc ) = mo_a (:, 1 : nocc ) + hx * dCx (:,:, yy2 ) call dftexcor ( basis , mg , 1 , frp , frp , mop , mop , nbf , nbf2 , eexc , tele , tkin , infos ) call dftclean ( infos ) basis % atoms % xyz ( ccy , kcy ) = basis % atoms % xyz ( ccy , kcy ) - 2 * hx call basis % init_shell_centers () call dft_initialize ( infos , basis , mg ) dap = pfull - hx * dPx (:,:, yy2 ); dedm = 0.0_dp call derexc_blk ( basis , mg , dap , dap , dedm , tele , tkin , nang , nbf , & infos % dft % grid_density_cutoff , . false ., infos ) mop = mo_a ; mop (:, 1 : nocc ) = mo_a (:, 1 : nocc ) - hx * dCx (:,:, yy2 ) call dftexcor ( basis , mg , 1 , frm , frm , mop , mop , nbf , nbf2 , eexc , tele , tkin , infos ) call dftclean ( infos ) basis % atoms % xyz ( ccy , kcy ) = basis % atoms % xyz ( ccy , kcy ) + hx call basis % init_shell_centers () dHse (:, yy2 ) = reshape (( dedp - dedm ) / ( 2 * hx ), [ ncart ]) ! term3: -2 s1oo&#94;x (vxc&#94;y + fxc[dP&#94;y])_oo call unpack_from_packed (( frp - frm ) / ( 2 * hx ), dFxc , nbf ) call dgemm ( 'n' , 'n' , nbf , nocc , nbf , 1.0_dp , dFxc , nbf , mo_a , nbf , 0.0_dp , tmpn , nbf ) call dgemm ( 't' , 'n' , nocc , nocc , nbf , 1.0_dp , mo_a , nbf , tmpn , nbf , 0.0_dp , dFoo , nocc ) do x2 = 1 , ncart do ll2 = 1 , nocc do kk2 = 1 , nocc dHt3 ( x2 , yy2 ) = dHt3 ( x2 , yy2 ) - 2.0_dp * s1oo ( kk2 , ll2 , x2 ) * dFoo ( kk2 , ll2 ) end do end do end do end do hess_native = hess_native + 0.5_dp * ( dHse + transpose ( dHse )) & + 0.5_dp * ( dHt3 + transpose ( dHt3 )) deallocate ( dap , dedp , dedm , mop , frp , frm , dFxc , dFoo , tmpn , dHse , dHt3 ) end block end if deallocate ( sflat , hflat , dCx , dPx , Gdp , s1oo , hMOoo , GdpMOoo , moe1a , & Mi , gxy , A2 , tGP , hresp , s1 , s2 , bMO , dpp , gpp , gfl , cocc , tmpno ) end block call hess_nn ( basis % atoms , basis % ecp_zn_num , hess_native ) ! --- One-electron + Pulay second-derivative skeleton (fixed density) ------ ! Mirrors the production HF gradient assembly (hf_1e_grad): the analytic ! Hessian skeleton is d/dx of [grad_ee_overlap(W) + grad_ee_kinetic(P) ! + grad_en(P)] evaluated at the fixed converged density, i.e. the ! second-derivative integral contractions hess_ee_overlap / hess_ee_kinetic ! / hess_en.  This is distinct from (and additive to) the CPHF response ! term above; the 2e ERI second-derivative skeleton is added separately. block use grd1 , only : eijden , hess_ee_overlap , hess_ee_kinetic , hess_en use ecp_tool , only : add_ecphess real ( kind = dp ), allocatable :: wlag (:), pden (:), hcc (:,:) allocate ( wlag ( nbf2 ), pden ( nbf2 ), hcc ( ncart , ncart ), source = 0.0_dp ) call eijden ( wlag , nbf , infos ) ! energy-weighted (Lagrangian) density pden = dmat_a ! total density (closed-shell RHF) call hess_ee_overlap ( basis , wlag , hess_native ) ! overlap / Pulay call hess_ee_kinetic ( basis , pden , hess_native ) ! kinetic call hess_en ( basis , basis % atoms % xyz , & basis % atoms % zn - basis % ecp_zn_num , pden , hess_native , hess_cc = hcc ) call add_ecphess ( basis , basis % atoms % xyz , pden , hess_native ) ! ECP skeleton (if any) deallocate ( wlag , pden , hcc ) end block ! --- Two-electron (ERI) second-derivative skeleton (fixed density) -------- ! d&#94;2/dR&#94;2 of the analytic 2e gradient contraction at the converged density, ! i.e. sum P P d&#94;2/dR&#94;2 [ (ij|kl) - 1/4 c_x (ik|jl) ]. Validated against a ! finite difference of grd2_driver (see grd2_hess_selftest). Additive to the ! CPHF response and 1e skeleton above. block use grd2 , only : grd2_hess_driver , grd2_compute_data_t use hf_gradient_mod , only : grd2_rhf_compute_data_t type ( grd2_rhf_compute_data_t ) :: gcomp gcomp = grd2_rhf_compute_data_t ( da = dmat_a , hfscale = hfscale , nbf = nbf ) call gcomp % init () call gcomp % build_cart ( basis ) call grd2_hess_driver ( infos , basis , hess_native , gcomp ) call gcomp % clean () end block call infos % dat % alloc_or_die ( OQP_hf_hessian , ( / ncart , ncart / ), hess_store , & description = 'Native OpenQP HF/DFT analytic Hessian matrix' ) hess_store = hess_native write ( iw , '(A)' ) 'PyOQP: Native OpenQP HF/DFT Hessian matrix stored' close ( iw ) deallocate ( pfull , dSa , dTa , dVa , scr , col , Sx , hx , F0x , Gd0 , probe , gx , & d0 , d0p , gp , gfull , bvec , uvec , hess_native ) end subroutine hf_hessian !############################################################################### subroutine hf_hessian_uhf ( infos ) ! Native open-shell (UHF) analytic HF Hessian. ! ! Mirrors the closed-shell hf_hessian response assembly per spin, summed over ! s in {alpha, beta} with single (not doubled) occupation factors.  Each spin ! uses its own MO set C&#94;s, orbital energies eps&#94;s and density P&#94;s; the ! two-electron couplings are open-shell (Coulomb from the total density ! P = Pa + Pb, exchange from the spin density P&#94;s): ! !   B&#94;s_ia   = -(h&#94;x_ia + G&#94;{s,x}[P]_ia) + eps&#94;s_i S&#94;x_ia - G&#94;s[d0]_ia , !   d0&#94;s     = -sum_ij S&#94;x,s_ij C&#94;s_i C&#94;s_j&#94;T          (reorthonormalization), !   G&#94;s[.]   = J[.&#94;a + .&#94;b] - c_x K[.&#94;s]               (scf_addons::fock_jk), !   G&#94;{s,x}[P] via fock_deriv_mod::fock_deriv_contract_os (Coulomb P, exch P&#94;s). ! ! The 3N right-hand sides are solved with cphf_mod::cphf_solve_uhf, and the ! orbital-relaxation response is assembled as (per spin, summed): ! !   H&#94;resp_xy = sum_s [ Tr[dP&#94;s,y h&#94;x] + Tr[dP&#94;s,y G&#94;{s,x}[P]] ] !             - 2 sum_s sum_i eps&#94;s_i (dC&#94;s,y_i . S&#94;x . C&#94;s_i) !             -   sum_s sum_kl s1oo&#94;s,x_kl moe1&#94;s,y_kl !             -   sum_s Tr[Mi&#94;s,x G&#94;{s,y}[P]] , ! !   moe1&#94;s,y_kl = h&#94;x_kl(MO) + G&#94;s[dP&#94;y]_kl(MO) - 1/2(eps&#94;s_k+eps&#94;s_l) s1oo&#94;s,y_kl , !   Mi&#94;s,x      = sum_kl s1oo&#94;s,x_kl C&#94;s_k C&#94;s_l&#94;T . ! ! The fixed-density skeleton (1e total density + open-shell Lagrangian W, 2e ! via grd2_uhf_compute_data_t) and the nuclear-repulsion term are added on ! top, exactly as in hess_skel_open_selftest.  HF only (the UKS f_xc response ! is not finite-difference validated). use precision , only : dp use types , only : information use basis_tools , only : basis_set use oqp_tagarray_driver , only : tagarray_get_data , OQP_DM_A , OQP_DM_B , & OQP_VEC_MO_A , OQP_VEC_MO_B , OQP_E_MO_A , OQP_E_MO_B , OQP_hf_hessian , TA_TYPE_REAL64 use mathlib , only : unpack_matrix , pack_matrix use grd1 , only : der_overlap_matrix , der_kinetic_matrix , der_nucattr_matrix , hess_nn use fock_deriv_mod , only : fock_deriv_contract_os use scf_addons , only : fock_jk use cphf_mod , only : cphf_solve_uhf use io_constants , only : iw implicit none type ( information ), target , intent ( inout ) :: infos !> Per-spin work container (alpha/beta have different nocc/nvir). type :: uhf_spin_t real ( dp ), allocatable :: mo (:,:) ! MO coefficients (nbf,nbf) real ( dp ), allocatable :: eps (:) ! orbital energies (nbf) real ( dp ), allocatable :: p (:,:) ! spin AO density (nbf,nbf) integer :: nocc = 0 , nvir = 0 , loff = 0 ! occ/vir count, CPHF block offset real ( dp ), allocatable :: s1oo (:,:,:) ! occ-occ MO of S&#94;x (nocc,nocc,ncart) real ( dp ), allocatable :: hoo (:,:,:) ! occ-occ MO of h&#94;x real ( dp ), allocatable :: g2e (:,:) ! G&#94;{s,x}[P]_ia for all coords (nocc*nvir,ncart) real ( dp ), allocatable :: dCx (:,:,:) ! relaxed dC (nbf,nocc,ncart) real ( dp ), allocatable :: dPx (:,:,:) ! relaxed spin density derivative real ( dp ), allocatable :: gdpoo (:,:,:) ! occ-occ MO of G&#94;s[dP&#94;y] real ( dp ), allocatable :: moe1 (:,:,:) ! occ-occ energy-weighted derivative end type type ( basis_set ), pointer :: basis real ( dp ), contiguous , pointer :: dma (:), dmb (:), moa (:,:), mob (:,:), epsa (:), epsb (:) real ( dp ), contiguous , pointer :: hess_store (:,:) real ( dp ), allocatable :: ptot (:,:), dSa (:,:,:,:), dTa (:,:,:,:), dVa (:,:,:,:) real ( dp ), allocatable :: sflat (:,:,:), hflat (:,:,:) real ( dp ), allocatable :: bvec (:,:), uvec (:,:), hess_native (:,:) real ( dp ), allocatable :: scr (:,:), tmp (:,:), gx (:,:), probe (:,:) real ( dp ), allocatable :: SxMO (:,:), hxMO (:,:), d0a (:,:), d0b (:,:) real ( dp ), allocatable :: dpck (:,:), fpck (:,:), gfull (:,:) real ( dp ), allocatable :: Gd0 (:,:), Mi (:,:) real ( dp ), allocatable :: A2 (:,:), tGP (:,:), hresp (:,:) type ( uhf_spin_t ) :: sp ( 2 ) real ( dp ) :: hfscale , a1v , a3v , t3a , dcsx integer :: nbf , nbf2 , natom , ncart , nocca , noccb , nvira , nvirb , la , lb , ltot integer :: s , i , j , a , ia , icart , kc , cc , x , yy , kk , ll , mu , nu basis => infos % basis basis % atoms => infos % atoms nbf = basis % nbf nbf2 = nbf * ( nbf + 1 ) / 2 natom = size ( basis % atoms % xyz , 2 ) ncart = 3 * natom nocca = infos % mol_prop % nelec_A noccb = infos % mol_prop % nelec_B nvira = nbf - nocca nvirb = nbf - noccb la = nocca * nvira lb = noccb * nvirb ltot = la + lb hfscale = 1.0_dp if ( infos % control % hamilton >= 20 ) hfscale = infos % dft % hfscale write ( iw , '(/,A)' ) 'PyOQP: Native OpenQP open-shell (UHF) HF Hessian CPHF response prepass' write ( iw , '(A,I6,A,I6,A,I6,A,I6,A,I6)' ) '  nbf=' , nbf , ' nocca=' , nocca , & ' noccb=' , noccb , ' rhs=' , ncart , ' ltot=' , ltot write ( iw , '(A)' ) '  Storing native OpenQP open-shell HF analytic Hessian in OQP::hf_hessian.' if ( ncart <= 0 . or . ( la <= 0 . and . lb <= 0 )) then write ( iw , '(A)' ) '  UHF CPHF prepass skipped: empty occupied/virtual/nuclear space.' return end if call tagarray_get_data ( infos % dat , OQP_DM_A , dma ) call tagarray_get_data ( infos % dat , OQP_DM_B , dmb ) call tagarray_get_data ( infos % dat , OQP_VEC_MO_A , moa ) call tagarray_get_data ( infos % dat , OQP_VEC_MO_B , mob ) call tagarray_get_data ( infos % dat , OQP_E_MO_A , epsa ) call tagarray_get_data ( infos % dat , OQP_E_MO_B , epsb ) ! per-spin containers sp ( 1 )% nocc = nocca ; sp ( 1 )% nvir = nvira ; sp ( 1 )% loff = 0 sp ( 2 )% nocc = noccb ; sp ( 2 )% nvir = nvirb ; sp ( 2 )% loff = la allocate ( sp ( 1 )% mo ( nbf , nbf ), sp ( 1 )% eps ( nbf ), sp ( 1 )% p ( nbf , nbf )) allocate ( sp ( 2 )% mo ( nbf , nbf ), sp ( 2 )% eps ( nbf ), sp ( 2 )% p ( nbf , nbf )) sp ( 1 )% mo = moa ; sp ( 1 )% eps = epsa sp ( 2 )% mo = mob ; sp ( 2 )% eps = epsb call unpack_matrix ( dma , sp ( 1 )% p ) call unpack_matrix ( dmb , sp ( 2 )% p ) allocate ( ptot ( nbf , nbf )); ptot = sp ( 1 )% p + sp ( 2 )% p ! derivative integrals (normalized into the bfnrm convention of the MOs) allocate ( dSa ( nbf , nbf , 3 , natom ), dTa ( nbf , nbf , 3 , natom ), dVa ( nbf , nbf , 3 , natom )) call der_overlap_matrix ( basis , dSa ) call der_kinetic_matrix ( basis , dTa ) call der_nucattr_matrix ( basis , basis % atoms % xyz , & basis % atoms % zn - basis % ecp_zn_num , dVa ) ! ECP-screened point charge block integer :: kc2 , cc2 , mu2 , nu2 do kc2 = 1 , natom do cc2 = 1 , 3 do nu2 = 1 , nbf do mu2 = 1 , nbf dSa ( mu2 , nu2 , cc2 , kc2 ) = dSa ( mu2 , nu2 , cc2 , kc2 ) * basis % bfnrm ( mu2 ) * basis % bfnrm ( nu2 ) dTa ( mu2 , nu2 , cc2 , kc2 ) = dTa ( mu2 , nu2 , cc2 , kc2 ) * basis % bfnrm ( mu2 ) * basis % bfnrm ( nu2 ) dVa ( mu2 , nu2 , cc2 , kc2 ) = dVa ( mu2 , nu2 , cc2 , kc2 ) * basis % bfnrm ( mu2 ) * basis % bfnrm ( nu2 ) end do end do end do end do end block ! ECP first-derivative integrals -> core-Hamiltonian derivative dHcore/dR (see ! the RHF kernel for the rationale).  Already in the normalized convention, so ! added after the bfnrm scaling.  No-op for non-ECP bases. block use ecp_tool , only : ecp_deriv_ints real ( dp ), allocatable :: dVecp (:,:,:,:) allocate ( dVecp ( nbf , nbf , 3 , natom )) call ecp_deriv_ints ( basis , basis % atoms % xyz , dVecp ) dVa = dVa + dVecp deallocate ( dVecp ) end block ! flat (ncart) AO views of S&#94;x and h&#94;x = (T+V)&#94;x allocate ( sflat ( nbf , nbf , ncart ), hflat ( nbf , nbf , ncart )) do x = 1 , ncart cc = mod ( x - 1 , 3 ) + 1 ; kc = ( x - 1 ) / 3 + 1 sflat (:,:, x ) = dSa (:,:, cc , kc ) hflat (:,:, x ) = dTa (:,:, cc , kc ) + dVa (:,:, cc , kc ) end do ! occ-occ and occ MO transforms needed by the response assembly allocate ( scr ( nbf , nbf ), tmp ( nbf , nbf ), SxMO ( nbf , nbf ), hxMO ( nbf , nbf )) do s = 1 , 2 allocate ( sp ( s )% s1oo ( sp ( s )% nocc , sp ( s )% nocc , ncart ), source = 0.0_dp ) allocate ( sp ( s )% hoo ( sp ( s )% nocc , sp ( s )% nocc , ncart ), source = 0.0_dp ) do x = 1 , ncart call mo_transform ( sp ( s )% mo , sflat (:,:, x ), nbf , scr , tmp , SxMO ) call mo_transform ( sp ( s )% mo , hflat (:,:, x ), nbf , scr , tmp , hxMO ) sp ( s )% s1oo (:,:, x ) = SxMO ( 1 : sp ( s )% nocc , 1 : sp ( s )% nocc ) sp ( s )% hoo (:,:, x ) = hxMO ( 1 : sp ( s )% nocc , 1 : sp ( s )% nocc ) end do end do ! ===== CPHF right-hand sides B&#94;s (occ-vir) for all 3N perturbations ===== allocate ( bvec ( ltot , ncart ), uvec ( ltot , ncart ), source = 0.0_dp ) allocate ( probe ( nbf , nbf ), gx ( 3 , natom )) allocate ( d0a ( nbf , nbf ), d0b ( nbf , nbf ), gfull ( nbf , nbf ), Gd0 ( nbf , nbf )) allocate ( dpck ( nbf2 , 2 ), fpck ( nbf2 , 2 )) ! 2e response-Fock skeleton  G&#94;{s,x}[P]_ia  for ALL 3N coordinates.  The ! occ-vir probe C&#94;s_a C&#94;s_i&#94;T is geometry-independent, so a single open-shell ! derivative-Fock contraction per occ-vir pair yields every Cartesian ! component at once (avoids an ncart-fold redundant grd2 sweep). do s = 1 , 2 allocate ( sp ( s )% g2e ( sp ( s )% nocc * sp ( s )% nvir , ncart ), source = 0.0_dp ) do a = 1 , sp ( s )% nvir do i = 1 , sp ( s )% nocc do mu = 1 , nbf do nu = 1 , nbf probe ( mu , nu ) = 0.5_dp * ( sp ( s )% mo ( mu , sp ( s )% nocc + a ) * sp ( s )% mo ( nu , i ) & + sp ( s )% mo ( mu , i ) * sp ( s )% mo ( nu , sp ( s )% nocc + a ) ) end do end do gx = 0.0_dp call fock_deriv_contract_os ( infos , basis , ptot , sp ( s )% p , probe , hfscale , gx ) ia = ( a - 1 ) * sp ( s )% nocc + i sp ( s )% g2e ( ia ,:) = reshape ( gx , [ ncart ]) end do end do end do icart = 0 do kc = 1 , natom do cc = 1 , 3 icart = icart + 1 ! reorthonormalization density per spin: d0&#94;s = -sum_ij S&#94;x,s_ij C&#94;s_i C&#94;s_j&#94;T d0a = 0.0_dp ; d0b = 0.0_dp do s = 1 , 2 call mo_transform ( sp ( s )% mo , dSa (:,:, cc , kc ), nbf , scr , tmp , SxMO ) do i = 1 , sp ( s )% nocc do j = 1 , sp ( s )% nocc do mu = 1 , nbf do nu = 1 , nbf if ( s == 1 ) then d0a ( mu , nu ) = d0a ( mu , nu ) - SxMO ( i , j ) * sp ( s )% mo ( mu , i ) * sp ( s )% mo ( nu , j ) else d0b ( mu , nu ) = d0b ( mu , nu ) - SxMO ( i , j ) * sp ( s )% mo ( mu , i ) * sp ( s )% mo ( nu , j ) end if end do end do end do end do end do call pack_matrix ( d0a , dpck (:, 1 )) call pack_matrix ( d0b , dpck (:, 2 )) fpck = 0.0_dp call fock_jk ( basis , d = dpck , f = fpck , scale_exch = hfscale , infos = infos ) do s = 1 , 2 call mo_transform ( sp ( s )% mo , dSa (:,:, cc , kc ), nbf , scr , tmp , SxMO ) call mo_transform ( sp ( s )% mo , dTa (:,:, cc , kc ) + dVa (:,:, cc , kc ), nbf , scr , tmp , hxMO ) call unpack_from_packed ( fpck (:, s ), gfull , nbf ) ! G&#94;s[d0] call mo_transform ( sp ( s )% mo , gfull , nbf , scr , tmp , Gd0 ) do a = 1 , sp ( s )% nvir do i = 1 , sp ( s )% nocc ia = ( a - 1 ) * sp ( s )% nocc + i bvec ( sp ( s )% loff + ia , icart ) = & - ( hxMO ( i , sp ( s )% nocc + a ) + sp ( s )% g2e ( ia , icart )) & + sp ( s )% eps ( i ) * SxMO ( i , sp ( s )% nocc + a ) & - Gd0 ( i , sp ( s )% nocc + a ) end do end do end do ! --- XC contribution to the CPKS right-hand side (UKS only) ------------- ! Mirror the closed-shell RKS RHS XC: one central FD of the spin XC Fock ! matrices (open-shell dftexcor) along R +/- h AND occupied MOs reorthonor- ! malized by dmoR&#94;s = -1/2 sum_j C&#94;s_j S&#94;x,s_ji captures both the XC ! skeleton dVxc/dR and f_xc[d0]; subtract the vir-occ MO blocks from B ! (which carries -F0x). if ( infos % control % hamilton >= 20 ) then block use dft , only : dft_initialize , dftclean , dftexcor use mod_dft_molgrid , only : dft_grid_t type ( dft_grid_t ) :: mgr real ( dp ), allocatable :: dmoa (:,:), dmob (:,:), mopa (:,:), mopb (:,:) real ( dp ), allocatable :: SxMOa (:,:), SxMOb (:,:) real ( dp ), allocatable :: frap (:), frbp (:), fram (:), frbm (:), dvx (:,:), hxc (:,:) real ( dp ) :: hxr , exr , telr , tknr integer :: ir , jr allocate ( dmoa ( nbf , nocca ), dmob ( nbf , noccb ), mopa ( nbf , nbf ), mopb ( nbf , nbf )) allocate ( SxMOa ( nbf , nbf ), SxMOb ( nbf , nbf )) allocate ( frap ( nbf2 ), frbp ( nbf2 ), fram ( nbf2 ), frbm ( nbf2 ), dvx ( nbf , nbf ), hxc ( nbf , nbf )) hxr = 1.0d-3 call mo_transform ( sp ( 1 )% mo , dSa (:,:, cc , kc ), nbf , scr , tmp , SxMOa ) call mo_transform ( sp ( 2 )% mo , dSa (:,:, cc , kc ), nbf , scr , tmp , SxMOb ) dmoa = 0.0_dp do ir = 1 , nocca do jr = 1 , nocca dmoa (:, ir ) = dmoa (:, ir ) - 0.5_dp * SxMOa ( jr , ir ) * sp ( 1 )% mo (:, jr ) end do end do dmob = 0.0_dp do ir = 1 , noccb do jr = 1 , noccb dmob (:, ir ) = dmob (:, ir ) - 0.5_dp * SxMOb ( jr , ir ) * sp ( 2 )% mo (:, jr ) end do end do basis % atoms % xyz ( cc , kc ) = basis % atoms % xyz ( cc , kc ) + hxr call basis % init_shell_centers () call dft_initialize ( infos , basis , mgr ) mopa = sp ( 1 )% mo ; mopa (:, 1 : nocca ) = sp ( 1 )% mo (:, 1 : nocca ) + hxr * dmoa mopb = sp ( 2 )% mo ; mopb (:, 1 : noccb ) = sp ( 2 )% mo (:, 1 : noccb ) + hxr * dmob frap = 0.0_dp ; frbp = 0.0_dp call dftexcor ( basis , mgr , int ( infos % control % scftype ), frap , frbp , mopa , mopb , & nbf , nbf2 , exr , telr , tknr , infos ) call dftclean ( infos ) basis % atoms % xyz ( cc , kc ) = basis % atoms % xyz ( cc , kc ) - 2 * hxr call basis % init_shell_centers () call dft_initialize ( infos , basis , mgr ) mopa = sp ( 1 )% mo ; mopa (:, 1 : nocca ) = sp ( 1 )% mo (:, 1 : nocca ) - hxr * dmoa mopb = sp ( 2 )% mo ; mopb (:, 1 : noccb ) = sp ( 2 )% mo (:, 1 : noccb ) - hxr * dmob fram = 0.0_dp ; frbm = 0.0_dp call dftexcor ( basis , mgr , int ( infos % control % scftype ), fram , frbm , mopa , mopb , & nbf , nbf2 , exr , telr , tknr , infos ) call dftclean ( infos ) basis % atoms % xyz ( cc , kc ) = basis % atoms % xyz ( cc , kc ) + hxr call basis % init_shell_centers () call unpack_from_packed (( frap - fram ) / ( 2 * hxr ), dvx , nbf ) call mo_transform ( sp ( 1 )% mo , dvx , nbf , scr , tmp , hxc ) do a = 1 , nvira do i = 1 , nocca ia = ( a - 1 ) * nocca + i bvec ( ia , icart ) = bvec ( ia , icart ) - hxc ( i , nocca + a ) end do end do call unpack_from_packed (( frbp - frbm ) / ( 2 * hxr ), dvx , nbf ) call mo_transform ( sp ( 2 )% mo , dvx , nbf , scr , tmp , hxc ) do a = 1 , nvirb do i = 1 , noccb ia = ( a - 1 ) * noccb + i bvec ( la + ia , icart ) = bvec ( la + ia , icart ) - hxc ( i , noccb + a ) end do end do deallocate ( dmoa , dmob , mopa , mopb , SxMOa , SxMOb , frap , frbp , fram , frbm , dvx , hxc ) end block end if end do end do call cphf_solve_uhf ( infos , ncart , bvec , uvec ) ! ===== open-shell CPHF orbital-relaxation response ===== ! relaxed dC&#94;s, spin density derivative dP&#94;s do s = 1 , 2 allocate ( sp ( s )% dCx ( nbf , sp ( s )% nocc , ncart ), source = 0.0_dp ) allocate ( sp ( s )% dPx ( nbf , nbf , ncart ), source = 0.0_dp ) do yy = 1 , ncart do a = 1 , sp ( s )% nvir do i = 1 , sp ( s )% nocc ia = ( a - 1 ) * sp ( s )% nocc + i sp ( s )% dCx (:, i , yy ) = sp ( s )% dCx (:, i , yy ) & + sp ( s )% mo (:, sp ( s )% nocc + a ) * uvec ( sp ( s )% loff + ia , yy ) end do end do do i = 1 , sp ( s )% nocc do j = 1 , sp ( s )% nocc sp ( s )% dCx (:, i , yy ) = sp ( s )% dCx (:, i , yy ) - 0.5_dp * sp ( s )% mo (:, j ) * sp ( s )% s1oo ( j , i , yy ) end do end do do i = 1 , sp ( s )% nocc do mu = 1 , nbf do nu = 1 , nbf sp ( s )% dPx ( mu , nu , yy ) = sp ( s )% dPx ( mu , nu , yy ) & + sp ( s )% dCx ( mu , i , yy ) * sp ( s )% mo ( nu , i ) + sp ( s )% mo ( mu , i ) * sp ( s )% dCx ( nu , i , yy ) end do end do end do end do allocate ( sp ( s )% gdpoo ( sp ( s )% nocc , sp ( s )% nocc , ncart ), source = 0.0_dp ) allocate ( sp ( s )% moe1 ( sp ( s )% nocc , sp ( s )% nocc , ncart ), source = 0.0_dp ) end do ! G&#94;s[dP&#94;y] (couples both spins via fock_jk) -> occ-occ MO block do yy = 1 , ncart call pack_matrix ( sp ( 1 )% dPx (:,:, yy ), dpck (:, 1 )) call pack_matrix ( sp ( 2 )% dPx (:,:, yy ), dpck (:, 2 )) fpck = 0.0_dp call fock_jk ( basis , d = dpck , f = fpck , scale_exch = hfscale , infos = infos ) do s = 1 , 2 call unpack_from_packed ( fpck (:, s ), gfull , nbf ) call mo_transform ( sp ( s )% mo , gfull , nbf , scr , tmp , hxMO ) sp ( s )% gdpoo (:,:, yy ) = hxMO ( 1 : sp ( s )% nocc , 1 : sp ( s )% nocc ) end do end do ! energy-weighted derivative occ-occ block (without the G[P]&#94;y piece, which ! is folded into tGP via the Mi&#94;x probe below) do s = 1 , 2 do yy = 1 , ncart do ll = 1 , sp ( s )% nocc do kk = 1 , sp ( s )% nocc sp ( s )% moe1 ( kk , ll , yy ) = sp ( s )% hoo ( kk , ll , yy ) + sp ( s )% gdpoo ( kk , ll , yy ) & - 0.5_dp * ( sp ( s )% eps ( kk ) + sp ( s )% eps ( ll )) * sp ( s )% s1oo ( kk , ll , yy ) end do end do end do end do ! 2e response traces, summed over spin: !   A2(x,y)  = sum_s Tr[dP&#94;s,y G&#94;{s,x}[P]] !   tGP(x,y) = sum_s Tr[Mi&#94;s,x G&#94;{s,y}[P]],  Mi&#94;s,x = sum_kl s1oo&#94;s,x_kl C&#94;s_k C&#94;s_l&#94;T allocate ( A2 ( ncart , ncart ), tGP ( ncart , ncart ), Mi ( nbf , nbf ), source = 0.0_dp ) do yy = 1 , ncart do s = 1 , 2 gx = 0.0_dp call fock_deriv_contract_os ( infos , basis , ptot , sp ( s )% p , sp ( s )% dPx (:,:, yy ), hfscale , gx ) A2 (:, yy ) = A2 (:, yy ) + reshape ( gx , [ ncart ]) end do end do do x = 1 , ncart do s = 1 , 2 Mi = 0.0_dp do ll = 1 , sp ( s )% nocc do kk = 1 , sp ( s )% nocc do mu = 1 , nbf do nu = 1 , nbf Mi ( mu , nu ) = Mi ( mu , nu ) + sp ( s )% s1oo ( kk , ll , x ) * sp ( s )% mo ( mu , kk ) * sp ( s )% mo ( nu , ll ) end do end do end do end do gx = 0.0_dp call fock_deriv_contract_os ( infos , basis , ptot , sp ( s )% p , Mi , hfscale , gx ) tGP ( x ,:) = tGP ( x ,:) + reshape ( gx , [ ncart ]) end do end do ! assemble  H&#94;resp_xy allocate ( hresp ( ncart , ncart ), source = 0.0_dp ) do x = 1 , ncart do yy = 1 , ncart a1v = 0.0_dp ; a3v = 0.0_dp ; t3a = 0.0_dp do s = 1 , 2 a1v = a1v + sum ( sp ( s )% dPx (:,:, yy ) * hflat (:,:, x )) do i = 1 , sp ( s )% nocc dcsx = 0.0_dp do mu = 1 , nbf do nu = 1 , nbf dcsx = dcsx + sp ( s )% dCx ( mu , i , yy ) * sflat ( mu , nu , x ) * sp ( s )% mo ( nu , i ) end do end do a3v = a3v + sp ( s )% eps ( i ) * dcsx end do do ll = 1 , sp ( s )% nocc do kk = 1 , sp ( s )% nocc t3a = t3a + sp ( s )% s1oo ( kk , ll , x ) * sp ( s )% moe1 ( kk , ll , yy ) end do end do end do hresp ( x , yy ) = ( a1v + A2 ( x , yy )) - 2.0_dp * a3v - t3a - tGP ( x , yy ) end do end do allocate ( hess_native ( ncart , ncart )) hess_native = 0.5_dp * ( hresp + transpose ( hresp )) ! --- DFT (UKS) exchange-correlation second-derivative contribution -------- ! Open-shell analog of the closed-shell RKS XC block: !   dHse : XC skeleton + density-response, central FD of the analytic !          open-shell XC gradient (derexc_blk) along R +/- h, P&#94;s +/- h dP&#94;s. !   dHt3 : -2 sum_s sum_kl s1oo&#94;s,x_kl (vxc&#94;s,y + fxc[dP&#94;s,y])_kl, the XC part !          of the energy-weighted term, from the FD of the spin XC Fock !          (dftexcor) along R, C&#94;s +/- h dC&#94;s. ! The HF-exchange fraction is already in the Coulomb/exchange terms (hfscale). if ( infos % control % hamilton >= 20 ) then block use dft , only : dft_initialize , dftclean , dftexcor use mod_dft_gridint_grad , only : derexc_blk use mod_dft_molgrid , only : dft_grid_t type ( dft_grid_t ) :: mg real ( dp ), allocatable :: dapa (:,:), dapb (:,:), dedp (:,:), dedm (:,:) real ( dp ), allocatable :: mopa (:,:), mopb (:,:), frap (:), frbp (:), fram (:), frbm (:) real ( dp ), allocatable :: dFxc (:,:), tmpn (:,:), dHse (:,:), dHt3 (:,:), dFoo (:,:) real ( dp ) :: hx , exr , telr , tknr integer :: yy2 , ccy , kcy , nang , x2 , kk2 , ll2 , ss hx = 1.0d-3 ; nang = maxval ( basis % am ) + 2 allocate ( dapa ( nbf , nbf ), dapb ( nbf , nbf ), dedp ( 3 , natom ), dedm ( 3 , natom )) allocate ( mopa ( nbf , nbf ), mopb ( nbf , nbf ), frap ( nbf2 ), frbp ( nbf2 ), fram ( nbf2 ), frbm ( nbf2 )) allocate ( dFxc ( nbf , nbf ), dHse ( ncart , ncart ), dHt3 ( ncart , ncart )) dHse = 0.0_dp ; dHt3 = 0.0_dp call dft_initialize ( infos , basis , mg ); call dftclean ( infos ) ! warm-up do yy2 = 1 , ncart ccy = mod ( yy2 - 1 , 3 ) + 1 ; kcy = ( yy2 - 1 ) / 3 + 1 basis % atoms % xyz ( ccy , kcy ) = basis % atoms % xyz ( ccy , kcy ) + hx call basis % init_shell_centers () call dft_initialize ( infos , basis , mg ) dapa = sp ( 1 )% p + hx * sp ( 1 )% dPx (:,:, yy2 ); dapb = sp ( 2 )% p + hx * sp ( 2 )% dPx (:,:, yy2 ) dedp = 0.0_dp call derexc_blk ( basis , mg , dapa , dapb , dedp , telr , tknr , nang , nbf , & infos % dft % grid_density_cutoff , . true ., infos ) mopa = sp ( 1 )% mo ; mopa (:, 1 : nocca ) = sp ( 1 )% mo (:, 1 : nocca ) + hx * sp ( 1 )% dCx (:,:, yy2 ) mopb = sp ( 2 )% mo ; mopb (:, 1 : noccb ) = sp ( 2 )% mo (:, 1 : noccb ) + hx * sp ( 2 )% dCx (:,:, yy2 ) frap = 0.0_dp ; frbp = 0.0_dp call dftexcor ( basis , mg , int ( infos % control % scftype ), frap , frbp , mopa , mopb , & nbf , nbf2 , exr , telr , tknr , infos ) call dftclean ( infos ) basis % atoms % xyz ( ccy , kcy ) = basis % atoms % xyz ( ccy , kcy ) - 2 * hx call basis % init_shell_centers () call dft_initialize ( infos , basis , mg ) dapa = sp ( 1 )% p - hx * sp ( 1 )% dPx (:,:, yy2 ); dapb = sp ( 2 )% p - hx * sp ( 2 )% dPx (:,:, yy2 ) dedm = 0.0_dp call derexc_blk ( basis , mg , dapa , dapb , dedm , telr , tknr , nang , nbf , & infos % dft % grid_density_cutoff , . true ., infos ) mopa = sp ( 1 )% mo ; mopa (:, 1 : nocca ) = sp ( 1 )% mo (:, 1 : nocca ) - hx * sp ( 1 )% dCx (:,:, yy2 ) mopb = sp ( 2 )% mo ; mopb (:, 1 : noccb ) = sp ( 2 )% mo (:, 1 : noccb ) - hx * sp ( 2 )% dCx (:,:, yy2 ) fram = 0.0_dp ; frbm = 0.0_dp call dftexcor ( basis , mg , int ( infos % control % scftype ), fram , frbm , mopa , mopb , & nbf , nbf2 , exr , telr , tknr , infos ) call dftclean ( infos ) basis % atoms % xyz ( ccy , kcy ) = basis % atoms % xyz ( ccy , kcy ) + hx call basis % init_shell_centers () dHse (:, yy2 ) = reshape (( dedp - dedm ) / ( 2 * hx ), [ ncart ]) ! dHt3: -2 sum_s s1oo&#94;s,x (dVxc&#94;s,y + fxc[dP&#94;s,y])_oo do ss = 1 , 2 if ( ss == 1 ) then call unpack_from_packed (( frap - fram ) / ( 2 * hx ), dFxc , nbf ) else call unpack_from_packed (( frbp - frbm ) / ( 2 * hx ), dFxc , nbf ) end if allocate ( tmpn ( nbf , sp ( ss )% nocc ), dFoo ( sp ( ss )% nocc , sp ( ss )% nocc )) call dgemm ( 'n' , 'n' , nbf , sp ( ss )% nocc , nbf , 1.0_dp , dFxc , nbf , sp ( ss )% mo , nbf , 0.0_dp , tmpn , nbf ) call dgemm ( 't' , 'n' , sp ( ss )% nocc , sp ( ss )% nocc , nbf , 1.0_dp , sp ( ss )% mo , nbf , tmpn , nbf , 0.0_dp , dFoo , sp ( ss )% nocc ) do x2 = 1 , ncart do ll2 = 1 , sp ( ss )% nocc do kk2 = 1 , sp ( ss )% nocc dHt3 ( x2 , yy2 ) = dHt3 ( x2 , yy2 ) - 1.0_dp * sp ( ss )% s1oo ( kk2 , ll2 , x2 ) * dFoo ( kk2 , ll2 ) end do end do end do deallocate ( tmpn , dFoo ) end do end do hess_native = hess_native + 0.5_dp * ( dHse + transpose ( dHse )) & + 0.5_dp * ( dHt3 + transpose ( dHt3 )) deallocate ( dapa , dapb , dedp , dedm , mopa , mopb , frap , frbp , fram , frbm , dFxc , dHse , dHt3 ) end block end if ! nuclear repulsion call hess_nn ( basis % atoms , basis % ecp_zn_num , hess_native ) ! --- one-electron + Pulay second-derivative skeleton (fixed density) ------ block use grd1 , only : eijden , hess_ee_overlap , hess_ee_kinetic , hess_en use ecp_tool , only : add_ecphess real ( dp ), allocatable :: wlag (:), pden (:), hcc (:,:) allocate ( wlag ( nbf2 ), pden ( nbf2 ), hcc ( ncart , ncart ), source = 0.0_dp ) call eijden ( wlag , nbf , infos ) ! open-shell Lagrangian W pden = dma + dmb ! total density (Pa + Pb) call hess_ee_overlap ( basis , wlag , hess_native ) call hess_ee_kinetic ( basis , pden , hess_native ) call hess_en ( basis , basis % atoms % xyz , & basis % atoms % zn - basis % ecp_zn_num , pden , hess_native , hess_cc = hcc ) call add_ecphess ( basis , basis % atoms % xyz , pden , hess_native ) ! ECP skeleton (if any) deallocate ( wlag , pden , hcc ) end block ! --- two-electron (ERI) second-derivative skeleton (fixed density) -------- block use grd2 , only : grd2_hess_driver , grd2_compute_data_t use hf_gradient_mod , only : grd2_uhf_compute_data_t type ( grd2_uhf_compute_data_t ) :: gcomp gcomp = grd2_uhf_compute_data_t ( da = dma , db = dmb , hfscale = hfscale , nbf = nbf ) call gcomp % init () call gcomp % build_cart ( basis ) call grd2_hess_driver ( infos , basis , hess_native , gcomp ) call gcomp % clean () end block call infos % dat % alloc_or_die ( OQP_hf_hessian , ( / ncart , ncart / ), hess_store , & description = 'Native OpenQP open-shell (UHF) HF analytic Hessian matrix' ) hess_store = hess_native write ( iw , '(A)' ) 'PyOQP: Native OpenQP open-shell (UHF) HF Hessian matrix stored' deallocate ( ptot , dSa , dTa , dVa , sflat , hflat , bvec , uvec , scr , tmp , SxMO , hxMO , & probe , gx , d0a , d0b , gfull , Gd0 , dpck , fpck , & A2 , tGP , Mi , hresp , hess_native ) end subroutine hf_hessian_uhf !############################################################################### subroutine hf_hessian_rohf ( infos ) ! Native open-shell (ROHF) analytic HF Hessian (HF only). ! ! ROHF uses a SINGLE MO set with a docc/socc/virt partition, so the orbital ! response is solved over the ROHF rotation space (cphf_solve_rohf) rather ! than the UHF spin blocks.  The ROHF energy has the same functional form as ! UHF in terms of (Pa, Pb), so the Hessian decomposes identically into !   H = E_nn'' + skeleton(1e total density + open-shell W, 2e via grd2_uhf) !       + response(orbital relaxation), ! where the skeleton + nuclear repulsion are exactly hess_skel_open. ! ! The orbital-relaxation response is evaluated SEMI-NUMERICALLY, reusing the ! validated analytic open-shell gradient: with the relaxed orbital derivative ! dC&#94;b (from the ROHF CPHF amplitudes) the response is the central finite ! difference, AT FIXED GEOMETRY, of the density/Lagrangian-dependent gradient ! along the orbital path C_occ +/- h dC&#94;b: !   H&#94;resp(:,b) = [ g(C + h dC&#94;b) - g(C - h dC&#94;b) ] / 2h , !   g(C') = grad_ee_overlap(W') + grad_ee_kinetic(P') + grad_en(P') !           + grad_2e(Pa', Pb') ,  W' = -(Pa' Fa' Pa' + Pb' Fb' Pb') , ! with Fa'/Fb' rebuilt from the perturbed densities (Hcore + fock_jk).  This ! captures BOTH the relaxed-density and the energy-weighted (W) response ! through the gradient's own W build (eijden convention), so no ROHF-specific ! Lagrangian-derivative algebra is required.  The CPHF right-hand side is the ! non-canonical Pulay form (orbital energies replaced by the full Fock occ-occ ! blocks), reducing to the validated UHF RHS in the canonical limit. use precision , only : dp use types , only : information use basis_tools , only : basis_set use oqp_tagarray_driver , only : tagarray_get_data , OQP_DM_A , OQP_DM_B , & OQP_VEC_MO_A , OQP_FOCK_A , OQP_FOCK_B , OQP_Hcore , OQP_hf_hessian , TA_TYPE_REAL64 use mathlib , only : unpack_matrix , pack_matrix , orthogonal_transform_sym use grd1 , only : der_overlap_matrix , der_kinetic_matrix , der_nucattr_matrix , hess_nn , & grad_ee_overlap , grad_ee_kinetic , grad_en_hellman_feynman , grad_en_pulay use grd2 , only : grd2_driver , grd2_compute_data_t use hf_gradient_mod , only : grd2_uhf_compute_data_t use fock_deriv_mod , only : fock_deriv_contract_os use scf_addons , only : fock_jk use cphf_mod , only : cphf_solve_rohf , rohf_pack_trial , rohf_unpack_trial use io_constants , only : iw use messages , only : show_message , WITH_ABORT implicit none type ( information ), target , intent ( inout ) :: infos type ( basis_set ), pointer :: basis real ( dp ), contiguous , pointer :: dma (:), dmb (:), mo (:,:), focka (:), fockb (:), hcore (:) real ( dp ), contiguous , pointer :: hess_store (:,:) real ( dp ), allocatable :: pa (:,:), pb (:,:), ptot (:,:) real ( dp ), allocatable :: dSa (:,:,:,:), dTa (:,:,:,:), dVa (:,:,:,:) real ( dp ), allocatable :: faMO (:,:), fbMO (:,:) real ( dp ), allocatable :: scr (:,:), tmp (:,:), SxMO (:,:), hxMO (:,:), probe (:,:) real ( dp ), allocatable :: ga2e (:,:,:), gb2e (:,:,:) real ( dp ), allocatable :: d0a (:,:), d0b (:,:), dpck (:,:), fpck (:,:), gfull (:,:), Gd0 (:,:) real ( dp ), allocatable :: ba (:,:), bb (:,:), bvec (:,:), uvec (:,:) real ( dp ), allocatable :: xa (:,:), xb (:,:), dCa (:,:), dCb (:,:), gp (:,:), gm (:,:) real ( dp ), allocatable :: zneff (:), hess_native (:,:), hresp (:,:) real ( dp ), allocatable :: faop (:), fbop (:) integer , allocatable :: iecp_atom (:) real ( dp ) :: hfscale , hstep , gx ( 3 , size ( infos % atoms % xyz , 2 )) integer :: nbf , nbf2 , natom , ncart , nocca , noccb , nvira , nvirb , offset , ltot integer :: i , j , a , icart , kc , cc , x , mu , nu , ie , nec basis => infos % basis basis % atoms => infos % atoms nbf = basis % nbf nbf2 = nbf * ( nbf + 1 ) / 2 natom = size ( basis % atoms % xyz , 2 ) ncart = 3 * natom nocca = infos % mol_prop % nelec_A noccb = infos % mol_prop % nelec_B nvira = nbf - nocca nvirb = nbf - noccb offset = nocca - noccb ltot = noccb * ( offset + nvira ) + offset * nvira hfscale = 1.0_dp if ( infos % control % hamilton >= 20 ) hfscale = infos % dft % hfscale hstep = 1.0d-3 write ( iw , '(/,A)' ) 'PyOQP: Native OpenQP open-shell (ROHF) HF Hessian CPHF response prepass' write ( iw , '(A,I6,A,I6,A,I6,A,I6,A,I6)' ) '  nbf=' , nbf , ' nocca=' , nocca , & ' noccb=' , noccb , ' rhs=' , ncart , ' rotdim=' , ltot write ( iw , '(A)' ) '  Storing native OpenQP open-shell (ROHF) HF analytic Hessian in OQP::hf_hessian.' if ( ncart <= 0 . or . ltot <= 0 ) then write ( iw , '(A)' ) '  ROHF CPHF prepass skipped: empty rotation/nuclear space.' return end if call tagarray_get_data ( infos % dat , OQP_DM_A , dma ) call tagarray_get_data ( infos % dat , OQP_DM_B , dmb ) call tagarray_get_data ( infos % dat , OQP_VEC_MO_A , mo ) call tagarray_get_data ( infos % dat , OQP_FOCK_A , focka ) call tagarray_get_data ( infos % dat , OQP_FOCK_B , fockb ) call tagarray_get_data ( infos % dat , OQP_Hcore , hcore ) allocate ( pa ( nbf , nbf ), pb ( nbf , nbf ), ptot ( nbf , nbf )) call unpack_matrix ( dma , pa ); call unpack_matrix ( dmb , pb ); ptot = pa + pb allocate ( zneff ( natom )); zneff = basis % atoms % zn - basis % ecp_zn_num ! Map each atom to its ECP-centre index in ecp_coord (which is sized ! 3*num_ecps, i.e. one (x,y,z) triple per ECP centre, NOT per atom).  The ! semi-numerical resp_grad displaces atoms one Cartesian at a time and must ! move the matching ECP centre in lockstep; iecp_atom(kc)=0 means atom kc ! carries no ECP (its centre must not be touched). allocate ( iecp_atom ( natom )); iecp_atom = 0 if ( basis % ecp_params % is_ecp ) then nec = size ( basis % ecp_params % n_expo ) do ie = 1 , nec do i = 1 , natom if ( all ( abs ( basis % ecp_params % ecp_coord ( 3 * ( ie - 1 ) + 1 : 3 * ie ) & - basis % atoms % xyz (:, i )) < 1.0e-6_dp )) then iecp_atom ( i ) = ie exit end if end do end do ! Every ECP centre must have been matched to an atom: an unmapped centre ! would stay fixed while its atom is displaced, silently corrupting the ! semi-numerical response. Abort loudly instead. if ( count ( iecp_atom > 0 ) /= nec ) then call show_message ( 'hf_hessian (ROHF): could not map every ECP centre ' // & 'to an atom (coordinate mismatch > 1e-6 bohr); analytic Hessian ' // & 'would be wrong - use [hess] type=numerical for this system.' , WITH_ABORT ) end if end if ! derivative integrals (normalized into the bfnrm/MO convention) allocate ( dSa ( nbf , nbf , 3 , natom ), dTa ( nbf , nbf , 3 , natom ), dVa ( nbf , nbf , 3 , natom )) call der_overlap_matrix ( basis , dSa ) call der_kinetic_matrix ( basis , dTa ) call der_nucattr_matrix ( basis , basis % atoms % xyz , & basis % atoms % zn - basis % ecp_zn_num , dVa ) ! ECP-screened point charge block integer :: kc2 , cc2 , mu2 , nu2 do kc2 = 1 , natom do cc2 = 1 , 3 do nu2 = 1 , nbf do mu2 = 1 , nbf dSa ( mu2 , nu2 , cc2 , kc2 ) = dSa ( mu2 , nu2 , cc2 , kc2 ) * basis % bfnrm ( mu2 ) * basis % bfnrm ( nu2 ) dTa ( mu2 , nu2 , cc2 , kc2 ) = dTa ( mu2 , nu2 , cc2 , kc2 ) * basis % bfnrm ( mu2 ) * basis % bfnrm ( nu2 ) dVa ( mu2 , nu2 , cc2 , kc2 ) = dVa ( mu2 , nu2 , cc2 , kc2 ) * basis % bfnrm ( mu2 ) * basis % bfnrm ( nu2 ) end do end do end do end do end block ! ECP first-derivative integrals -> core-Hamiltonian derivative dHcore/dR, ! feeding the non-canonical CPHF RHS (hxMO below).  The ECP skeleton + response ! is then completed by add_ecpder inside resp_grad (semi-numerical).  Already ! normalized, so added after the bfnrm scaling.  No-op for non-ECP bases. block use ecp_tool , only : ecp_deriv_ints real ( dp ), allocatable :: dVecp (:,:,:,:) allocate ( dVecp ( nbf , nbf , 3 , natom )) call ecp_deriv_ints ( basis , basis % atoms % xyz , dVecp ) dVa = dVa + dVecp deallocate ( dVecp ) end block ! occ-occ Fock blocks (MO) of the converged spin Fock matrices (non-canonical) allocate ( scr ( nbf , nbf ), tmp ( nbf , nbf ), SxMO ( nbf , nbf ), hxMO ( nbf , nbf )) allocate ( faMO ( nbf , nbf ), fbMO ( nbf , nbf )) call unpack_matrix ( focka , scr ); call mo_transform ( mo , scr , nbf , tmp , hxMO , faMO ) call unpack_matrix ( fockb , scr ); call mo_transform ( mo , scr , nbf , tmp , hxMO , fbMO ) ! 2e response-Fock skeleton  G&#94;{s,x}[P]_ai  for all coordinates (per spin) allocate ( ga2e ( nvira , nocca , ncart ), gb2e ( nvirb , noccb , ncart ), source = 0.0_dp ) allocate ( probe ( nbf , nbf )) do a = 1 , nvira do i = 1 , nocca do mu = 1 , nbf do nu = 1 , nbf probe ( mu , nu ) = 0.5_dp * ( mo ( mu , nocca + a ) * mo ( nu , i ) + mo ( mu , i ) * mo ( nu , nocca + a ) ) end do end do gx = 0.0_dp call fock_deriv_contract_os ( infos , basis , ptot , pa , probe , hfscale , gx ) ga2e ( a , i ,:) = reshape ( gx , [ ncart ]) end do end do do a = 1 , nvirb do i = 1 , noccb do mu = 1 , nbf do nu = 1 , nbf probe ( mu , nu ) = 0.5_dp * ( mo ( mu , noccb + a ) * mo ( nu , i ) + mo ( mu , i ) * mo ( nu , noccb + a ) ) end do end do gx = 0.0_dp call fock_deriv_contract_os ( infos , basis , ptot , pb , probe , hfscale , gx ) gb2e ( a , i ,:) = reshape ( gx , [ ncart ]) end do end do ! ===== CPHF right-hand sides (non-canonical Pulay form), packed ===== allocate ( d0a ( nbf , nbf ), d0b ( nbf , nbf ), gfull ( nbf , nbf ), Gd0 ( nbf , nbf )) allocate ( dpck ( nbf2 , 2 ), fpck ( nbf2 , 2 )) allocate ( ba ( nvira , nocca ), bb ( nvirb , noccb )) allocate ( bvec ( ltot , ncart ), uvec ( ltot , ncart ), source = 0.0_dp ) icart = 0 do kc = 1 , natom do cc = 1 , 3 icart = icart + 1 call mo_transform ( mo , dSa (:,:, cc , kc ), nbf , scr , tmp , SxMO ) call mo_transform ( mo , dTa (:,:, cc , kc ) + dVa (:,:, cc , kc ), nbf , scr , tmp , hxMO ) ! reorthonormalization densities d0&#94;s = -sum_ij S&#94;x_ij C_i C_j (per spin occ) d0a = 0.0_dp ; d0b = 0.0_dp do i = 1 , nocca do j = 1 , nocca do mu = 1 , nbf do nu = 1 , nbf d0a ( mu , nu ) = d0a ( mu , nu ) - SxMO ( i , j ) * mo ( mu , i ) * mo ( nu , j ) end do end do end do end do do i = 1 , noccb do j = 1 , noccb do mu = 1 , nbf do nu = 1 , nbf d0b ( mu , nu ) = d0b ( mu , nu ) - SxMO ( i , j ) * mo ( mu , i ) * mo ( nu , j ) end do end do end do end do call pack_matrix ( d0a , dpck (:, 1 )); call pack_matrix ( d0b , dpck (:, 2 )) fpck = 0.0_dp call fock_jk ( basis , d = dpck , f = fpck , scale_exch = hfscale , infos = infos ) ! Non-canonical Pulay RHS.  The reorthonormalization Fock-coupling is the ! occupied-projected anticommutator of S&#94;x and the spin Fock: !   B&#94;s_ai = -(h&#94;x + G2e + G[d0])_ai !            + sum_{j in occ} ( S&#94;x_aj F&#94;s_ji + F&#94;s_aj S&#94;x_ji ) . ! The first sum is the usual eps_i S&#94;x_ai in the canonical (diagonal-Fock) ! limit; the second vanishes there (F&#94;s_aj is a vir-occ Fock element) and ! supplies the non-canonical correction needed for the socc rotations. call unpack_from_packed ( fpck (:, 1 ), gfull , nbf ) call mo_transform ( mo , gfull , nbf , scr , tmp , Gd0 ) do i = 1 , nocca do a = 1 , nvira ba ( a , i ) = - ( hxMO ( i , nocca + a ) + ga2e ( a , i , icart ) + Gd0 ( i , nocca + a )) & + dot_product ( SxMO ( nocca + a , 1 : nocca ), faMO ( 1 : nocca , i )) & + dot_product ( faMO ( nocca + a , 1 : nocca ), SxMO ( 1 : nocca , i )) end do end do ! beta block call unpack_from_packed ( fpck (:, 2 ), gfull , nbf ) call mo_transform ( mo , gfull , nbf , scr , tmp , Gd0 ) do i = 1 , noccb do a = 1 , nvirb bb ( a , i ) = - ( hxMO ( i , noccb + a ) + gb2e ( a , i , icart ) + Gd0 ( i , noccb + a )) & + dot_product ( SxMO ( noccb + a , 1 : noccb ), fbMO ( 1 : noccb , i )) & + dot_product ( fbMO ( noccb + a , 1 : noccb ), SxMO ( 1 : noccb , i )) end do end do ! --- XC contribution to the CPKS right-hand side (ROKS only) ----------- ! Central FD of the spin XC Fock (open-shell dftexcor) along R +/- h AND ! occupied MOs reorthonormalized by dmoR&#94;s = -1/2 sum_j C_j S&#94;x_ji; the XC ! skeleton dVxc/dR + f_xc[d0], subtracted from B (which carries -F0x). if ( infos % control % hamilton >= 20 ) then block use dft , only : dft_initialize , dftclean , dftexcor use mod_dft_molgrid , only : dft_grid_t type ( dft_grid_t ) :: mgr real ( dp ), allocatable :: dmoa (:,:), dmob (:,:), mopa (:,:), mopb (:,:) real ( dp ), allocatable :: frap (:), frbp (:), fram (:), frbm (:), dvx (:,:), hxc (:,:) real ( dp ) :: hxr , exr , telr , tknr integer :: ir , jr allocate ( dmoa ( nbf , nocca ), dmob ( nbf , noccb ), mopa ( nbf , nbf ), mopb ( nbf , nbf )) allocate ( frap ( nbf2 ), frbp ( nbf2 ), fram ( nbf2 ), frbm ( nbf2 ), dvx ( nbf , nbf ), hxc ( nbf , nbf )) hxr = 1.0d-3 dmoa = 0.0_dp do ir = 1 , nocca do jr = 1 , nocca dmoa (:, ir ) = dmoa (:, ir ) - 0.5_dp * SxMO ( jr , ir ) * mo (:, jr ) end do end do dmob = 0.0_dp do ir = 1 , noccb do jr = 1 , noccb dmob (:, ir ) = dmob (:, ir ) - 0.5_dp * SxMO ( jr , ir ) * mo (:, jr ) end do end do basis % atoms % xyz ( cc , kc ) = basis % atoms % xyz ( cc , kc ) + hxr call basis % init_shell_centers () call dft_initialize ( infos , basis , mgr ) mopa = mo ; mopa (:, 1 : nocca ) = mo (:, 1 : nocca ) + hxr * dmoa mopb = mo ; mopb (:, 1 : noccb ) = mo (:, 1 : noccb ) + hxr * dmob frap = 0.0_dp ; frbp = 0.0_dp call dftexcor ( basis , mgr , int ( infos % control % scftype ), frap , frbp , mopa , mopb , & nbf , nbf2 , exr , telr , tknr , infos ) call dftclean ( infos ) basis % atoms % xyz ( cc , kc ) = basis % atoms % xyz ( cc , kc ) - 2 * hxr call basis % init_shell_centers () call dft_initialize ( infos , basis , mgr ) mopa = mo ; mopa (:, 1 : nocca ) = mo (:, 1 : nocca ) - hxr * dmoa mopb = mo ; mopb (:, 1 : noccb ) = mo (:, 1 : noccb ) - hxr * dmob fram = 0.0_dp ; frbm = 0.0_dp call dftexcor ( basis , mgr , int ( infos % control % scftype ), fram , frbm , mopa , mopb , & nbf , nbf2 , exr , telr , tknr , infos ) call dftclean ( infos ) basis % atoms % xyz ( cc , kc ) = basis % atoms % xyz ( cc , kc ) + hxr call basis % init_shell_centers () call unpack_from_packed (( frap - fram ) / ( 2 * hxr ), dvx , nbf ) call mo_transform ( mo , dvx , nbf , scr , tmp , hxc ) do i = 1 , nocca do a = 1 , nvira ba ( a , i ) = ba ( a , i ) - hxc ( i , nocca + a ) end do end do call unpack_from_packed (( frbp - frbm ) / ( 2 * hxr ), dvx , nbf ) call mo_transform ( mo , dvx , nbf , scr , tmp , hxc ) do i = 1 , noccb do a = 1 , nvirb bb ( a , i ) = bb ( a , i ) - hxc ( i , noccb + a ) end do end do deallocate ( dmoa , dmob , mopa , mopb , frap , frbp , fram , frbm , dvx , hxc ) end block end if call rohf_pack_trial ( bvec (:, icart ), ba , bb , nbf , nocca , noccb ) end do end do call cphf_solve_rohf ( infos , ncart , bvec , uvec ) ! ===== semi-numerical orbital-relaxation response ===== ! Build the relaxed alpha/beta orbital derivatives independently, UHF-style: !   dCa_i = sum_a C&#94;{vir_a}_a xa(a,i) - 1/2 sum_{j in docc+socc} S&#94;x_ji C_j !   dCb_i = sum_a C&#94;{vir_b}_a xb(a,i) - 1/2 sum_{j in docc}      S&#94;x_ji C_j ! The socc-docc rotation lives in xb (socc is beta-virtual), so it relaxes Pb ! and leaves Pa invariant (it is an alpha occ-occ rotation) -- exactly the ! ROHF physics, with no socc-docc cross term needed in dCa. allocate ( xa ( nvira , nocca ), xb ( nvirb , noccb ), dCa ( nbf , nocca ), dCb ( nbf , noccb )) allocate ( gp ( 3 , natom ), gm ( 3 , natom ), hresp ( ncart , ncart ), source = 0.0_dp ) allocate ( faop ( nbf2 ), fbop ( nbf2 )) if ( infos % control % hamilton >= 20 ) then ! flush stale grid state from the CPHF solver block use dft , only : dft_initialize , dftclean use mod_dft_molgrid , only : dft_grid_t type ( dft_grid_t ) :: mgw call dft_initialize ( infos , basis , mgw ); call dftclean ( infos ) end block end if do x = 1 , ncart cc = mod ( x - 1 , 3 ) + 1 ; kc = ( x - 1 ) / 3 + 1 call rohf_unpack_trial ( uvec (:, x ), xa , xb , nbf , nocca , noccb ) call mo_transform ( mo , dSa (:,:, cc , kc ), nbf , scr , tmp , SxMO ) dCa = 0.0_dp do i = 1 , nocca do a = 1 , nvira dCa (:, i ) = dCa (:, i ) + mo (:, nocca + a ) * xa ( a , i ) end do do j = 1 , nocca dCa (:, i ) = dCa (:, i ) - 0.5_dp * SxMO ( j , i ) * mo (:, j ) end do end do dCb = 0.0_dp do i = 1 , noccb do a = 1 , nvirb dCb (:, i ) = dCb (:, i ) + mo (:, noccb + a ) * xb ( a , i ) end do do j = 1 , noccb dCb (:, i ) = dCb (:, i ) - 0.5_dp * SxMO ( j , i ) * mo (:, j ) end do end do call resp_grad ( 1.0_dp , gp ) call resp_grad ( - 1.0_dp , gm ) hresp (:, x ) = reshape (( gp - gm ) / ( 2.0_dp * hstep ), [ ncart ]) end do ! The central difference of the ELECTRONIC gradient over geometry AND the ! relaxed orbital path already contains the full electronic Hessian (skeleton ! + orbital-relaxation response); only the (orbital-independent) nuclear ! repulsion second derivative is added analytically. allocate ( hess_native ( ncart , ncart )) hess_native = 0.5_dp * ( hresp + transpose ( hresp )) call hess_nn ( basis % atoms , basis % ecp_zn_num , hess_native ) call infos % dat % alloc_or_die ( OQP_hf_hessian , ( / ncart , ncart / ), hess_store , & description = 'Native OpenQP open-shell (ROHF) HF analytic Hessian matrix' ) hess_store = hess_native write ( iw , '(A)' ) 'PyOQP: Native OpenQP open-shell (ROHF) HF Hessian matrix stored' deallocate ( pa , pb , ptot , dSa , dTa , dVa , faMO , fbMO , scr , tmp , & SxMO , hxMO , probe , ga2e , gb2e , d0a , d0b , dpck , fpck , gfull , Gd0 , & ba , bb , bvec , uvec , xa , xb , dCa , dCb , gp , gm , hresp , zneff , & hess_native , faop , fbop , iecp_atom ) contains !> Electronic gradient (1e + 2e + Pulay-W; NO nuclear repulsion) at the !> geometry displaced by sgn*hstep in coordinate (cc,kc) AND the alpha-occ !> MOs displaced by sgn*hstep*dC (host-associated cc,kc,dC,hstep).  Central !> differencing over sgn therefore captures the electronic skeleton AND the !> orbital-relaxation response together: the one-electron Hamiltonian, all !> gradient integrals, the densities Pa'/Pb' and the energy-weighted density !> W' = -(Pa' Fa' Pa' + Pb' Fb' Pb') (eijden convention, Fock rebuilt as !> Hcore' + fock_jk) are all evaluated at the displaced point, so no !> ROHF-specific Lagrangian-derivative algebra is needed. subroutine resp_grad ( sgn , gout ) use int1 , only : omp_hst real ( dp ), intent ( in ) :: sgn real ( dp ), intent ( out ) :: gout (:,:) real ( dp ), allocatable :: cocc (:,:), pap (:,:), pbp (:,:) real ( dp ), allocatable , target :: paP_tri (:), pbP_tri (:) real ( dp ), allocatable :: ptP_tri (:), wlag (:), ta (:), hc (:), sm (:), tm (:) real ( dp ) :: tol integer :: ii , ij type ( grd2_uhf_compute_data_t ) :: gc allocate ( cocc ( nbf , nocca ), pap ( nbf , nbf ), pbp ( nbf , nbf )) allocate ( paP_tri ( nbf2 ), pbP_tri ( nbf2 ), ptP_tri ( nbf2 ), wlag ( nbf2 ), ta ( nbf2 )) allocate ( hc ( nbf2 ), sm ( nbf2 ), tm ( nbf2 )) ! displace geometry and rebuild the one-electron Hamiltonian there.  The ECP ! center (ecp_coord) is a separate array from atoms%xyz, so it must be moved ! in lockstep or the displaced add_ecpint/add_ecpder would see the basis and ! the ECP at mismatched centers (catastrophic for the ECP atom). basis % atoms % xyz ( cc , kc ) = basis % atoms % xyz ( cc , kc ) + sgn * hstep if ( iecp_atom ( kc ) > 0 ) & basis % ecp_params % ecp_coord ( 3 * ( iecp_atom ( kc ) - 1 ) + cc ) = & basis % ecp_params % ecp_coord ( 3 * ( iecp_atom ( kc ) - 1 ) + cc ) + sgn * hstep call basis % init_shell_centers () tol = log ( 1 0.0d0 ) * 2 0.0_dp call omp_hst ( basis , basis % atoms % xyz , basis % atoms % zn - basis % ecp_zn_num , & hc , sm , tm , logtol = tol , comm = infos % mpiinfo % comm , usempi = infos % mpiinfo % usempi ) ! NB: the ECP one-electron potential is deliberately NOT added to hc here. ! The full ECP gradient (operator + basis-centre/Pulay derivatives) is the ! analytic add_ecpder below; folding the ECP into the spin Fock used to build ! the energy-weighted density W' would double-count its Pulay contribution ! (verified: doing so gives ~1.5e-2 vs the numerical Hessian, omitting it ! gives ~2e-5). ! relaxed orbitals -> perturbed densities and spin Fock matrices cocc (:, 1 : nocca ) = mo (:, 1 : nocca ) + sgn * hstep * dCa call dgemm ( 'n' , 't' , nbf , nbf , nocca , 1.0_dp , cocc , nbf , cocc , nbf , 0.0_dp , pap , nbf ) cocc (:, 1 : noccb ) = mo (:, 1 : noccb ) + sgn * hstep * dCb call dgemm ( 'n' , 't' , nbf , nbf , noccb , 1.0_dp , cocc , nbf , cocc , nbf , 0.0_dp , pbp , nbf ) call pack_matrix ( pap , paP_tri ); call pack_matrix ( pbp , pbP_tri ) ptP_tri = paP_tri + pbP_tri dpck (:, 1 ) = paP_tri ; dpck (:, 2 ) = pbP_tri fpck = 0.0_dp call fock_jk ( basis , d = dpck , f = fpck , scale_exch = hfscale , infos = infos ) faop = hc + fpck (:, 1 ); fbop = hc + fpck (:, 2 ) gout = 0.0_dp ! DFT (ROKS): add the XC potential to the spin Focks (so W' is the full KS ! energy-weighted density) and the explicit open-shell XC gradient to gout. ! Both are evaluated at the displaced geometry with the relaxed orbitals, so ! the geometry+orbital FD gives the full KS Hessian (Pulay/W XC + explicit XC) ! with no separate analytic XC term. if ( infos % control % hamilton >= 20 ) then block use dft , only : dft_initialize , dftclean , dftexcor use mod_dft_gridint_grad , only : derexc_blk use mod_dft_molgrid , only : dft_grid_t type ( dft_grid_t ) :: mg real ( dp ), allocatable :: mopa (:,:), mopb (:,:), fra (:), frb (:), dedft (:,:) real ( dp ) :: exr , telr , tknr integer :: nang allocate ( mopa ( nbf , nbf ), mopb ( nbf , nbf ), fra ( nbf2 ), frb ( nbf2 ), dedft ( 3 , natom )) nang = maxval ( basis % am ) + 2 call dft_initialize ( infos , basis , mg ) mopa = mo ; mopa (:, 1 : nocca ) = mo (:, 1 : nocca ) + sgn * hstep * dCa mopb = mo ; mopb (:, 1 : noccb ) = mo (:, 1 : noccb ) + sgn * hstep * dCb fra = 0.0_dp ; frb = 0.0_dp call dftexcor ( basis , mg , int ( infos % control % scftype ), fra , frb , mopa , mopb , & nbf , nbf2 , exr , telr , tknr , infos ) faop = faop + fra ; fbop = fbop + frb dedft = 0.0_dp call derexc_blk ( basis , mg , pap , pbp , dedft , telr , tknr , nang , nbf , & infos % dft % grid_density_cutoff , . true ., infos ) call dftclean ( infos ) gout = gout + dedft deallocate ( mopa , mopb , fra , frb , dedft ) end block end if call orthogonal_transform_sym ( nbf , nbf , faop , pap , nbf , ta ) call orthogonal_transform_sym ( nbf , nbf , fbop , pbp , nbf , wlag ) wlag = - wlag - ta ij = 0 do ii = 1 , nbf ij = ij + ii wlag ( ij ) = 0.5_dp * wlag ( ij ) end do call grad_ee_overlap ( basis , wlag , gout ) call grad_ee_kinetic ( basis , ptP_tri , gout ) call grad_en_hellman_feynman ( basis , basis % atoms % xyz , zneff , ptP_tri , gout ) call grad_en_pulay ( basis , basis % atoms % xyz , zneff , ptP_tri , gout ) ! ECP gradient at the displaced geometry/density: central FD over the ! geometry+orbital path then yields BOTH the ECP skeleton second derivative ! and the ECP orbital-relaxation response.  No-op for non-ECP bases. block use ecp_tool , only : add_ecpder call add_ecpder ( basis , basis % atoms % xyz , ptP_tri , gout ) end block gc = grd2_uhf_compute_data_t ( da = paP_tri , db = pbP_tri , hfscale = hfscale , nbf = nbf ) call gc % init () call gc % build_cart ( basis ) call grd2_driver ( infos , basis , gout , gc ) call gc % clean () ! restore geometry (and the ECP center moved above) basis % atoms % xyz ( cc , kc ) = basis % atoms % xyz ( cc , kc ) - sgn * hstep if ( iecp_atom ( kc ) > 0 ) & basis % ecp_params % ecp_coord ( 3 * ( iecp_atom ( kc ) - 1 ) + cc ) = & basis % ecp_params % ecp_coord ( 3 * ( iecp_atom ( kc ) - 1 ) + cc ) - sgn * hstep call basis % init_shell_centers () deallocate ( cocc , pap , pbp , paP_tri , pbP_tri , ptP_tri , wlag , ta , hc , sm , tm ) end subroutine resp_grad end subroutine hf_hessian_rohf !############################################################################### subroutine mo_transform ( c_mo , a_ao , n , s1 , s2 , b_mo ) use precision , only : dp real ( kind = dp ), intent ( in ) :: c_mo (:,:), a_ao (:,:) integer , intent ( in ) :: n real ( kind = dp ), intent ( inout ) :: s1 (:,:), s2 (:,:), b_mo (:,:) call dgemm ( 't' , 'n' , n , n , n , 1.0_dp , c_mo , n , a_ao , n , 0.0_dp , s1 , n ) call dgemm ( 'n' , 'n' , n , n , n , 1.0_dp , s1 , n , c_mo , n , 0.0_dp , b_mo , n ) end subroutine mo_transform !############################################################################### subroutine unpack_from_packed ( gpk , gfu , n ) use precision , only : dp real ( kind = dp ), intent ( in ) :: gpk (:) real ( kind = dp ), intent ( inout ) :: gfu (:,:) integer , intent ( in ) :: n integer :: ii , jj , ij ij = 0 do ii = 1 , n do jj = 1 , ii ij = ij + 1 gfu ( ii , jj ) = gpk ( ij ); gfu ( jj , ii ) = gpk ( ij ) end do end do end subroutine unpack_from_packed end module hf_hessian_mod","tags":"","url":"sourcefile/hf_hessian.f90.html"},{"title":"resp.F90 – OpenQP Fortran API","text":"Source Code module resp_mod use oqp_linalg implicit none character ( len =* ), parameter :: module_name = \"resp_mod\" private public oqp_resp_charges public add_atom_grid public resp_charges_C !-------------------------------------------------------------------------------- contains !-------------------------------------------------------------------------------- !> @brief Compute ESP charges fitted by modified Merz-Kollman method !> @details This is a C interface for a Fortran subroutine !> !> @param[in]      c_handle     OQP handle ! !> @author   Vladimir Mironov ! !     REVISION HISTORY: !> @date _Mar, 2023_ Initial release subroutine resp_charges_C ( c_handle ) bind ( C , name = \"resp_charges\" ) use c_interop , only : oqp_handle_t , oqp_handle_get_info , oqp_handle_refresh_ptr use strings , only : Cstring use types , only : information type ( oqp_handle_t ) :: c_handle type ( information ), pointer :: inf inf => oqp_handle_get_info ( c_handle ) call oqp_resp_charges ( inf ) end subroutine resp_charges_C !-------------------------------------------------------------------------------- !> @brief Compute ESP charges fitted by modified Merz-Kollman method !> @note  see refs: !>        B.Besler, K. Merz, P.Kollman, J. Comput. Chem., 11, 4, 431-439 (1990) !>        C.Bayly et. al., J. Phys. Chem., 97, 10269-10280 (1993) !> !> @param[in]      infos        OQP handle ! !> @author   Vladimir Mironov ! !     REVISION HISTORY: !> @date _Mar, 2023_ Initial release subroutine oqp_resp_charges ( infos ) use precision , only : dp use io_constants , only : iw use oqp_tagarray_driver use basis_tools , only : basis_set use messages , only : show_message , with_abort use types , only : information use strings , only : Cstring , fstring use mathlib , only : traceprod_sym_packed , triangular_to_full use int1 , only : electrostatic_potential use lebedev , only : lebedev_get_grid use elements , only : ELEMENTS_VDW_RADII implicit none character ( len =* ), parameter :: subroutine_name = \"oqp_resp_charges\" type ( information ), target , intent ( inout ) :: infos integer :: nbf , nbf2 , ok logical :: urohf type ( basis_set ), pointer :: basis real ( kind = dp ), allocatable :: xyz (:,:), wt (:), pot (:) real ( kind = dp ), allocatable :: leb (:,:), lebw (:) real ( kind = dp ), allocatable :: vdwrad (:) real ( kind = dp ), allocatable :: chg (:) integer , allocatable :: neigh (:) real ( kind = dp ) :: rms real ( kind = dp ), allocatable :: den (:) real ( kind = dp ), allocatable :: q0 (:), alpha (:) integer :: nat , npt , nptcur , nadd , nleb integer :: i , layer integer , parameter :: nlayers = 4 real ( kind = dp ), parameter :: & layers ( nlayers ) = [ 1.4 , 1.6 , 1.8 , 2.0 ] integer , parameter :: npt_layer ( nlayers ) = [ 132 , 152 , 192 , 350 ] integer , parameter :: typ_layer ( nlayers ) = [ 3 , 3 , 3 , 0 ] logical :: restr ! tagarray real ( kind = dp ), contiguous , pointer :: dmat_a (:), dmat_b (:) character ( len =* ), parameter :: tags_alpha ( 1 ) = ( / character ( len = 80 ) :: & OQP_DM_A / ) character ( len =* ), parameter :: tags_beta ( 2 ) = ( / character ( len = 80 ) :: & OQP_DM_A , OQP_DM_B / ) open ( unit = IW , file = infos % log_filename , position = \"append\" ) nat = ubound ( infos % atoms % zn , 1 ) select case ( infos % control % esp ) case ( 0 , 1 ) restr = . false . write ( iw , '(2/)' ) write ( iw , '(4x,a)' ) '=======================' write ( iw , '(4x,a)' ) 'ESP charges calculation' write ( iw , '(4x,a)' ) '=======================' case ( 2 ) restr = . true . allocate ( q0 ( nat ), alpha ( nat ), source = 0.0d0 ) alpha = infos % control % resp_constr select case ( infos % control % resp_target ) case ( 0 ) q0 = 0 !case(1) ! set Mulliken charges case default error stop 'Unknown RESP charges target' end select write ( iw , '(2/)' ) write ( iw , '(4x,a)' ) '========================' write ( iw , '(4x,a)' ) 'RESP charges calculation' write ( iw , '(4x,a)' ) '========================' case default error stop 'Unknown type of ESP charges calculation' end select call flush ( iw ) !   Load basis set basis => infos % basis basis % atoms => infos % atoms !   Allocate memory nbf = basis % nbf nbf2 = nbf * ( nbf + 1 ) / 2 npt = nat * sum ( npt_layer ) urohf = infos % control % scftype == 2 . or . infos % control % scftype == 3 allocate ( xyz ( npt , 3 ), & wt ( npt ), & pot ( npt ), & leb ( maxval ( npt_layer ), 3 ), & lebw ( maxval ( npt_layer )), & vdwrad ( nat ), & chg ( nat ), & neigh ( nat ), & den ( nbf2 ), & stat = ok ) if ( ok /= 0 ) call show_message ( 'Cannot allocate memory' , WITH_ABORT ) !   Set up the grid nptcur = 0 ! Current number of point in a grid !   Loop over layers and add spherical grid points on each atom to the molecular grid do layer = 1 , nlayers !     Get the atomic radii on which to place new grid layer vdwrad = ELEMENTS_VDW_RADII ( int ( infos % atoms % zn )) * layers ( layer ) !     Get grid nleb = npt_layer ( layer ) leb = 0 lebw = 0 call lebedev_get_grid ( nleb , leb , lebw , typ_layer ( layer )) !     Add new grid layer for each atom, remove inner points do i = 1 , nat call add_atom_grid ( & x = xyz ( nptcur + 1 :, 1 ), & y = xyz ( nptcur + 1 :, 2 ), & z = xyz ( nptcur + 1 :, 3 ), & wts = wt ( nptcur + 1 :), & nadd = nadd , & atpts = leb (: nleb ,:), & atwts = lebw (: nleb ), & atoms_xyz = infos % atoms % xyz , & atoms_rad = vdwrad , & cur_atom = i , & neighbours = neigh ) nptcur = nptcur + nadd end do end do !   Set all grid weights to be 1 for now wt = 1 deallocate ( leb , lebw , vdwrad , neigh ) !   Get density if ( urohf ) then call data_has_tags ( infos % dat , tags_beta , module_name , subroutine_name , WITH_ABORT ) call tagarray_get_data ( infos % dat , OQP_DM_A , dmat_a ) call tagarray_get_data ( infos % dat , OQP_DM_B , dmat_b ) den = dmat_a + dmat_b else call data_has_tags ( infos % dat , tags_alpha , module_name , subroutine_name , WITH_ABORT ) call tagarray_get_data ( infos % dat , OQP_DM_A , dmat_a ) den = dmat_a end if !   Compute electrostatic potential pot = 0 call electrostatic_potential ( basis , & x = xyz (: nptcur , 1 ), & y = xyz (: nptcur , 2 ), & z = xyz (: nptcur , 3 ), & wt = wt (: nptcur ), & d = den , & pot = pot ) deallocate ( den ) !   Add nuclei contribution to the potential call nuc_pot ( & x = xyz (: nptcur , 1 ), & y = xyz (: nptcur , 2 ), & z = xyz (: nptcur , 3 ), & w = wt (: nptcur ), & at = infos % atoms % xyz , & q = infos % atoms % zn - infos % basis % ecp_zn_num , & pot = pot (: nptcur )) !   Fit ESP charges call chg_fit_mk ( & x = xyz (: nptcur , 1 ), & y = xyz (: nptcur , 2 ), & z = xyz (: nptcur , 3 ), & w = wt (: nptcur ), & at = infos % atoms % xyz , & pot = pot (: nptcur ), & chgtot = real ( infos % mol_prop % charge , dp ), & chg = chg , & resp = restr , & q0 = q0 , & alpha = alpha & ) !   Print ESP charges call print_charges ( infos , chg ) !   Store RESP charges to a tagarray for JSON output / regression testing block real ( kind = dp ), contiguous , pointer :: chgout (:) call infos % dat % alloc_or_die ( OQP_resp_chg , ( / nat / ), chgout , & description = OQP_resp_chg_comment ) chgout ( 1 : nat ) = chg ( 1 : nat ) end block !   Compute RMS error of the ponential induced by ESP charges call check_charges ( & x = xyz (: nptcur , 1 ), & y = xyz (: nptcur , 2 ), & z = xyz (: nptcur , 3 ), & w = wt (: nptcur ), & at = infos % atoms % xyz , & chg = chg , & pot = pot (: nptcur ), & rms = rms ) write ( * , '(x,a,es20.6)' ) 'rms.err.=' , rms close ( iw ) end subroutine oqp_resp_charges !-------------------------------------------------------------------------------- !> @brief Add atomic-centered spherical grid to the molecular grid for ESP calculations !> @param[in,out]  x            X coordinates of a molecular grid !> @param[in,out]  y            Y coordinates of a molecular grid !> @param[in,out]  z            Z coordinates of a molecular grid !> @param[in,out]  wts          molecular grid weights !> @param[out]     nadd         number of points added !> @param[in]      atpts        atomic grid points (npts,3) !> @param[in]      atwts        atomic grid weights !> @param[in]      atoms_xyz    atomic coordinates !> @param[in]      atoms_rad    atomic radii == radii of the spherical grid !> @param[in]      cur_atom     id of the current atom !> @param[in,out]  neighbours   temporary array to store current atom neighbours list ! !> @detail Atoms are supposed to be speres with radii specified in atoms_rad. !>         Neighbours are atoms, intesecting with the current atom, i.e. D_ij < R_i + R_j !>         This subroutine adds only those points of the current atom, which are outside of spehres !>         of all other atoms ! !> @author   Vladimir Mironov ! !     REVISION HISTORY: !> @date _Mar, 2023_ Initial release subroutine add_atom_grid ( x , y , z , wts , nadd , atpts , atwts , atoms_xyz , atoms_rad , cur_atom , neighbours , excl_rad ) use precision , only : dp real ( kind = dp ), intent ( inout ) :: x (:), y (:), z (:), wts (:) real ( kind = dp ), intent ( in ) :: atpts (:,:), atwts (:) real ( kind = dp ), intent ( in ) :: atoms_xyz (:,:), atoms_rad (:) integer , intent ( in ) :: cur_atom integer , intent ( inout ) :: neighbours (:) integer , intent ( out ) :: nadd !> Optional fixed exclusion radii (one per atom).  When present, a !> candidate grid point is retained only if its distance from every !> neighbour atom nb exceeds excl_rad(nb).  When absent, atoms_rad is !> used for both shell placement AND exclusion (original behaviour). !> !> Passing base VDW radii here (rather than the layer-scaled atoms_rad) !> avoids the layer-scaled exclusion problem: with atoms_rad, outer-shell !> points can sit right at the lambda*r_vdw exclusion boundary of a !> neighbour, so small atomic displacements flip grid membership → !> non-smooth energy.  With a fixed base-VDW exclusion the outer shells !> are always safely inside the retaining region. real ( kind = dp ), optional , intent ( in ) :: excl_rad (:) integer :: nat , natpts , nngh , i , j , nb real ( kind = dp ) :: cur_xyz ( 3 ), ptxyz ( 3 ), rcur , dist2 real ( kind = dp ), allocatable :: excl (:) logical :: add nadd = 0 nat = ubound ( atoms_xyz , 2 ) natpts = ubound ( atpts , 1 ) cur_xyz = atoms_xyz (:, cur_atom ) rcur = atoms_rad ( cur_atom ) ! Exclusion radii: base VDW when provided, else layer-scaled atoms_rad allocate ( excl ( nat )) if ( present ( excl_rad )) then excl = excl_rad else excl = atoms_rad end if ! Find all neighbours of the current atom using placement radii (conservative). ! atoms_rad is layer-scaled (>= base VDW), so the search radius is never ! smaller than the exclusion radius -- no neighbour can be missed. nngh = 0 do i = 1 , nat if ( i == cur_atom ) cycle dist2 = sum (( atoms_xyz (:, i ) - cur_xyz (:)) ** 2 ) - ( atoms_rad ( i ) + rcur ) ** 2 if ( dist2 < 0 ) then nngh = nngh + 1 neighbours ( nngh ) = i end if end do ! Add only the points which are outside of the VDW shell of all other atoms do j = 1 , natpts add = . true . ptxyz = cur_xyz + rcur * atpts ( j ,:) ! Check if grid is outside all other atoms VDW spheres do i = 1 , nngh nb = neighbours ( i ) dist2 = sum (( atoms_xyz (:, nb ) - ptxyz ) ** 2 ) add = dist2 > excl ( nb ) ** 2 if (. not . add ) exit end do ! Add new point to the grid, increase the counter if ( add ) then nadd = nadd + 1 x ( nadd ) = ptxyz ( 1 ) y ( nadd ) = ptxyz ( 2 ) z ( nadd ) = ptxyz ( 3 ) wts ( nadd ) = atwts ( j ) end if end do end subroutine add_atom_grid !-------------------------------------------------------------------------------- !> @brief Compute nuclear potential of atoms on a grid !> @param[in]      x            X coordinates of a molecular grid !> @param[in]      y            Y coordinates of a molecular grid !> @param[in]      z            Z coordinates of a molecular grid !> @param[in]      w            molecular grid weights !> @param[in]      at           coordinates of atoms !> @param[in]      q            atomic nuclei charges !> @param[out]     pot          values of nuclear potential on a grid ! !> @author   Vladimir Mironov ! !     REVISION HISTORY: !> @date _Mar, 2023_ Initial release subroutine nuc_pot ( x , y , z , w , at , q , pot ) use precision , only : dp real ( kind = dp ), intent ( in ) :: x (:), y (:), z (:), w (:), at (:,:), q (:) real ( kind = dp ), intent ( out ) :: pot (:) integer :: i , j , nat , npts nat = ubound ( q , 1 ) npts = ubound ( x , 1 ) ! i - atoms ! j - grid pts ! pot_j = \\sum_i&#94;{N_{at}} w_j * Q_i / D_ji do j = 1 , npts do i = 1 , nat pot ( j ) = pot ( j ) & + w ( j ) * q ( i ) / norm2 ( at (:, i ) - [ x ( j ), y ( j ), z ( j )]) end do end do end subroutine nuc_pot !-------------------------------------------------------------------------------- !> @brief Compute ESP charges using generalized least-squares fit in LAPACK !> @param[in]      x            X coordinates of a molecular grid !> @param[in]      y            Y coordinates of a molecular grid !> @param[in]      z            Z coordinates of a molecular grid !> @param[in]      w            molecular grid weights (not used for now) !> @param[in]      at           coordinates of atoms !> @param[in]      pot          values of nuclear potential on a grid !> @param[in]      chgtot       total charge of the system !> @param[out]     chg          ESP charges of atoms ! !> @author   Vladimir Mironov ! !     REVISION HISTORY: !> @date _Mar, 2023_ Initial release subroutine chg_fit_glsq ( x , y , z , w , at , pot , chgtot , chg ) use precision , only : dp real ( kind = dp ), intent ( in ) :: x (:), y (:), z (:), w (:), at (:,:), pot (:), chgtot real ( kind = dp ), intent ( inout ) :: chg (:) integer :: i , j , nat , npts real ( kind = dp ), allocatable :: a (:,:), b (:), c (:) real ( kind = dp ), allocatable :: work (:) integer :: lwork , info real ( kind = dp ) :: rwork ( 1 ), d ( 1 ) nat = ubound ( at , 2 ) npts = ubound ( x , 1 ) allocate ( b ( nat ), c ( npts ), a ( npts , nat ), source = 0.0d0 ) ! Solve the problem: !    minimize || pot - D*chg ||_2 !    subject to \\sum(chg) = chgtot ! In LAPACK we need to formulate the contraint in the form B*x = d ! which will be: !   (1,1,1...1)&#94;T * chg = chgtot ! Compute the matrix of the inverse distances do i = 1 , nat do j = 1 , npts a ( j , i ) = 1 / norm2 ( at (:, i ) - [ x ( j ), y ( j ), z ( j )]) end do end do ! Copy target values for LAPACK c (: npts ) = pot ! Set up constraints b = 1 d ( 1 ) = chgtot ! Query required workspace call dgglse ( npts , nat , 1 , a , npts , b , 1 , c , d , chg , rwork , - 1 , info ) lwork = nint ( rwork ( 1 ), 8 ) allocate ( work ( lwork )) ! Solve the problem call dgglse ( npts , nat , 1 , a , npts , b , 1 , c , d , chg , work , lwork , info ) end subroutine chg_fit_glsq !-------------------------------------------------------------------------------- !> @brief Compute ESP charges using Merz-Kollman algorithm !> @details This subroutine uses the Lagrangian proposed by MK !>   See the following paper for details: !>   B.Besler, K. Merz, P.Kollman, J. Comput. Chem., 11, 4, 431-439 (1990) !> @param[in]      x            X coordinates of a molecular grid !> @param[in]      y            Y coordinates of a molecular grid !> @param[in]      z            Z coordinates of a molecular grid !> @param[in]      w            molecular grid weights (not used for now) !> @param[in]      at           coordinates of atoms !> @param[in]      pot          values of nuclear potential on a grid !> @param[in]      chgtot       total charge of the system !> @param[out]     chg          ESP charges of atoms !> @param[in]      resp         if .true., run restrainted ESP (RESP) fit !> @param[in]      q0           RESP target charges !> @param[in]      alpha        RESP constraints ! !> @author   Vladimir Mironov ! !     REVISION HISTORY: !> @date _Mar, 2023_ Initial release subroutine chg_fit_mk ( x , y , z , w , at , pot , chgtot , chg , resp , q0 , alpha ) use precision , only : dp real ( kind = dp ), intent ( in ) :: x (:), y (:), z (:), w (:), at (:,:), pot (:), chgtot real ( kind = dp ), intent ( inout ) :: chg (:) logical , optional , intent ( in ) :: resp real ( kind = dp ), optional , intent ( in ) :: q0 (:), alpha (:) integer , parameter :: RESP_MAX_ITER = 30 real ( kind = dp ), parameter :: RESP_TOL = 1.0d-5 logical , parameter :: debug = . false . integer :: i , j , nat , npts real ( kind = dp ), allocatable :: a (:,:), b (:), r (:,:) real ( kind = dp ), allocatable :: a_bak (:,:), b_bak (:) integer , allocatable :: ipiv (:) integer :: info logical :: do_resp real ( kind = dp ) :: diff do_resp = . false . if ( present ( resp )) do_resp = resp nat = ubound ( at , 2 ) npts = ubound ( x , 1 ) allocate ( a ( nat + 1 , nat + 1 ), b ( nat + 1 ), r ( nat , npts ), ipiv ( nat + 1 )) ! Compute the matrix of the inverse distances do j = 1 , npts do i = 1 , nat r ( i , j ) = 1 / norm2 ( at (:, i ) - [ x ( j ), y ( j ), z ( j )]) end do end do ! Compute the main part of the Lagrangian call dgemm ( 'n' , 't' , & nat , nat , npts , & 1.0_dp , r , nat , & r , nat , & 0.0_dp , a , nat + 1 ) ! Compute the part of the Lagrangian corresponding to the constraint: !   sum(chg) = chgtot a (:, nat + 1 ) = 1 a ( nat + 1 ,:) = 1 a ( nat + 1 , nat + 1 ) = 0 ! Compute the vector b call dgemv ( 'n' , nat , npts , 1.0_dp , r , nat , pot , 1 , 0.0_dp , b , 1 ) b ( nat + 1 ) = chgtot ! We don't need the inverse distance matrix anymore deallocate ( r ) ! Save the original A and b in case of RESP, because ! GESV will destroy them if ( do_resp ) then a_bak = a b_bak = b end if ! Solve linear equation A*chg = b call dgesv ( nat + 1 , 1 , a , nat + 1 , ipiv , b , nat + 1 , info ) chg (: nat ) = b (: nat ) ! Iterative solution of RESP equations if ( do_resp ) then do j = 1 , RESP_MAX_ITER ! Recover original A and b a = a_bak b = b_bak ! Add harmonic restraint contribution: do i = 1 , nat a ( i , i ) = a ( i , i ) + 2 * alpha ( i ) * ( q0 ( i ) - chg ( i )) end do b (: nat ) = b (: nat ) + 2 * q0 (: nat ) * alpha (: nat ) * ( q0 (: nat ) - chg (: nat )) ! Solve the equation: call dgesv ( nat + 1 , 1 , a , nat + 1 , ipiv , b , nat + 1 , info ) ! Check convergence of charges diff = maxval ( abs ( chg (: nat ) - b (: nat ))) if ( debug ) write ( * , '(X,A10,I4,A10,ES10.3)' ) 'resp iter=' , j , ' err=' , diff ! Copy the solution, exit if converged chg (: nat ) = b (: nat ) if ( diff < RESP_TOL ) exit end do end if end subroutine chg_fit_mk !-------------------------------------------------------------------------------- !> @brief Compute an RMS error of the pontential induced by atomic charges !> !> @param[in]      x            X coordinates of a molecular grid !> @param[in]      y            Y coordinates of a molecular grid !> @param[in]      z            Z coordinates of a molecular grid !> @param[in]      w            molecular grid weights !> @param[in]      at           coordinates of atoms !> @param[in]      chg          atomic partial charges !> @param[in]      pot          reference ponential values on a grid !> @param[out]     rms          RMS error ! !> @author   Vladimir Mironov ! !     REVISION HISTORY: !> @date _Mar, 2023_ Initial release subroutine check_charges ( x , y , z , w , at , chg , pot , rms ) use precision , only : dp real ( kind = dp ), intent ( in ) :: x (:), y (:), z (:), w (:), at (:,:), chg (:) real ( kind = dp ), intent ( in ) :: pot (:) real ( kind = dp ), intent ( out ) :: rms integer :: i , j , nat , npts real ( kind = dp ) :: v , vtot npts = ubound ( x , 1 ) nat = ubound ( chg , 1 ) vtot = 0 do j = 1 , npts v = 0 do i = 1 , nat v = v & + w ( j ) * chg ( i ) / norm2 ( at (:, i ) - [ x ( j ), y ( j ), z ( j )]) end do vtot = vtot + ( v - pot ( j )) ** 2 end do rms = sqrt ( vtot / npts ) end subroutine check_charges !-------------------------------------------------------------------------------- !> @brief Print partial charges !> !> @param[in]      infos        OQP handle !> @param[in]      chg          atomic partial charges ! !> @author   Vladimir Mironov ! !     REVISION HISTORY: !> @date _Mar, 2023_ Initial release subroutine print_charges ( infos , chg ) use precision , only : dp use elements , only : ELEMENTS_SHORT_NAME use types , only : information type ( information ), intent ( in ) :: infos real ( kind = dp ), intent ( in ) :: chg (:) integer :: i , elem , nat nat = ubound ( infos % atoms % zn , 1 ) write ( * , '(/,30(\"&#94;\"))' ) write ( * , '(/a8,a8,a14)' ) '#' , 'Name' , 'Charge' write ( * , '(30(\"-\"))' ) do i = 1 , nat elem = nint ( infos % atoms % zn ( i )) write ( * , '(i8,a8,f14.6)' ) i , ELEMENTS_SHORT_NAME ( elem ), chg ( i ) end do write ( * , '(30(\"=\"))' ) end subroutine print_charges end module resp_mod","tags":"","url":"sourcefile/resp.f90.html"},{"title":"mp2_lib.F90 – OpenQP Fortran API","text":"Source Code !> @file mp2_lib.F90 !> !> @brief Standalone Moller-Plesset second-order (MP2) ground-state correlation !>        energy for RHF/UHF/ROHF references. !> !> The correlation energy is built in the spin-blocked (aa, bb, ab) form on !> semicanonicalized orbitals, reusing the validated two-electron driver !> (`int2_compute`) via per-occupied-MO-pair Coulomb builds -- so no full O(N&#94;4) !> MO integral tensor is ever stored.  A ROHF reference is semicanonicalized first !> (occ-occ and vir-vir Fock blocks diagonalized) so the canonical MP2 amplitude !> denominators are well defined.  Validated to 1e-8 Ha against PySCF UMP2. module mp2_lib use precision , only : dp implicit none private public :: mp2_correlation !> Default guard on the number of per-MO-pair Coulomb builds the correlation !> assembly performs (nocc*nvir over both spins); overridable at run time via !> OQP_MP2_MAX_JBUILDS.  Prevents an accidental large number of J-builds. integer , parameter :: MAX_JBUILDS = 4000 contains !> .true. when the per-MO-pair Coulomb-build count for this reference is within !> MAX_JBUILDS (overridable via OQP_MP2_MAX_JBUILDS). logical function mp2_build_is_affordable ( nbf , nocca , noccb ) result ( ok ) integer , intent ( in ) :: nbf , nocca , noccb integer :: vira , virb , nbuild , cap , ln character ( len = 32 ) :: sval vira = nbf - nocca virb = nbf - noccb nbuild = max ( 0 , nocca * vira ) + max ( 0 , noccb * virb ) cap = MAX_JBUILDS call get_environment_variable ( \"OQP_MP2_MAX_JBUILDS\" , sval , ln ) if ( ln > 0 ) read ( sval , * , iostat = ln ) cap ok = ( nbuild > 0 ) . and . ( nbuild <= cap ) end function mp2_build_is_affordable subroutine mp2_correlation ( infos , e_mp2 , e_aa , e_bb , e_ab , computed ) use types , only : information use basis_tools , only : basis_set use int2_compute , only : int2_compute_t use messages , only : show_message , with_abort use oqp_tagarray_driver , only : tagarray_get_data , & OQP_VEC_MO_A , OQP_VEC_MO_B , & OQP_FOCK_A , OQP_FOCK_B type ( information ), target , intent ( inout ) :: infos real ( kind = dp ), intent ( out ) :: e_mp2 , e_aa , e_bb , e_ab logical , intent ( out ) :: computed type ( basis_set ), pointer :: basis type ( int2_compute_t ) :: int2_driver real ( kind = dp ), contiguous , pointer :: mo_a (:,:), mo_b (:,:) real ( kind = dp ), contiguous , pointer :: fock_a (:), fock_b (:) ! Semicanonical orbitals/energies (occ-occ and vir-vir Fock blocks ! diagonalized) -- required for a standard ROHF/UHF MP2. real ( kind = dp ), allocatable :: mo_a_sc (:,:), mo_b_sc (:,:) real ( kind = dp ), allocatable :: e_a_sc (:), e_b_sc (:) integer :: nbf , nbf2 , nocca , noccb , vira , virb , ok real ( kind = dp ) :: e_opp_scratch real ( kind = dp ) :: ss_scale , os_scale logical :: restricted_ref , need_same_spin , need_opposite_spin e_mp2 = 0.0_dp ; e_aa = 0.0_dp ; e_bb = 0.0_dp ; e_ab = 0.0_dp computed = . false . basis => infos % basis basis % atoms => infos % atoms nbf = basis % nbf nbf2 = nbf * ( nbf + 1 ) / 2 nocca = infos % mol_prop % nelec_a noccb = infos % mol_prop % nelec_b vira = nbf - nocca virb = nbf - noccb if (. not . mp2_build_is_affordable ( nbf , nocca , noccb )) return call tagarray_get_data ( infos % dat , OQP_VEC_MO_A , mo_a ) call tagarray_get_data ( infos % dat , OQP_FOCK_A , fock_a ) restricted_ref = ( infos % control % scftype == 1 ) if ( restricted_ref ) then mo_b => mo_a fock_b => fock_a else call tagarray_get_data ( infos % dat , OQP_VEC_MO_B , mo_b ) call tagarray_get_data ( infos % dat , OQP_FOCK_B , fock_b ) end if ss_scale = infos % dft % MP2SS_Scale os_scale = infos % dft % MP2OS_Scale need_same_spin = abs ( ss_scale ) > 1.0e-14_dp need_opposite_spin = abs ( os_scale ) > 1.0e-14_dp ! Semicanonicalize each spin so the MP2 denominators use canonical orbital ! energies (Fock occ-occ / vir-vir sub-blocks diagonalized).  For a UHF ! reference this is a no-op (orbitals already canonical); for ROHF it yields ! the standard ROHF-MP2 amplitudes. allocate ( mo_a_sc ( nbf , nbf ), mo_b_sc ( nbf , nbf ), e_a_sc ( nbf ), e_b_sc ( nbf ), & source = 0.0_dp , stat = ok ) if ( ok /= 0 ) call show_message ( 'mp2: cannot allocate semicanonical MOs' , with_abort ) call semicanonicalize ( nbf , nocca , mo_a , fock_a , mo_a_sc , e_a_sc ) call semicanonicalize ( nbf , noccb , mo_b , fock_b , mo_b_sc , e_b_sc ) call int2_driver % init ( basis , infos ) call int2_driver % set_screening () ! Same-spin alpha block + opposite-spin block share the alpha (i,a) Coulomb ! builds, so they are accumulated together. call mp2_spin_block ( int2_driver , basis , nbf , nbf2 , & mo_a_sc , e_a_sc , nocca , vira , & ! \"left\"  = alpha occ/vir mo_a_sc , e_a_sc , nocca , vira , & ! same-spin partner = alpha mo_b_sc , e_b_sc , noccb , virb , & ! opposite-spin partner = beta same_spin = need_same_spin , do_opposite = need_opposite_spin , & e_same = e_aa , e_opp = e_ab ) ! Same-spin beta block (opposite-spin already counted once above). e_opp_scratch = 0.0_dp call mp2_spin_block ( int2_driver , basis , nbf , nbf2 , & mo_b_sc , e_b_sc , noccb , virb , & mo_b_sc , e_b_sc , noccb , virb , & mo_a_sc , e_a_sc , nocca , vira , & same_spin = need_same_spin , do_opposite = . false ., & e_same = e_bb , e_opp = e_opp_scratch ) deallocate ( mo_a_sc , mo_b_sc , e_a_sc , e_b_sc ) call int2_driver % clean () e_mp2 = ss_scale * ( e_aa + e_bb ) + os_scale * e_ab computed = . true . end subroutine mp2_correlation subroutine mp2_spin_block ( int2_driver , basis , nbf , nbf2 , & cmo_l , e_l , nocc_l , nvir_l , & cmo_s , e_s , nocc_s , nvir_s , & cmo_o , e_o , nocc_o , nvir_o , & same_spin , do_opposite , e_same , e_opp ) use basis_tools , only : basis_set use int2_compute , only : int2_compute_t , int2_urohf_data_t use mathlib , only : pack_matrix , unpack_matrix use messages , only : show_message , WITH_ABORT type ( int2_compute_t ), intent ( inout ) :: int2_driver type ( basis_set ), intent ( in ) :: basis integer , intent ( in ) :: nbf , nbf2 real ( kind = dp ), intent ( in ) :: cmo_l ( nbf , nbf ), e_l ( nbf ) integer , intent ( in ) :: nocc_l , nvir_l real ( kind = dp ), intent ( in ) :: cmo_s ( nbf , nbf ), e_s ( nbf ) integer , intent ( in ) :: nocc_s , nvir_s real ( kind = dp ), intent ( in ) :: cmo_o ( nbf , nbf ), e_o ( nbf ) integer , intent ( in ) :: nocc_o , nvir_o logical , intent ( in ) :: same_spin , do_opposite real ( kind = dp ), intent ( inout ) :: e_same , e_opp type ( int2_urohf_data_t ), target :: int2_data real ( kind = dp ), allocatable , target :: pdmat (:,:) real ( kind = dp ), allocatable :: dfull (:,:), jfull (:,:), scr (:,:), jpack (:) ! same_block(a,b,j) = (i a | j b) for one occupied i. real ( kind = dp ), allocatable :: same_block (:,:,:) real ( kind = dp ), allocatable :: gopp (:,:) integer :: i , a , j , b , ii , ok real ( kind = dp ) :: denom , num allocate ( pdmat ( nbf2 , 2 ), dfull ( nbf , nbf ), jfull ( nbf , nbf ), scr ( nbf , nbf ), & jpack ( nbf2 ), source = 0.0_dp , stat = ok ) if ( ok /= 0 ) call show_message ( 'mp2: cannot allocate J-build scratch' , WITH_ABORT ) if ( same_spin . and . ( nocc_s /= nocc_l . or . nvir_s /= nvir_l )) then call show_message ( 'mp2: inconsistent same-spin dimensions' , WITH_ABORT ) end if if ( same_spin ) then allocate ( same_block ( nvir_l , nvir_s , nocc_s ), source = 0.0_dp , stat = ok ) if ( ok /= 0 ) call show_message ( 'mp2: cannot allocate same-spin block' , WITH_ABORT ) end if if ( do_opposite ) then allocate ( gopp ( nocc_o , nvir_o ), source = 0.0_dp , stat = ok ) if ( ok /= 0 ) call show_message ( 'mp2: cannot allocate opp-spin block' , WITH_ABORT ) end if do i = 1 , nocc_l if ( same_spin ) same_block = 0.0_dp do a = 1 , nvir_l ! Rank-1 symmetric AO density of MO_i (x) MO_(occ+a) (left spin). call rank1_sym_density ( cmo_l (:, i ), cmo_l (:, nocc_l + a ), nbf , dfull ) call pack_matrix ( dfull , pdmat (:, 1 ), 'U' ) pdmat (:, 2 ) = 0.0_dp int2_data = int2_urohf_data_t ( nfocks = 2 , d = pdmat , scale_exchange = 0.0_dp ) call int2_driver % run ( int2_data ) ! The packed Fock accumulator stores OFF-DIAGONAL elements doubled and ! the DIAGONAL untouched (same convention as scf_addons::fock_jk): the ! true matrix is 0.5*f off-diagonal, f on the diagonal.  Recover it ! before unpacking so J(D) = (mu nu | i a) has the correct magnitude. jpack (:) = 0.5_dp * int2_data % f (:, 1 , 1 ) ii = 0 do j = 1 , nbf ii = ii + j jpack ( ii ) = 2.0_dp * jpack ( ii ) end do call unpack_matrix ( jpack , jfull , 'U' ) call int2_data % clean () if ( same_spin ) then ! Same-spin: (i a | j b) = MO_j&#94;T J MO_(occ+b), all j,b of left spin. ! scr = J * C_occ(left)  -> (nbf, nocc_s) call dgemm ( 'n' , 'n' , nbf , nocc_s , nbf , 1.0_dp , jfull , nbf , & cmo_s , nbf , 0.0_dp , scr , nbf ) do j = 1 , nocc_s do b = 1 , nvir_s ! (i a | j b) = sum_mu C_(occ+b)(mu) * scr(mu,j) same_block ( a , b , j ) = dot_product ( cmo_s (:, nocc_s + b ), scr (:, j )) end do end do end if if ( do_opposite ) then ! Opposite spin: (i a | j b) with j,b on the OTHER spin. call dgemm ( 'n' , 'n' , nbf , nocc_o , nbf , 1.0_dp , jfull , nbf , & cmo_o , nbf , 0.0_dp , scr , nbf ) do j = 1 , nocc_o do b = 1 , nvir_o gopp ( j , b ) = dot_product ( cmo_o (:, nocc_o + b ), scr (:, j )) end do end do do j = 1 , nocc_o do b = 1 , nvir_o denom = e_l ( i ) + e_o ( j ) - e_l ( nocc_l + a ) - e_o ( nocc_o + b ) if ( abs ( denom ) < 1.0e-10_dp ) cycle e_opp = e_opp + gopp ( j , b ) * gopp ( j , b ) / denom end do end do end if end do ! Same-spin contraction with antisymmetrized integrals.  Only the ! virtual-virtual blocks for the current occupied i are retained, avoiding ! the previous (nocc*nvir)&#94;2 tensor. if ( same_spin ) then do j = 1 , nocc_s do a = 1 , nvir_l do b = 1 , nvir_s denom = e_l ( i ) + e_s ( j ) - e_l ( nocc_l + a ) - e_s ( nocc_s + b ) if ( abs ( denom ) < 1.0e-10_dp ) cycle ! <ij||ab> = (ia|jb) - (ib|ja) num = same_block ( a , b , j ) - same_block ( b , a , j ) e_same = e_same + 0.25_dp * num * num / denom end do end do end do end if end do deallocate ( pdmat , dfull , jfull , scr , jpack ) if ( allocated ( same_block )) deallocate ( same_block ) if ( allocated ( gopp )) deallocate ( gopp ) end subroutine mp2_spin_block subroutine rank1_sym_density ( u , v , nbf , dfull ) real ( kind = dp ), intent ( in ) :: u ( nbf ), v ( nbf ) integer , intent ( in ) :: nbf real ( kind = dp ), intent ( out ) :: dfull ( nbf , nbf ) integer :: mu , nu do nu = 1 , nbf do mu = 1 , nbf dfull ( mu , nu ) = 0.5_dp * ( u ( mu ) * v ( nu ) + u ( nu ) * v ( mu )) end do end do end subroutine rank1_sym_density subroutine semicanonicalize ( nbf , nocc , cmo , fock_packed , cmo_sc , e_sc ) use mathlib , only : unpack_matrix use eigen , only : diag_symm_full use messages , only : show_message , with_abort integer , intent ( in ) :: nbf , nocc real ( kind = dp ), intent ( in ) :: cmo ( nbf , nbf ) real ( kind = dp ), intent ( in ) :: fock_packed (:) real ( kind = dp ), intent ( out ) :: cmo_sc ( nbf , nbf ) real ( kind = dp ), intent ( out ) :: e_sc ( nbf ) real ( kind = dp ), allocatable :: fao (:,:), fmo (:,:), scr (:,:), blk (:,:), eval (:) integer :: nvir , ok nvir = nbf - nocc allocate ( fao ( nbf , nbf ), fmo ( nbf , nbf ), scr ( nbf , nbf ), eval ( nbf ), source = 0.0_dp , stat = ok ) if ( ok /= 0 ) call show_message ( 'mp2: semicanonical alloc failed' , with_abort ) ! F_mo = C&#94;T F_ao C call unpack_matrix ( fock_packed , fao , 'U' ) call dgemm ( 'n' , 'n' , nbf , nbf , nbf , 1.0_dp , fao , nbf , cmo , nbf , 0.0_dp , scr , nbf ) call dgemm ( 't' , 'n' , nbf , nbf , nbf , 1.0_dp , cmo , nbf , scr , nbf , 0.0_dp , fmo , nbf ) cmo_sc = cmo e_sc = 0.0_dp ! --- occupied-occupied block --- if ( nocc > 0 ) then allocate ( blk ( nocc , nocc ), source = 0.0_dp , stat = ok ) if ( ok /= 0 ) call show_message ( 'mp2: occ block alloc failed' , with_abort ) blk = fmo ( 1 : nocc , 1 : nocc ) call diag_symm_full ( 1 , nocc , blk , nocc , eval ( 1 : nocc )) ! blk now holds eigenvectors (columns); rotate occupied MOs. call dgemm ( 'n' , 'n' , nbf , nocc , nocc , 1.0_dp , cmo (:, 1 : nocc ), nbf , & blk , nocc , 0.0_dp , cmo_sc (:, 1 : nocc ), nbf ) e_sc ( 1 : nocc ) = eval ( 1 : nocc ) deallocate ( blk ) end if ! --- virtual-virtual block --- if ( nvir > 0 ) then allocate ( blk ( nvir , nvir ), source = 0.0_dp , stat = ok ) if ( ok /= 0 ) call show_message ( 'mp2: vir block alloc failed' , with_abort ) blk = fmo ( nocc + 1 : nbf , nocc + 1 : nbf ) call diag_symm_full ( 1 , nvir , blk , nvir , eval ( 1 : nvir )) call dgemm ( 'n' , 'n' , nbf , nvir , nvir , 1.0_dp , cmo (:, nocc + 1 : nbf ), nbf , & blk , nvir , 0.0_dp , cmo_sc (:, nocc + 1 : nbf ), nbf ) e_sc ( nocc + 1 : nbf ) = eval ( 1 : nvir ) deallocate ( blk ) end if deallocate ( fao , fmo , scr , eval ) end subroutine semicanonicalize end module mp2_lib","tags":"","url":"sourcefile/mp2_lib.f90.html"},{"title":"huckel.F90 – OpenQP Fortran API","text":"Source Code module huckel use precision , only : dp use oqp_linalg implicit none private public huckel_guess public orthogonalize_orbitals contains !> @brief Compute an extended Huckel initial guess in the input basis set ! !> @details The guess is obtained in three steps: !>   1. run an extended Huckel calculation in a minimal (MINI) basis set, !>   2. project the occupied (and a few virtual) Huckel MOs onto the !>      canonical orbitals of the input basis, !>   3. orthonormalize the result. ! !> @param[in]     ovl           overlap matrix of the input basis, packed !> @param[in,out] orbitals      guess orbitals on exit, (nbf x nbf) !> @param[in]     infos         OQP run information !> @param[in]     basis         input basis set !> @param[in]     huckel_basis  minimal basis set used for the Huckel step !> @param[in]     modified      use the energy-weighted Wolfsberg-Helmholz !>                              formula (default: .false.) !> @param[out]    mo_energy     optional, approximate orbital energies of the !>                              guess: the Huckel eigenvalues for the first !>                              nproj (projected) orbitals, zero for the rest subroutine huckel_guess ( ovl , orbitals , infos , basis , huckel_basis , modified , mo_energy ) use constants , only : tol_int use types , only : information use messages , only : show_message , WITH_ABORT use qmat_cache , only : get_qmat_cached use basis_tools , only : basis_set use int1 , only : basis_overlap use guess , only : corresponding_orbital_projection implicit none type ( information ), intent ( inout ) :: infos type ( basis_set ), intent ( in ) :: basis , huckel_basis logical , intent ( in ), optional :: modified real ( kind = dp ), intent ( out ), optional :: mo_energy (:) real ( kind = dp ) :: ovl ( * ), orbitals ( * ) integer :: nat , i , ok , l0 , l0co , nbf , nbf_co , nact , ndoc , nproj logical :: use_modified real ( kind = dp ), allocatable :: q (:) real ( kind = dp ), allocatable :: vec (:,:) real ( kind = dp ), allocatable :: sco (:,:) real ( kind = dp ), allocatable :: heig (:) nbf = basis % nbf nat = infos % mol_prop % natom !  Number of orbitals in MINI basis used in Huckel nbf_co = huckel_basis % nbf allocate ( q ( nbf * nbf ), & vec ( nbf_co , nbf_co ), & sco ( nbf_co , nbf ), & stat = ok ) if ( ok /= 0 ) call show_message ( 'Cannot allocate memory' , WITH_ABORT ) !  Step 1: overlap between the minimal (Huckel) basis set and the !  input basis set, S_co(i_mini, j_input). It connects the two spaces !  and drives the corresponding-orbital projection below. call basis_overlap ( sco , basis , huckel_basis , tol = log ( 1 0.0d0 ) * tol_int ) !  Apply the basis function normalization factors of both basis sets do i = 1 , nbf sco (:, i ) = sco (:, i ) * basis % bfnrm ( i ) * huckel_basis % bfnrm end do !  Step 2: decide how many orbitals to take over from the Huckel !  calculation: ndoc doubly occupied + nact singly occupied (ROHF/UHF) ndoc = 0 nact = 0 if ( infos % control % scftype == 1 ) then ndoc = infos % mol_prop % nelec / 2 else if ( infos % control % scftype >= 2 ) then ndoc = infos % mol_prop % nelec_b nact = infos % mol_prop % nelec_a - infos % mol_prop % nelec_b end if use_modified = . false . if ( present ( modified )) use_modified = modified !  Step 3: extended Huckel calculation in the minimal basis set; !  returns the Huckel MOs (vec) and their orbital energies (heig) allocate ( heig ( nbf_co ), source = 0.0_dp ) call huckel_calc ( huckel_basis , vec , l0co , nat , infos % atoms % zn , tol_int , use_modified , heig ) !  Project all occupied orbitals plus at most 5 Huckel virtuals; !  higher Huckel virtuals in a minimal basis carry no useful structure nproj = min ( l0co , ndoc + nact + 5 ) !  The first nproj guess orbitals correspond to the Huckel MOs !  in order; export their energies as approximate MO energies if ( present ( mo_energy )) then mo_energy = 0.0_dp mo_energy ( 1 : min ( nproj , size ( mo_energy ))) = heig ( 1 : min ( nproj , size ( mo_energy ))) end if !  Step 4: canonical orthonormal orbitals Q = S&#94;(-1/2) of the input !  basis (cached for reuse by the SCF setup); they serve both as the !  starting set to be rotated and as the orthogonalizer. l0 <= nbf is !  the number of linearly independent combinations. call get_qmat_cached ( infos , ovl , q , nbf , qrnk = l0 ) orbitals ( 1 : nbf * nbf ) = q ( 1 : nbf * nbf ) !  Step 5: rotate the canonical orbitals so that the first nproj of !  them have maximum overlap with the Huckel MOs (King-Stanton !  corresponding orbital transformation) call corresponding_orbital_projection ( vec , sco , orbitals , ndoc , nact , nproj , nbf , nbf_co , l0 ) !  Step 6: re-orthonormalize: the first nproj orbitals are kept (QR), !  the remaining ones are rebuilt as their orthogonal complement call orthogonalize_orbitals ( q , ovl , orbitals , nproj , l0 , nbf , nbf ) end subroutine huckel_guess !> @brief   Extended Huckel calculation in a Huzinaga minimal basis set ! !> @param[in]  basis     minimal (MINI) basis set !> @param[out] vec       Huckel MOs in the (Cartesian) minimal basis !> @param[out] l0co      number of linearly independent spherical-harmonic !>                       basis functions !> @param[in]  nat       number of atoms !> @param[in]  zan       nuclear charges !> @param[in]  tol_int   integral tolerance (powers of 10) !> @param[in]  modified  use the energy-weighted Wolfsberg-Helmholz formula subroutine huckel_calc ( basis , vec , l0co , nat , zan , tol_int , modified , energies ) use eigen , only : diag_symm_full use mathlib , only : unpack_matrix , orthogonal_transform_sym use messages , only : show_message , WITH_ABORT use basis_tools , only : basis_set use guess , only : mksphar use int1 , only : overlap implicit none type ( basis_set ), intent ( in ) :: basis real ( kind = dp ), intent ( out ) :: vec (:,:) integer , intent ( out ) :: l0co integer , intent ( in ) :: nat , tol_int real ( kind = dp ), intent ( in ) :: zan (:) logical , intent ( in ) :: modified real ( kind = dp ), intent ( out ), optional :: energies (:) !   Scale-down factor for core/core and core/valence overlaps real ( kind = dp ), parameter :: BITSY = 0.05d+00 !   Wolfsberg-Helmholz constant real ( kind = dp ), parameter :: WH_K = 1.75d+00 real ( kind = dp ) :: delta , kij , hsum integer :: l1co , l2co , i , j , ierr logical :: notsp real ( kind = dp ), allocatable :: h2 (:,:) real ( kind = dp ), allocatable :: eig (:), h (:), s (:) real ( kind = dp ), allocatable :: tsh (:), q (:,:) integer , allocatable :: llim (:), iulim (:) logical , allocatable :: core (:) l1co = basis % nbf l2co = ( l1co * l1co + l1co ) / 2 allocate ( h2 ( l1co , l1co ), & eig ( l1co ), & h ( l2co ), & s ( l2co ), & tsh ( l1co * l1co ), & q ( l1co , l1co ), & source = 0.0d0 ) allocate ( llim ( nat ), iulim ( nat ), source = 0 ) allocate ( core ( l1co ), source = . false .) !   set lower and upper basis functions on each atom, !   counting is done in terms of spherical harmonics. call get_atom_ao_limits ( basis , llim , iulim ) !   Compute the minimal basis set's overlap matrix (packed storage) call overlap ( s , basis , log ( 1 0.0d0 ) * tol_int ) !   Transform the overlap matrix to spherical harmonic form: the !   Huckel parameter tables count orbitals in spherical harmonics !   (5d/7f), while the basis may be Cartesian (6d/10f). tsh is the !   Cartesian -> spherical transformation; l0co <= l1co is the number !   of spherical-harmonic functions; notsp = any d/f shells present. call mksphar ( tsh , l1co , l0co , notsp , basis ) if ( notsp ) then call orthogonal_transform_sym ( l1co , l0co , s , tsh , l1co , h ) s ( 1 : l2co ) = h ( 1 : l2co ) end if !   obtain canonical orthonormal MOs -Q- for the minimal basis set: !   diagonalize S and scale the eigenvectors by 1/sqrt(eigenvalue), !   so that Q&#94;T S Q = 1 (used to orthonormalize the Huckel MOs below) call unpack_matrix ( s , q ) call diag_symm_full ( 1 , l0co , q , l1co , eig , ierr ) do i = 1 , l0co q (:, i ) = q (:, i ) / sqrt ( eig ( i )) end do !   construct the extended Huckel operator -H- directly on top of !   a copy of the overlap -S- in spherical harmonic space. call unpack_matrix ( s , h2 ) !   set the diagonal to atomic core/valence orbital energies call set_diagonal_energies ( h2 , core , llim , iulim , zan ) !   Generate the off-diagonal of the extended Huckel operator using the !   Wolfsberg-Helmholz formula: !     H_ij = 1/2 * K_ij * (H_ii + H_jj) * S_ij !   Standard:  K_ij = K = 1.75 !   Modified (weighted), cf. Ammeter et al., J. Am. Chem. Soc. 100, 3686 !   (1978) and Psi4's MODHUCKEL guess: !     K_ij = K + d**2 + d**4*(1-K),  d = (H_ii - H_jj)/(H_ii + H_jj) !   The energy-dependent K_ij reduces overbinding for orbitals of very !   different energies and yields a sharper guess than constant-K GWH. ! !   In view of the very large core orbital energies, all core/core and !   core/valence overlaps are first scaled down by BITSY, to reduce the !   amount of mixing of these types. ! !   Note on the choice of BITSY: alternatives were benchmarked on a !   10-molecule HF/cc-pVDZ set (H2O, NH3, H2S, PH3, SO2, PCl3, SiCl4, !   CS2, HCl, ClF), counting SCF iterations to 1.0e-8 convergence: !     - flat BITSY in {0.0, 0.01, 0.05, 0.1, 0.2}: identical within !       +/-1 iteration everywhere except SiCl4 (29 -> 21 for 0.2); !     - energy-dependent damping, 2*sqrt(|Hii*Hjj|)/(|Hii|+|Hjj|): !       no gain on average, catastrophic for SiCl4 (73 iterations); !     - weaker core/core than core/valence damping: worse (SiCl4: 43). !   The guess is largely insensitive to BITSY, so the long-standing !   default of 0.05 is kept. do i = 2 , l0co do j = 1 , i - 1 if ( core ( i ). or . core ( j )) h2 ( j , i ) = BITSY * h2 ( j , i ) hsum = h2 ( i , i ) + h2 ( j , j ) kij = WH_K if ( modified . and . abs ( hsum ) > tiny ( 1.0d0 )) then delta = ( h2 ( i , i ) - h2 ( j , j )) / hsum kij = WH_K + delta * delta + delta ** 4 * ( 1.0d0 - WH_K ) end if h2 ( j , i ) = 0.5d0 * kij * h2 ( j , i ) * hsum end do end do call diag_symm_full ( 1 , l0co , h2 , l1co , eig , ierr ) if ( ierr /= 0 ) call show_message ( 'Huckel MBS diagonalization failure' , WITH_ABORT ) !   export the Huckel orbital energies (ascending); the caller maps !   them onto the corresponding projected guess orbitals if ( present ( energies )) then energies = 0.0_dp energies ( 1 : min ( l0co , size ( energies ))) = eig ( 1 : min ( l0co , size ( energies ))) end if !   orthonormalize the Huckel MOs in the metric of the overlap matrix call orthogonalize_orbitals ( q , s , h2 , l0co , l0co , l1co , l1co ) !   backtransform from spherical harmonics to the Cartesian minimal !   basis, in which the inter-basis overlap sco is expressed if ( notsp ) then call dgemm ( 'N' , 'N' , l1co , l0co , l0co ,& 1.0d0 , tsh , l1co , & h2 , l1co , & 0.0d0 , vec , l1co ) else vec = h2 end if end subroutine huckel_calc !> @brief First and last spherical-harmonic basis function of each atom ! !> @note Assumes the shells of one atom are contiguous ! !> @param[in]  basis  basis set !> @param[out] llim   index of the first basis function on each atom !> @param[out] iulim  index of the last basis function on each atom subroutine get_atom_ao_limits ( basis , llim , iulim ) use basis_tools , only : basis_set implicit none type ( basis_set ), intent ( in ) :: basis integer , intent ( out ) :: llim (:), iulim (:) integer :: iat , kat , ish llim = 0 iulim = 0 iat = 1 llim ( 1 ) = 1 do ish = 1 , basis % nshell kat = basis % origin ( ish ) if ( kat /= iat ) then llim ( kat ) = iulim ( iat ) + 1 iulim ( kat ) = iulim ( iat ) iat = kat end if iulim ( kat ) = iulim ( kat ) + 2 * basis % am ( ish ) + 1 end do end subroutine get_atom_ao_limits !> @brief Put atomic orbital energies on the diagonal of the Huckel operator ! !> @details For every (non-dummy) atom, the core and valence orbital !>          energies from the Huckel lookup tables are placed on the !>          diagonal of `h2`; basis functions describing core orbitals !>          are flagged in `core`. ! !> @param[in,out] h2     Huckel operator, diagonal is set on exit !> @param[out]    core   .true. for rows corresponding to core orbitals !> @param[in]     llim   index of the first basis function on each atom !> @param[in]     iulim  index of the last basis function on each atom !> @param[in]     zan    nuclear charges subroutine set_diagonal_energies ( h2 , core , llim , iulim , zan ) use messages , only : show_message , WITH_ABORT use huckel_lut , only : lneg => huckel_lneg implicit none real ( kind = dp ), intent ( inout ) :: h2 (:,:) logical , intent ( out ) :: core (:) integer , intent ( in ) :: llim (:), iulim (:) real ( kind = dp ), intent ( in ) :: zan (:) real ( kind = dp ) :: eneg ( 18 ) integer :: ncore , nval , ndval ( 4 ), atype integer :: n , nucz , i , j , i0 , j0 , irow , ival core = . false . do n = 1 , size ( llim ) nucz = int ( zan ( n )) !     skip dummy atoms if ( nucz == 0 ) cycle call huckel_get ( nucz , eneg , ncore , nval , ndval , atype ) !     set core orbital energies i0 = llim ( n ) - 1 do i = 1 , ncore irow = i0 + i h2 ( irow , irow ) = eneg ( lneg ( i , atype )) core ( irow ) = . true . end do !     set valence orbital energies. i0 = llim ( n ) + ncore - 1 j0 = 0 do j = 1 , nval ival = ndval ( j ) do i = 1 , ival irow = i0 + i h2 ( irow , irow ) = eneg ( lneg ( ncore + j0 + i , atype )) end do i0 = i0 + ival j0 = j0 + ival end do if ( iulim ( n ) - i0 > 0 ) then call show_message ( 'Huckel: confusion with MINI basis set' , WITH_ABORT ) end if end do end subroutine set_diagonal_energies !> @brief Orthogonalize orbitals !> @param[in]     q     matrix of 'canonical orbitals', (ndim x l0) !> @param[in]     s     symmetric overlap matrix (nbf x nbf), packed !> @param[in,out] v     orbitals to transform, (ndim x l0) !> @param[in]     n     defines, how many orbitals from V space to use !> @param[in]     l0    dimension of the 'canonical orbitals' space !> @param[in]     nbf    dimension of the AO basis, nbf >= l0 >= n !> @param[in]     ndim  leading dimension of q and v ! !> @details Orbital will be computed in three steps: !>   1. compute V = Q&#94;T * S * V !>   2. orthogonalize first `n` vectors from resulting 'V' space !>   3. back-transform V = Q*V ! subroutine orthogonalize_orbitals ( q , s , v , n , l0 , nbf , ndim ) use mathlib , only : unpack_matrix implicit none integer , intent ( in ) :: n , l0 , nbf , ndim real ( kind = dp ), intent ( in ) :: q ( ndim , * ), s ( * ) real ( kind = dp ), intent ( inout ) :: v ( ndim , * ) real ( kind = dp ), allocatable :: u (:,:), tmp (:,:), wrk (:) real ( kind = dp ) :: wrksize ( 1 ) integer :: lwork , info allocate ( u ( nbf , nbf ), tmp ( nbf , nbf )) ! query both routines so that dormqr can also run blocked ! (dormqr with side='r' requires lwork >= nbf as a minimum) call dgeqrf ( l0 , n , v , ndim , u , wrksize , - 1 , info ) lwork = max ( int ( wrksize ( 1 )), nbf ) call dormqr ( 'r' , 'n' , nbf , l0 , n , u , ndim , tmp , v , nbf , wrksize , - 1 , info ) lwork = max ( lwork , int ( wrksize ( 1 ))) allocate ( wrk ( lwork )) ! 1. Compute Q&#94;T * S * V, store in U call unpack_matrix ( s , u ) call dsymm ( 'l' , 'u' , nbf , n , & 1.0_dp , u , nbf , & v , ndim , & 0.0_dp , tmp , nbf ) call dgemm ( 't' , 'n' , l0 , n , nbf , & 1.0_dp , q , ndim , & tmp , nbf , & 0.0_dp , u , ndim ) ! 2. Orthogonalize orbitals in U call dgeqrf ( l0 , n , u , ndim , tmp , wrk , lwork , info ) ! The matrix of orthogonal orbitals U is now stored as a product of elementary reflectors ! 3. Transform V = Q*U v (:,: l0 ) = q (:,: l0 ) call dormqr ( 'r' , 'n' , nbf , l0 , n , u , ndim , tmp , v , nbf , wrk , lwork , info ) end subroutine orthogonalize_orbitals !>    @brief    return Huckel parameters for atom of charge NUCZ ! !>    @details  parameters are orbital energies, valence shell !>              info, and sometimes info about how to use a !>              minimal basis for semicore ECPs. ! !>    @param[in]  nucz     nuclear charge (atomic number) !>    @param[out] eneg     list of orbital energies for input atom `nucz` !>    @param[out] ncore    the number of core _orbitals_ !>    @param[out] nval     the number of valence _shells_ !>    @param[out] ndval    tells how many functions are in each valence shell !>    @param[out] atype    row of the `huckel_lneg` lookup table to use ! !>    @note `ncore` and `ndval` count d and f orbitals as containing 6 and 10 functions, respectively. subroutine huckel_get ( nucz , eneg , ncore , nval , ndval , atype ) use huckel_lut , only : huckel_eneg , huckel_ncore , huckel_nval , huckel_ndval use messages , only : show_message , WITH_ABORT implicit none integer , intent ( in ) :: nucz real ( kind = dp ), intent ( out ) :: eneg ( 18 ) integer , intent ( out ) :: ncore , nval , ndval ( 4 ), atype select case ( nucz ) case (: 0 ) ncore = 0 nval = 0 case ( 1 : 103 ) eneg = huckel_eneg (:, nucz ) ncore = huckel_ncore ( nucz ) nval = huckel_nval ( nucz ) ndval = huckel_ndval (:, nucz ) case default call show_message ( \"(A,I5)\" , \" Error!  This atom has nuclear charge \" , NUCZ ) call show_message ( \" Huckel parameters are unavailable past element Lr\" , WITH_ABORT ) end select select case ( nucz ) case (: 57 ) ; atype = 1 case ( 58 : 71 ) ; atype = 2 case ( 72 : 86 ) ; atype = 3 case ( 87 : 88 ) ; atype = 4 case ( 89 : 90 ) ; atype = 5 case ( 91 :) ; atype = 6 end select end subroutine huckel_get end module huckel","tags":"","url":"sourcefile/huckel.f90.html"},{"title":"scf_converger.F90 – OpenQP Fortran API","text":"Source Code !=============================================================================== ! MODULE: scf_converger !=============================================================================== ! ! DESCRIPTION: !   The scf_converger module implements a framework for managing convergence !   in Self-Consistent Field (SCF) calculations. It provides a main driver !   type `scf_conv` to coordinate multiple convergence methods, including !   variants of Direct Inversion in the Iterative Subspace (DIIS) and !   Second-Order SCF (SOSCF), storing iteration data in a ring buffer structure. ! ! MEMBERS: !   - conv_none  [INTEGER]: Constant (1) for no convergence method. !   - conv_cdiis [INTEGER]: Constant (2) for Commutator DIIS. !   - conv_ediis [INTEGER]: Constant (3) for Energy DIIS. !   - conv_adiis [INTEGER]: Constant (4) for Approximate DIIS. !   - conv_soscf [INTEGER]: Constant (5) for Second-Order SCF. !   - conv_state_not_initialized [INTEGER]: Constant (0) for uninitialized state. !   - conv_state_initialized     [INTEGER]: Constant (1) for initialized state. !   - conv_name_maxlen           [INTEGER]: Constant (32) for maximum length of converger names. ! ! DEPENDENCIES: !   - precision: Provides `dp` for double precision real numbers. !   - io_constants: Provides `iw` for output unit. !   - messages: Provides `show_message` and `with_abort` for error handling. !   - mathlib: Provides functions for matrix operations: !     `traceprod_sym_packed`: Calculates trace of product of two packed symmetric matrices. !     `orb_to_dens`: Converts orbitals to density matrix. !     `antisymmetrize_matrix`: Makes matrix antisymmetric (A = A - A&#94;T). !     `unpack_matrix`: Converts packed triangular to full square matrix. !     `pack_matrix`: Converts full square to packed triangular matrix. !   - `scf_addons`: Provides Pseudo-Fractional Occupation Number (pFON) functionality. ! ! DATA MANAGEMENT: !   The module uses a ring buffer system implemented in the `converger_data` type !   for efficiently storing SCF iteration history. This designimproves memory efficiency !   and data locality compared to traditional vector growth approaches. !   The buffer system supports both forward and backward indices for intuitive access !   (1 = oldest, -1 = latest). ! ! NOTES: !   - The module defines public types: `scf_conv`, `scf_conv_result`, and `soscf_converger`. !   - All other entities are private unless explicitly made public. !   - The code supports handling of Fock matrices for RHF/ROHF (1 matrix) and UHF (2 matrices). !   - ROHF Fock matrix has already gone through the Guest-Saunders transformation. !   - The module supports integration with the pFON (pseudo-Fractional Occupation Number) !     methodology. ! ! HISTORY: !   - [pre-2022] Initial Development - Vladimir Mironov !     Established the core framework for SCF convergence management, !     including the main driver `scf_conv` and initial DIIS methods. !   - [2025] Ring Buffer - Konstantin Komarov !     Implemented the ring buffer structure via the `converger_data` type, !     improving memory efficiency for storing SCF iteration history. !   - [2025] SOSCF Converger - Konstantin Komarov !     Added the Second-Order SCF (SOSCF) method through the `soscf_converger` type, !     enabling convergence using orbital optimization techniques. ! !=============================================================================== !=============================================================================== ! TYPE: scf_conv - MAIN DRIVER TYPE !=============================================================================== ! ! DESCRIPTION: !   The `scf_conv` type is the main driver for SCF convergence. It manages a !   ring buffer of iteration data via `converger_data`, maintains an array of !   subconvergers, and selects a convergence method based on the current error !   and predefined thresholds. ! ! MEMBERS: !   step          [INTEGER]: Current SCF iteration step. !   overlap       [REAL(dp), POINTER]: Pointer to the full-format overlap matrix (S). !   overlap_sqrt  [REAL(dp), POINTER]: Pointer to the full-format S&#94;(1/2) matrix. !   dat           [TYPE(converger_data)]: Stores SCF iteration history in a ring buffer. !   sconv         [TYPE(subconverger_), ALLOCATABLE]: Array of subconverger instances. !   thresholds    [REAL(dp), ALLOCATABLE]: Error thresholds for selecting subconvergers. !   iter_space_size [INTEGER]: Size of the subconverger problem space, default is 10. !   verbose       [INTEGER]: Verbosity level, default is 0. !   state         [INTEGER]: Current state (0 = not initialized, 1 = initialized), default is 0. !   current_error [REAL(dp)]: Maximum absolute value of the current DIIS error, default is 1.0e99_dp. ! ! METHODS: !   init          - Initializes the driver with iteration parameters and subconvergers. !   clean         - Deallocates resources and resets the driver. !   add_data      - Adds data from a new SCF iteration to the ring buffer. !   select_method - Selects the active subconverger based on the current error (private). !   run           - Executes the selected subconverger and returns a result. !   compute_error - Computes the current DIIS error (private). ! ! USAGE EXAMPLE IS BELOW. ! !=============================================================================== !=============================================================================== ! TYPE: converger_data - DATA MANAGEMENT TYPE !=============================================================================== ! ! DESCRIPTION: !   The `converger_data` type implements a ring buffer for efficient storage !   of SCF iteration history. It manages data locality and memory usage by !   maintaining a fixed-size circular buffer rather than continuously growing !   arrays, improving performance for calculations with many iterations. ! ! MEMBERS: !   slot          [INTEGER]: Current slot in the ring buffer (1-based index). !   num_saved     [INTEGER]: Number of occupied slots in the buffer. !   num_slots     [INTEGER]: Total capacity of the buffer. !   num_focks     [INTEGER]: Number of Fock matrices per iteration (1 for RHF/ROHF, 2 for UHF). !   ldim          [INTEGER]: Size of square matrices (nbf). !   nelec_a       [INTEGER]: Number of alpha electrons. !   nelec_b       [INTEGER]: Number of beta electrons. !   buffer        [TYPE(scf_data_t), ALLOCATABLE]: Array of SCF data containers. ! ! METHODS: !   init         - Initializes the ring buffer with specified dimensions. !   clean        - Deallocates buffer resources. !   next_slot    - Advances to the next slot in the buffer (private). !   discard_last - Removes the most recent iteration data (private). !   put          - Stores new SCF data in the current slot (private). !   get_fock     - Retrieves Fock matrix for specific iteration (private). !   get_mo_a     - Retrieves alpha MO coefficients (private). !   get_mo_b     - Retrieves beta MO coefficients (private). !   get_mo_e_a   - Retrieves alpha MO energies (private). !   get_mo_e_b   - Retrieves beta MO energies (private). !   get_pfon     - Retrieves pFON object pointer (private). !   get_density  - Retrieves density matrix (private). !   get_err      - Retrieves error matrix (private). !   get_energy   - Retrieves SCF energy (private). !   get_slot     - Computes slot index from iteration number (private). ! ! USAGE NOTES: !   - Data access supports both positive indices (1 = oldest) and !     negative indices (-1 = latest) for intuitive programming. !   - Each slot contains complete SCF iteration data including Fock matrices, !     density matrices, MO coefficients, energies, and error matrices. !   - Integration with pFON allows storage of fractional occupation data !     when dealing with challenging electronic structures. ! !=============================================================================== !=============================================================================== ! TYPE: subconverger - ABSTRACT BASE TYPE !=============================================================================== ! ! DESCRIPTION: !   The `subconverger` type is an abstract base type defining the interface !   for all convergence methods used by `scf_conv`. Each subtype must implement !   the deferred procedures `run` and `setup`. ! ! MEMBERS: !   last_setup [INTEGER]: Number of SCF iterations since last setup, default is 1024. !   iter       [INTEGER]: Number of iterations passed, default is 0. !   conv_name  [CHARACTER(len=32)]: Name of the converger, default is an empty string. !   dat        [TYPE(converger_data), POINTER]: Pointer to SCF data. ! ! METHODS: !   init  - Initializes the subconverger (implemented as `subconverger_init`). !   clean - Deallocates resources (implemented as `subconverger_clean`). !   run   - Executes the convergence method, returns a `scf_conv_result` (deferred). !   setup - Prepares the subconverger with new data (deferred). ! !=============================================================================== !=============================================================================== ! TYPE: noconv_converger - DUMMY CONVERGER !=============================================================================== ! ! DESCRIPTION: !   The `noconv_converger` type extends `subconverger` and implements a dummy !   convergence method that returns the latest iteration data without modification. ! ! METHODS: !   init  - Initializes with the parent `scf_conv` instance. !   run   - Returns the latest Fock matrix data in a `scf_conv_result`. !   setup - Does nothing (empty implementation). ! !=============================================================================== !=============================================================================== ! TYPE: cdiis_converger - COMMUTATOR DIIS !=============================================================================== ! ! DESCRIPTION: !   The `cdiis_converger` type extends `subconverger` and implements the !   Commutator DIIS (C-DIIS) method, solving a constrained minimization problem !   min { Ax, \\sum_i x_i = 1 } where A_{ij} = Tr([F_i D_i S_i], [F_j D_j S_j]). ! ! MEMBERS: !   maxdiis [INTEGER]: Maximum number of DIIS vectors. !   a       [REAL(dp), ALLOCATABLE]: C-DIIS A-matrix for error overlaps. !   verbose [INTEGER]: Verbosity level, default is 0. !   old_dim [INTEGER]: Dimension of A-matrix from the previous step, default is 0. ! ! METHODS: !   init  - Initializes the C-DIIS instance. !   clean - Deallocates the A-matrix. !   run   - Solves the DIIS equations and returns a `scf_conv_interp_result`. !   setup - Updates the A-matrix with new error data. ! !=============================================================================== !=============================================================================== ! TYPE: ediis_converger - ENERGY DIIS !=============================================================================== ! ! DESCRIPTION: !   The `ediis_converger` type extends `cdiis_converger` and implements the !   Energy DIIS (E-DIIS) method, optimizing the function !   E_E-DIIS = \\sum_i c_i E_i - 0.5 \\sum_{i,j} c_i c_j Tr((D_i-D_j)(F_i-F_j)) !   with constraints \\sum_i c_i = 1, c_i \\geq 0. ! ! MEMBERS: !   b    [REAL(dp), ALLOCATABLE]: Energy history from previous iterations. !   xlog [REAL(dp), ALLOCATABLE]: History of interpolation coefficients. !   t    [TYPE(ediis_opt_data)]: Optimization data structure for NLOpt. !   fun  [PROCEDURE(eadiis_f), POINTER]: Pointer to the objective function. ! ! METHODS: !   init  - Initializes the E-DIIS instance. !   clean - Deallocates additional arrays (b, xlog). !   setup - Prepares the optimization problem with energy and matrix data. !   run   - Solves the optimization problem and returns a `scf_conv_interp_result`. ! !=============================================================================== !=============================================================================== ! TYPE: adiis_converger - APPROXIMATE DIIS !=============================================================================== ! ! DESCRIPTION: !   The `adiis_converger` type extends `ediis_converger` and implements the !   Approximate DIIS (A-DIIS) method, optimizing the function !   E_A-DIIS = \\sum_i c_i Tr((D_i-D_n)F_n) + 2 \\sum_{i,j} c_i c_j Tr((D_i-D_n)(F_j-F_n)) !   with constraints \\sum_i c_i = 1, c_i \\geq 0. ! ! METHODS: !   init  - Initializes the A-DIIS instance (inherits from `ediis_converger`). !   setup - Prepares the modified optimization problem specific to A-DIIS. ! ! NOTES: !   - Inherits all members and most methods from `ediis_converger`. !   - Only `setup` is overridden to adjust the objective function. ! !=============================================================================== !=============================================================================== ! TYPE: soscf_converger - SECOND-ORDER SCF !=============================================================================== ! ! DESCRIPTION: !   The `soscf_converger` type extends `subconverger` and implements the !   Second-Order SCF (SOSCF) method, using orbital gradients and an L-BFGS !   approximation of the Hessian for convergence. ! ! MEMBERS: !   verbose         [INTEGER]: Verbosity level, default is 0. !   nfocks          [INTEGER]: Number of Fock matrices (1 for RHF, 2 for UHF), default is 0. !   nbf             [INTEGER]: Number of basis functions, default is 0. !   nbf_tri         [INTEGER]: Triangular size of basis functions (nbf*(nbf+1)/2), default is 0. !   scf_type        [INTEGER]: SCF type (1=RHF, 2=UHF, 3=ROHF), default is 0. !   nocc_a          [INTEGER]: Number of occupied alpha orbitals, default is 0. !   nocc_b          [INTEGER]: Number of occupied beta orbitals, default is 0. !   nvec            [INTEGER]: Size of the gradient vector, default is 0. !   overlap         [REAL(dp), POINTER]: Pointer to overlap matrix, null by default. !   overlap_invsqrt [REAL(dp), POINTER]: Pointer to inverse square root of overlap, null by default. !   max_iter        [INTEGER]: Maximum micro-iterations, default is 10. !   min_iter        [INTEGER]: Minimum micro-iterations, default is 1. !   hess_thresh     [REAL(dp)]: Orbital Hessian threshold, default is 1.0e-10_dp. !   grad_thresh     [REAL(dp)]: Gradient threshold, default is 1.0e-5_dp. !   level_shift     [REAL(dp)]: Level shifting parameter, default is 0.2_dp. !   s_history       [REAL(dp), ALLOCATABLE]: L-BFGS step history (nvec, m_max). !   rho_history     [REAL(dp), ALLOCATABLE]: L-BFGS curvature reciprocals (m_max). !   y_history       [REAL(dp), ALLOCATABLE]: L-BFGS gradient difference history (nvec, m_max). !   grad            [REAL(dp), ALLOCATABLE]: Current gradient (nvec). !   x               [REAL(dp), ALLOCATABLE]: Current x (nvec). !   grad_prev       [REAL(dp), ALLOCATABLE]: Previous gradient (nvec). !   x_prev          [REAL(dp), ALLOCATABLE]: Previous rotation parameters (nvec). !   h_inv           [REAL(dp), ALLOCATABLE]: Initial inverse Hessian diagonal (nvec). !   work_1          [REAL(dp), ALLOCATABLE]: Working matrix (nbf, nbf). !   work_2          [REAL(dp), ALLOCATABLE]: Working matrix (nbf, nbf). !   work_3          [REAL(dp), ALLOCATABLE]: Working matrix (nbf, nbf). !   mo_a            [REAL(dp), ALLOCATABLE]: Alpha MO coefficients (nbf, nbf). !   mo_b            [REAL(dp), ALLOCATABLE]: Beta MO coefficients (nbf, nbf). !   dens_a          [REAL(dp), ALLOCATABLE]: Alpha density matrix (nbf_tri). !   dens_b          [REAL(dp), ALLOCATABLE]: Beta density matrix (nbf_tri). !   m_max           [INTEGER]: Maximum number of stored history steps, default is 0. !   m_history       [INTEGER]: Current number of stored history steps, default is 0. !   first_macro     [LOGICAL]: Flag for first macro-iteration, default is .true. ! ! METHODS: !   init           - Initializes the SOSCF instance. !   clean          - Deallocates arrays and resets pointers. !   setup          - Prepares data for SOSCF iterations. !   run            - Executes SOSCF micro-iterations and returns a `scf_conv_soscf_result`. !   init_hess_inv  - Computes the initial inverse Hessian diagonal. !   calc_orb_grad  - Calculates the orbital gradient. !   bfgs           - Computes the orbital rotation x using L-BFGS. !   rotate_orbs    - Applies the orbital rotation. ! !=============================================================================== !=============================================================================== ! TYPE: scf_conv_result - BASE RESULT TYPE !=============================================================================== ! ! DESCRIPTION: !   The `scf_conv_result` type is a base type for returning results from !   convergence methods executed by `scf_conv`. It provides default !   implementations that do nothing, overridden by subtypes. ! ! MEMBERS: !   ierr           [INTEGER]: Error status (0 = success, nonzero = failure), default is 5. !   error          [REAL(dp)]: Current DIIS error magnitude, default is 1.0e99_dp. !   dat            [TYPE(converger_data), POINTER]: Pointer to SCF data, null by default. !   active_converger_name [CHARACTER(len=32)]: Name of the active converger, default is empty. ! ! METHODS: !   get_error    - Returns the current error value. !   get_fock     - Placeholder returning no data (overridden by subtypes). !   get_density  - Placeholder returning no data (overridden by subtypes). !   get_mo_a     - Placeholder returning no data (overridden by subtypes). !   get_mo_b     - Placeholder returning no data (overridden by subtypes). !   get_mo_e_a   - Placeholder returning no data (overridden by subtypes). !   get_mo_e_b   - Placeholder returning no data (overridden by subtypes). ! !=============================================================================== !=============================================================================== ! TYPE: scf_conv_interp_result - INTERPOLATION RESULT TYPE !=============================================================================== ! ! DESCRIPTION: !   The `scf_conv_interp_result` type extends `scf_conv_result` and provides !   results for interpolation-based methods (e.g., DIIS), computing updated !   Fock or density matrices as F_n = \\sum_i F_i * c_i or D_n = \\sum_i D_i * c_i. ! ! MEMBERS: !   coeffs [REAL(dp), ALLOCATABLE]: Interpolation coefficients c_i. !   pstart [INTEGER]: Start index of the interpolation range. !   pend   [INTEGER]: End index of the interpolation range. ! ! METHODS: !   get_fock    - Returns the interpolated Fock matrix. !   get_density - Returns the interpolated density matrix. !   interpolate - Computes the interpolated matrix (Fock or density, private). ! !=============================================================================== !=============================================================================== ! TYPE: scf_conv_soscf_result - SOSCF RESULT TYPE !=============================================================================== ! ! DESCRIPTION: !   The `scf_conv_soscf_result` type extends `scf_conv_result` and provides !   results specific to the SOSCF method, returning the latest MO coefficients, !   and MO energies. ! ! METHODS: !   get_mo_a    - Returns the updated alpha MO coefficients. !   get_mo_b    - Returns the updated beta MO coefficients. !   get_mo_e_a  - Returns the updated alpha MO energies. !   get_mo_e_b  - Returns the updated beta MO energies. ! !=============================================================================== !=============================================================================== ! EXAMPLE USAGE !=============================================================================== ! !   use scf_converger !   type(scf_conv) :: conv !   class(scf_conv_result), allocatable :: res !   ! Initialize converger !   call conv%init(ldim=nbf, !                  maxvec=15, & !                  subconvergers=[conv_cdiis, conv_ediis], & !                  thresholds=[2.0_dp, 1.0_dp], & !                  overlap=s_mat, !                  overlap_sqrt=s_sqrt, & !                  num_focks=1, !                  verbose=1) !   ! In SCF loop: !   do iter = 1, max_iter !     ! Build Fock matrix... ! !     ! Add data to converger !     call conv%add_data(f=fock, dens=density, e=energy) ! !     ! Run convergence step and get new Fock matrix !     call conv%run(conv_res) !     call conv_res%get_fock(matrix=fock, istat=stat) ! !     ! Check convergence !     diis_error = conv_res%get_error() !     if (diis_error < thresh) exit !   end do !   ! Clean converger !   call conv%clean() !=============================================================================== ! EXAMPLE USAGE !=============================================================================== module scf_converger use precision , only : dp use io_constants , only : iw use mathlib , only : traceprod_sym_packed , orb_to_dens use messages , only : show_message , with_abort use mathlib , only : antisymmetrize_matrix , unpack_matrix , pack_matrix use scf_addons , only : pfon_t use , intrinsic :: iso_fortran_env , only : int32 use , intrinsic :: iso_c_binding , only : c_bool use types , only : information use mod_dft_molgrid , only : dft_grid_t implicit none private ! -- SOSCF variant selector (always SOSCF_VARIANT_ORIGINAL) -- integer , parameter , public :: SOSCF_VARIANT_ORIGINAL = 0 integer , parameter , public :: SOSCF_VARIANT_STABLE_ONLY = 1 integer , parameter , public :: SOSCF_VARIANT_QUAD_LS = 2 ! public :: scf_conv public :: scf_conv_result public :: scf_conv_trah_result public :: soscf_converger ! Used to provide parametres for soscf public :: soscf_set_variant ! SOSCF mode setter public :: trah_converger ! Used to provide parametres dor trah !> Constants for converger types integer , parameter , public :: conv_none = 1 integer , parameter , public :: conv_cdiis = 2 integer , parameter , public :: conv_ediis = 3 integer , parameter , public :: conv_adiis = 4 integer , parameter , public :: conv_soscf = 5 integer , parameter , public :: conv_trah = 6 !> Converger state constants integer , parameter , public :: conv_state_not_initialized = 0 integer , parameter , public :: conv_state_initialized = 1 !> Maximum length for converger names integer , parameter , public :: conv_name_maxlen = 32 integer , parameter , public :: SCF_RHF = 1 , SCF_UHF = 2 , SCF_ROHF = 3 !> @brief Type to encapsulate SCF iteration data !> @detail Stores Fock, density, DIIS error matrices, and SCF energy for a single SCF iteration. !>         Designed for efficient memory use and data locality in a ring buffer. type :: scf_data_t real ( kind = dp ), allocatable :: focks (:,:) !< Fock matrices (nbf_tri, num_focks) real ( kind = dp ), allocatable :: densities (:,:) !< Density matrices (nbf_tri, num_focks) real ( kind = dp ), allocatable :: errs (:,:) !< DIIS error matrices (nbf_tri, num_focks) real ( kind = dp ), allocatable :: mo_a (:,:) !< MO coefficients alpha (nbf, nbf) real ( kind = dp ), allocatable :: mo_b (:,:) !< MO coefficients beta (nbf, nbf) real ( kind = dp ), allocatable :: mo_e_a (:) !< MO energies alpha (nbf) real ( kind = dp ), allocatable :: mo_e_b (:) !< MO energies beta (nbf) real ( kind = dp ) :: energy = 0.0_dp !< SCF energy type ( pfon_t ), pointer :: pfon_obj => null () !< Pseudo-Fractional Occupation Number (pFON) type real ( kind = dp ), pointer :: occ_a (:) => null () !< Alpha orbital occupations (nbf) real ( kind = dp ), pointer :: occ_b (:) => null () !< Beta orbital occupations (nbf) contains procedure , private , pass :: init => scf_data_init procedure , private , pass :: clean => scf_data_clean end type scf_data_t !> @brief Storage of SCF iteration history using a ring buffer of scf_data_t !> @detail Manages a cyclic buffer of SCF data up to num_slots. Data is stored in a single !>         array of scf_data_t for better encapsulation and cache efficiency. type :: converger_data integer :: slot = 0 !< Current slot (1-based index) integer :: num_saved = 0 !< Number of occupied slots integer :: num_slots = 0 !< Total number of slots in buffer integer :: num_focks = 0 !< Number of Fock matrices per iteration (1 for RHF/ROHF, 2 for UHF) integer :: ldim = 0 !< Size of square matrices (nbf) integer :: nelec_a = 0 !< Number of occupied alpha orbitals integer :: nelec_b = 0 !< Number of occupied beta orbitals type ( scf_data_t ), allocatable :: buffer (:) !< Ring buffer of SCF data contains procedure , private , pass :: init => conv_data_init procedure , private , pass :: clean => conv_data_clean procedure , private , pass :: next_slot => conv_data_next_slot procedure , private , pass :: discard_last => conv_data_discard procedure , private , pass :: put => conv_data_put procedure , private , pass :: get_fock => conv_data_get_fock procedure , private , pass :: get_mo_a => conv_data_get_mo_a procedure , private , pass :: get_mo_b => conv_data_get_mo_b procedure , private , pass :: get_mo_e_a => conv_data_get_mo_e_a procedure , private , pass :: get_mo_e_b => conv_data_get_mo_e_b procedure , private , pass :: get_pfon => conv_data_get_pfon procedure , private , pass :: get_density => conv_data_get_density procedure , private , pass :: get_err => conv_data_get_err procedure , private , pass :: get_energy => conv_data_get_energy procedure , private , pass :: get_slot => conv_data_get_slot end type converger_data !> @brief Base type for SCF converger results !> @detail Used by the main SCF convergence driver `scf_conv` to return results. !>  The extending type should provide the following interfaces: !>    init  : preliminary initialization of internal subconverger data !>    clean : destructor !>    setup : setting-up of the sub-converger equations, taking into the account the new data !>            added in main SCF driver !>    run   : solving the equations, returns `scf_conv_result` datatype. Multiple subsequent calls to !>            this procedure without re-running `setup` should not change internal state and have to give same results type :: scf_conv_result integer :: ierr = 5 !< Error status (0 = success, nonzero = failure) real ( kind = dp ) :: error = 1.0e99_dp !< Current DIIS error magnitude type ( converger_data ), pointer :: dat => null () !< Pointer to SCF data storage character ( len = conv_name_maxlen ) :: active_converger_name = '' !< Name of active converger contains procedure , pass :: get_error => conv_result_get_error procedure , pass :: get_fock => conv_result_dummy_get_fock procedure , pass :: get_density => conv_result_dummy_get_density procedure , pass :: get_mo_a => conv_result_dummy_get_mo_a procedure , pass :: get_mo_b => conv_result_dummy_get_mo_b procedure , pass :: get_mo_e_a => conv_result_dummy_get_mo_e_a procedure , pass :: get_mo_e_b => conv_result_dummy_get_mo_e_b procedure , pass :: get_rms_grad => conv_result_dummy_get_rms_g procedure , pass :: get_iter => conv_result_dummy_get_iter procedure , pass :: get_rms_dp => conv_result_dummy_get_rms_dp procedure , pass :: get_etot => conv_result_dummy_get_etot end type scf_conv_result !> @brief SCF converger results for interpolation methods like DIIS !> @details The updated Fock/density is computed as F_n = \\sum_{i} F_i * c_i type , extends ( scf_conv_result ) :: scf_conv_interp_result real ( kind = dp ), allocatable :: coeffs (:) !< Interpolation coefficients c_i integer :: pstart !< Start index of interpolation range integer :: pend !< End index of interpolation range contains procedure , pass :: get_fock => conv_result_interp_get_fock procedure , pass :: get_density => conv_result_interp_get_density procedure , private , pass :: interpolate => conv_result_interpolate end type scf_conv_interp_result !> @brief SCF converger results for SOSCF method type , extends ( scf_conv_result ) :: scf_conv_soscf_result real ( kind = dp ) :: rms_grad = 1 real ( kind = dp ) :: rms_dp = 1 contains procedure , pass :: get_mo_a => conv_result_soscf_get_mo_a procedure , pass :: get_mo_b => conv_result_soscf_get_mo_b procedure , pass :: get_mo_e_a => conv_result_soscf_get_mo_e_a procedure , pass :: get_mo_e_b => conv_result_soscf_get_mo_e_b procedure , pass :: get_rms_grad => conv_result_soscf_get_rms_g procedure , pass :: get_rms_dp => conv_result_soscf_get_rms_dp end type scf_conv_soscf_result type , extends ( scf_conv_result ) :: scf_conv_trah_result integer :: iter = 0 real ( kind = dp ) :: rms_grad = 1 contains procedure , pass :: get_mo_a => conv_result_trah_get_mo_a procedure , pass :: get_mo_b => conv_result_trah_get_mo_b procedure , pass :: get_mo_e_a => conv_result_trah_get_mo_e_a procedure , pass :: get_mo_e_b => conv_result_trah_get_mo_e_b procedure , pass :: get_fock => conv_result_trah_get_fock procedure , pass :: get_rms_grad => conv_result_trah_get_rms_g procedure , pass :: get_iter => conv_result_trah_get_iter end type scf_conv_trah_result !> @brief Base type for real SCF convergers (subconvergers) !> @detail Used by main SCF convergence driver `scf_conv`. !>  The extending type should provide the following interfaces: !>    init  : preliminary initialization of internal subconverger data !>    clean : destructor !>    setup : setting-up of the sub-converger equations, taking into the account the new data !>            added in main SCF driver !>    run   : solving the equations, returns `scf_conv_result` datatype. Multiple subsequent calls to !>            this procedure without re-running `setup` should not change internal state and have to give same results type , abstract :: subconverger integer :: last_setup = 1024 !< Number of SCF iterations since last setup integer :: iter = 0 !< Number of iterations passed character ( len = conv_name_maxlen ) :: conv_name = '' !< Converger name type ( converger_data ), pointer :: dat => null () !< Pointer to SCF data contains private procedure , pass :: subconverger_init procedure , pass :: subconverger_clean procedure , public , pass :: init => subconverger_init procedure , public , pass :: clean => subconverger_clean procedure ( subconverger_run ), pass , deferred :: run procedure ( subconverger_setup ), pass , deferred :: setup end type subconverger !> @brief Container type for subconvergers !> @detail Used to create allocatable array of allocatable types type :: subconverger_ class ( subconverger ), allocatable :: s end type subconverger_ !> @brief Main driver for converging SCF problems !> @detail Manages and runs different real convergers depending on the current !>         state of SCF optimization. type :: scf_conv integer :: step = 0 !< Current SCF iteration step real ( kind = dp ), pointer :: overlap (:,:) => null () !< Pointer to full-format overlap matrix (S) real ( kind = dp ), pointer :: overlap_sqrt (:,:) => null () !< Pointer to full-format S&#94;(1/2) matrix type ( converger_data ) :: dat !< Storage of SCF iteration history type ( subconverger_ ), allocatable :: sconv (:) !< Array of subconverger methods real ( kind = dp ), allocatable :: thresholds (:) !< Thresholds to initiate subconvergers integer :: iter_space_size = 10 !< Default size of subconverger problem space integer :: verbose = 0 !< Verbosity level integer :: state = 0 !< Current state (0 = not initialized, 1 = initialized) real ( kind = dp ) :: current_error = 1.0e99_dp !< Maximum absolute value of current DIIS error integer :: scf_type = 0 contains procedure , pass :: init => scf_conv_init procedure , pass :: clean => scf_conv_clean procedure , pass :: add_data => scf_conv_add_data procedure , private , pass :: select_method => scf_conv_select procedure , pass :: run => scf_conv_run procedure , private , pass :: compute_error => scf_conv_compute_error end type scf_conv !> @brief Dummy (steepest descent) converger !> @detail Used for convenience, does nothing but return the latest data. type , extends ( subconverger ) :: noconv_converger contains procedure , pass :: init => noconv_init procedure , pass :: run => noconv_run procedure , pass :: setup => noconv_setup end type noconv_converger !> @brief Commutator DIIS (C-DIIS) converger !> @detail Solves constraint minimization problem: min { Ax, \\sum_i x_i = 1 } !>         where A_{ij} = Tr([F_i D_i S_i], [F_j D_j S_j]) type , extends ( subconverger ) :: cdiis_converger integer :: maxdiis !< Maximum number of DIIS vectors real ( kind = dp ), allocatable :: a (:,:) !< C-DIIS A-matrix integer :: verbose = 0 !< Verbosity parameter integer :: old_dim = 0 !< Dimension of A matrix from previous step contains procedure , pass :: init => cdiis_init procedure , pass :: clean => cdiis_clean procedure , pass :: run => cdiis_run procedure , pass :: setup => cdiis_setup end type cdiis_converger !> @brief Datatype to pass optimization parameters to NLOpt for E/A-DIIS !> @detail Used for solving constraint minimization problems in E/A-DIIS: !>         \\f$ min \\{ x&#94;T A x + bx,\\ x_i \\geq 0,\\ \\sum_i{x_i} = 1 \\} \\f$ type :: ediis_opt_data real ( kind = 8 ), pointer :: b (:) => null () !< Energy or linear term coefficients real ( kind = 8 ), pointer :: A (:,:) => null () !< Quadratic term matrix procedure ( eadiis_f ), pointer , nopass :: fun => null () !< Objective function pointer end type ediis_opt_data !> @brief Energy DIIS (E-DIIS) converger !> @detail Optimizes the following function: !>         \\f$ E_\\mathrm{E-DIIS} = \\sum_{i} c_i E_i - 0.5 \\sum_{i,j} c_i c_j Tr( (D_i-D_j) (F_i-F_j) ) \\f$ !>         under the constraints: !>         \\f$ \\sum_i {c_i} = 1, c_i \\geq 0 \\f$ type , extends ( cdiis_converger ) :: ediis_converger real ( kind = dp ), allocatable :: b (:) !< Energy history real ( kind = dp ), allocatable :: xlog (:,:) !< Interpolation coefficients history type ( ediis_opt_data ) :: t !< Optimization data for NLOpt procedure ( eadiis_f ), pointer , nopass :: fun => null () !< Pointer to objective function contains procedure , pass :: init => ediis_init procedure , pass :: clean => ediis_clean procedure , pass :: setup => ediis_setup procedure , pass :: run => ediis_run end type ediis_converger !> @brief A-DIIS subconverger type !> @detail Optimizes the following function: !>         \\f$ E_\\mathrm{A-DIIS} = \\sum_{i} c_i Tr((D_i-D_n)F_n) + 2 \\sum_{i,j} c_i c_j Tr( (D_i-D_n) (F_j-F_n) ) \\f$ !>         under the constraints: !>         \\f$ \\sum_i {c_i} = 1, c_i \\geq 0 \\f$ type , extends ( ediis_converger ) :: adiis_converger contains procedure , pass :: init => adiis_init procedure , pass :: setup => adiis_setup end type adiis_converger abstract interface subroutine subconverger_run ( self , res ) import class ( subconverger ), target , intent ( inout ) :: self class ( scf_conv_result ), allocatable , intent ( out ) :: res end subroutine subroutine subconverger_setup ( self ) import class ( subconverger ), intent ( inout ) :: self end subroutine subroutine eadiis_f ( val , n , t , grad , need_gradient , d ) import implicit none real ( kind = 8 ) :: val , t ( * ), grad ( * ) integer ( kind = 4 ), intent ( in ) :: n , need_gradient type ( ediis_opt_data ), intent ( in ) :: d end subroutine end interface !> @brief SOSCF subconverger type !> @detail Implementation is based on !          T. H. Fischer, J. Almlof, Journal of Physical Chemistry, 96(24), 9768-9774 (1992) !          F. Neese, Chemical Physics Letters, 325(1-3), 93-98 (2000) type , extends ( subconverger ) :: soscf_converger integer :: verbose = 0 !< Verbosity parameter integer :: nfocks = 0 !< Number of Focks (RHF = 1, UHF = 2) integer :: nbf = 0 !< Number of basis functions integer :: nbf_tri = 0 !< Number of basis functions in triangular format integer :: scf_type = 0 !< SCF type: 1:RHF, 2:UHF, 3:ROHF integer :: nocc_a = 0 !< Number of occupied alpha orbitals integer :: nocc_b = 0 !< Number of occupied beta orbitals integer :: nvec = 0 !< Size of the gradient vector ! === cheap step-control state (SOSCF only) === real ( dp ) :: alpha_cap = 1.0_dp real ( dp ) :: kappa_lim = 0.8_dp real ( dp ) :: alpha_last = 0.0_dp real ( dp ) :: gg_last = 0.0_dp real ( dp ) :: hh_last = 1.0_dp real ( dp ) :: g_rms_last = 0.0_dp integer :: polish_cnt = 0 real ( kind = dp ), pointer :: overlap (:, :) => null () real ( kind = dp ), pointer :: overlap_invsqrt (:, :) => null () class ( information ), pointer :: infos !    ! SOSCF parameters from scf_driver: real ( kind = dp ) :: hess_thresh = 1.0e-10_dp !< Orbital Hessian threshold real ( kind = dp ) :: grad_thresh = 1.0e-3_dp !< Gradient threshold real ( kind = dp ) :: level_shift = 0.0_dp !< Level shifting parameter real ( kind = dp ) :: rms_grad_prev = 0.0_dp !< previous Gradient norm integer :: soscf_reset_mod = 1 !< Set the SOSCF Hessian reset mode. logical :: use_lineq = . false . !< Use linear equations (vs BFGS) ! L-BFGS history real ( kind = dp ), allocatable :: s_history (:,:) !< Step history (nvec, m_max) real ( kind = dp ), allocatable :: rho_history (:) !< Curvature reciprocals (m_max) real ( kind = dp ), allocatable :: y_history (:,:) !< Gradient difference history (nvec, m_max) real ( kind = dp ), allocatable :: upd_history (:,:) ! h_inv*dgrad history (nvec, m_max) real ( kind = dp ), allocatable :: grad (:) !< Gradient (nvec) real ( kind = dp ), allocatable :: x (:) !< Step (nvec) real ( kind = dp ), allocatable :: x_prev (:) !< Step (nvec) real ( kind = dp ), allocatable :: grad_prev (:) !< Previous gradient (nvec) real ( kind = dp ), allocatable :: h_inv (:) !< Initial inverse Hessian diagonal (nvec) real ( kind = dp ), allocatable :: work_1 (:,:) !< Work matrix (nbf, nbf) real ( kind = dp ), allocatable :: work_2 (:,:) !< Work matrix (nbf, nbf) real ( kind = dp ), allocatable :: work_3 (:,:) !< Work matrix (nbf, nbf) real ( kind = dp ), allocatable :: mo_a (:,:) !< MOs matrix (nbf, nbf) real ( kind = dp ), allocatable :: mo_b (:,:) !< MOs matrix (nbf, nbf) real ( kind = dp ), allocatable :: dens_a (:) !< MOs matrix (nbf_tri) real ( kind = dp ), allocatable :: dens_b (:) !< MOs matrix (nbf_tri) real ( kind = dp ), allocatable :: dens_a_old (:) !< MOs matrix (nbf_tri) real ( kind = dp ), allocatable :: dens_b_old (:) !< MOs matrix (nbf_tri) integer :: m_max = 0 !< Maximum number of stored history steps integer :: m_history = 0 !< Number of stored history steps logical :: first_macro = . true . !< Flag for first macro-iteration ! 0: original; 1: stability-only; 2: stability + quadratic LS + 1-D TR integer :: variant = SOSCF_VARIANT_ORIGINAL contains procedure , pass :: init => soscf_init procedure , pass :: clean => soscf_clean procedure , pass :: setup => soscf_setup procedure , pass :: run => soscf_run procedure , private , pass :: init_hess_inv => init_hess_inv procedure , private , pass :: calc_orb_grad => calc_orb_grad procedure , private , pass :: bfgs => bfgs procedure , private , pass :: rotate_orbs => rotate_orbs procedure , private , pass :: rms_density => rms_density end type soscf_converger !================================================================= !impementation of trust region agumented hessian !================================================================= type , extends ( subconverger ) :: trah_converger integer :: scf_type = SCF_RHF integer :: nbf = 0 integer :: nbf_tri = 0 integer :: nocc_a = 0 integer :: nocc_b = 0 integer :: nvir_a = 0 integer :: nvir_b = 0 integer :: nfocks = 1 integer :: verbose = 0 real ( dp ) :: etot = 0 integer ( int32 ) :: n_param = 0 logical :: is_dft = . false . real ( dp ) :: hf_scale = 1.0_dp real ( dp ), allocatable :: fock_ao (:,:) ! fock matrix fock_ao (nbf_tri, nfock) real ( dp ), allocatable :: dens (:,:) ! density matrix (nbf_tri, nfocks) real ( dp ), allocatable :: f_old (:,:) real ( dp ), allocatable :: d_old (:,:) real ( kind = dp ), pointer :: overlap (:, :) => null () real ( kind = dp ), pointer :: overlap_invsqrt (:, :) => null () class ( information ), pointer :: infos type ( dft_grid_t ), pointer :: molgrid real ( dp ), allocatable :: mo_a (:,:), mo_b (:,:) real ( dp ), allocatable :: foo_a (:,:), fvv_a (:,:), xmat_a (:,:), x2mat_a (:,:) real ( dp ), allocatable :: foo_b (:,:), fvv_b (:,:), xmat_b (:,:), x2mat_b (:,:) real ( dp ), allocatable :: v (:,:) ! response v(nbf, nbf) real ( dp ), allocatable :: dm (:,:) ! response density dm(nbf,nbf) real ( dp ), allocatable :: pfock (:,:) ! Fock matrix (nbf_tri, nfocks) from respose density real ( dp ), allocatable :: dm_tri (:,:) ! packed DM (nbf_tri, nfocks) real ( dp ), allocatable :: work1 (:,:) ! (nbf, nbf) real ( dp ), allocatable :: work2 (:,:) ! (nbf, nbf) real ( dp ), allocatable :: work3 (:,:) ! (nbf, nbf) contains procedure , pass :: init => trah_init procedure , pass :: clean => trah_clean procedure , pass :: setup => trah_setup procedure , pass :: run => trah_run procedure , pass :: rotate_orbs => rotate_orbs_trah procedure , pass :: calc_h_op => calc_h_op procedure , pass :: calc_g_h => calc_g_h end type trah_converger contains subroutine soscf_set_variant ( obj , variant ) class ( subconverger ), intent ( inout ) :: obj integer , intent ( in ) :: variant select type ( me => obj ) type is ( soscf_converger ) me % variant = variant class default ! ignore for non-SOSCF convergers end select end subroutine soscf_set_variant !============================================================================== ! scf_data_t Methods !============================================================================== !> @brief Initialize an scf_data_t instance !> @param[inout] self The scf_data_t object to initialize. !> @param[in] ldim Size of triangular matrices (nbf*(nbf+1)/2) !> @param[in] nfocks Number of Fock matrices (1 for RHF/ROHF, 2 for UHF) !> @param[out] istat Status code (0 for success, nonzero for allocation failure) subroutine scf_data_init ( self , ldim , nfocks , istat ) class ( scf_data_t ), intent ( inout ) :: self integer , intent ( in ) :: ldim , nfocks integer , intent ( out ) :: istat integer :: nbf_tri istat = 0 nbf_tri = ldim * ( ldim + 1 ) / 2 if ( allocated ( self % focks )) call self % clean () allocate ( self % focks ( nbf_tri , nfocks ), & self % densities ( nbf_tri , nfocks ), & self % errs ( nbf_tri , nfocks ), & stat = istat ) ! Note: MO coefficients mo_a, mo_b and energies mo_e_a, mo_e_b ! Note: are allocated on demand in conv_data_put self % densities = 0.0_dp self % focks = 0.0_dp self % errs = 0.0_dp self % energy = 0.0_dp end subroutine scf_data_init !> @brief Clean up an scf_data_t instance subroutine scf_data_clean ( self ) class ( scf_data_t ), intent ( inout ) :: self if ( allocated ( self % focks )) deallocate ( self % focks ) if ( allocated ( self % densities )) deallocate ( self % densities ) if ( allocated ( self % errs )) deallocate ( self % errs ) self % occ_a => null () self % occ_b => null () self % energy = 0.0_dp end subroutine scf_data_clean !============================================================================== ! converger_data Methods !============================================================================== !> @brief Set up a ring buffer to store SCF iteration history. !> @param[inout] self The converger_data object to initialize. !> @param[in] ldim Number of basis functions (nbf) !> @param[in] nfocks Number of Fock matrices per iteration (1 for RHF/ROHF, 2 for UHF) !> @param[in] nslots Maximum number of SCF iterations to store !> @param[out] istat Success status (0 for success, nonzero for error) subroutine conv_data_init ( self , ldim , nfocks , nslots , istat , nelec_a , nelec_b ) class ( converger_data ), intent ( inout ) :: self integer , intent ( in ) :: ldim , nfocks , nslots integer , intent ( out ) :: istat integer , intent ( in ), optional :: nelec_a , nelec_b integer :: i istat = 0 if ( allocated ( self % buffer )) call self % clean () self % ldim = ldim self % num_focks = nfocks self % num_slots = nslots self % num_saved = 0 self % slot = 0 if ( present ( nelec_a )) self % nelec_a = nelec_a if ( present ( nelec_b )) self % nelec_b = nelec_b allocate ( self % buffer ( nslots ), stat = istat ) do i = 1 , nslots call self % buffer ( i )% init ( ldim , nfocks , istat ) end do end subroutine conv_data_init !> @brief Finalize converger_data and deallocate memory subroutine conv_data_clean ( self ) class ( converger_data ), intent ( inout ) :: self integer :: i if ( allocated ( self % buffer )) then do i = 1 , self % num_slots call self % buffer ( i )% clean () end do deallocate ( self % buffer ) end if self % ldim = 0 self % num_focks = 0 self % num_slots = 0 self % num_saved = 0 self % slot = 0 end subroutine conv_data_clean !> @brief Advance to the next slot in the ring buffer subroutine conv_data_next_slot ( self ) class ( converger_data ), intent ( inout ) :: self self % slot = mod ( self % slot , self % num_slots ) + 1 self % num_saved = min ( self % num_saved + 1 , self % num_slots ) end subroutine conv_data_next_slot !> @brief Discard the most recent data entry subroutine conv_data_discard ( self ) class ( converger_data ), intent ( inout ) :: self self % slot = mod ( self % slot - 2 , self % num_slots ) + 1 self % num_saved = min ( self % num_saved - 1 , 1 ) end subroutine conv_data_discard !> @brief Store SCF data for the current iteration !> @param[in] fock Fock matrices (optional) !> @param[in] dens Density matrices (optional) !> @param[in] energy SCF energy (optional) !> @param[in] mo_a Alpha MO coefficients (optional) !> @param[in] mo_b Beta MO coefficients (optional) !> @param[in] mo_e_a Alpha MO energies (optional) !> @param[in] mo_e_b Beta MO energies (optional) subroutine conv_data_put ( self , fock , dens , energy , mo_a , mo_b , & mo_e_a , mo_e_b , pfon_obj ) class ( converger_data ), intent ( inout ) :: self real ( kind = dp ), intent ( in ), optional :: fock (:,:) real ( kind = dp ), intent ( in ), optional :: dens (:,:) real ( kind = dp ), intent ( in ), optional :: energy real ( kind = dp ), intent ( in ), optional :: mo_a (:,:), mo_b (:,:) real ( kind = dp ), intent ( in ), optional :: mo_e_a (:), mo_e_b (:) type ( pfon_t ), optional , target , intent ( in ) :: pfon_obj integer :: slot , nbf nbf = self % ldim slot = self % slot if ( present ( fock )) self % buffer ( slot )% focks = fock if ( present ( dens )) self % buffer ( slot )% densities = dens if ( present ( energy )) self % buffer ( slot )% energy = energy if ( present ( mo_a )) then if (. not . allocated ( self % buffer ( slot )% mo_a )) then allocate ( self % buffer ( slot )% mo_a ( nbf , nbf )) end if self % buffer ( slot )% mo_a = mo_a end if if ( present ( mo_b )) then if (. not . allocated ( self % buffer ( slot )% mo_b )) then allocate ( self % buffer ( slot )% mo_b ( nbf , nbf )) end if self % buffer ( slot )% mo_b = mo_b end if if ( present ( mo_e_a )) then if (. not . allocated ( self % buffer ( slot )% mo_e_a )) then allocate ( self % buffer ( slot )% mo_e_a ( nbf )) end if self % buffer ( slot )% mo_e_a = mo_e_a end if if ( present ( mo_e_b )) then if (. not . allocated ( self % buffer ( slot )% mo_e_b )) then allocate ( self % buffer ( slot )% mo_e_b ( nbf )) end if self % buffer ( slot )% mo_e_b = mo_e_b end if if ( present ( pfon_obj )) then self % buffer ( slot )% pfon_obj => pfon_obj end if end subroutine conv_data_put !> @brief Get Fock matrix for a specific iteration and matrix ID !> @param[in] n Slot ID (1 = oldest, -1 = latest) !> @param[in] matrix_id Fock matrix index (1 = alpha, 2 = beta) !> @return Pointer to the Fock matrix function conv_data_get_fock ( self , n , matrix_id ) result ( res ) class ( converger_data ), intent ( in ), target :: self integer , intent ( in ) :: n , matrix_id real ( kind = dp ), pointer :: res (:) integer :: slot slot = self % get_slot ( n ) res => self % buffer ( slot )% focks (:, matrix_id ) end function conv_data_get_fock !> @brief Get MO coefficients for alpha orbitals for a specific iteration !> @param[in] n Slot ID (1 = oldest, -1 = latest) !> @return Pointer to the alpha MO coefficients function conv_data_get_mo_a ( self , n ) result ( res ) class ( converger_data ), intent ( in ), target :: self integer , intent ( in ) :: n real ( kind = dp ), pointer :: res (:,:) integer :: slot slot = self % get_slot ( n ) res => self % buffer ( slot )% mo_a end function conv_data_get_mo_a !> @brief Get MO coefficients for beta orbitals for a specific iteration !> @param[in] n Slot ID (1 = oldest, -1 = latest) !> @return Pointer to the beta MO coefficients function conv_data_get_mo_b ( self , n ) result ( res ) class ( converger_data ), intent ( in ), target :: self integer , intent ( in ) :: n real ( kind = dp ), pointer :: res (:,:) integer :: slot slot = self % get_slot ( n ) res => self % buffer ( slot )% mo_b end function conv_data_get_mo_b !> @brief Get alpha MO energies for a specific iteration !> @param[in] n Slot ID (1 = oldest, -1 = latest) !> @return Pointer to the alpha MO energies function conv_data_get_mo_e_a ( self , n ) result ( res ) class ( converger_data ), intent ( in ), target :: self integer , intent ( in ) :: n real ( kind = dp ), pointer :: res (:) integer :: slot slot = self % get_slot ( n ) res => self % buffer ( slot )% mo_e_a end function conv_data_get_mo_e_a !> @brief Get beta MO energies for a specific iteration !> @param[in] n Slot ID (1 = oldest, -1 = latest) !> @return Pointer to the beta MO energies function conv_data_get_mo_e_b ( self , n ) result ( res ) class ( converger_data ), intent ( in ), target :: self integer , intent ( in ) :: n real ( kind = dp ), pointer :: res (:) integer :: slot slot = self % get_slot ( n ) res => self % buffer ( slot )% mo_e_b end function conv_data_get_mo_e_b !> @brief Get pfon object for a specific iteration !> @param[in] n Slot ID (1 = oldest, -1 = latest) !> @return Pointer to the pfon object function conv_data_get_pfon ( self , n ) result ( res ) class ( converger_data ), intent ( in ), target :: self integer , intent ( in ) :: n type ( pfon_t ), pointer :: res integer :: slot slot = self % get_slot ( n ) res => self % buffer ( slot )% pfon_obj end function conv_data_get_pfon !> @brief Get density matrix for a specific iteration and matrix ID !> @param[in] n Slot ID (1 = oldest, -1 = latest) !> @param[in] matrix_id Density matrix index (1 = alpha, 2 = beta) !> @return Pointer to the density matrix function conv_data_get_density ( self , n , matrix_id ) result ( res ) class ( converger_data ), intent ( in ), target :: self integer , intent ( in ) :: n , matrix_id real ( kind = dp ), pointer :: res (:) integer :: slot slot = self % get_slot ( n ) res => self % buffer ( slot )% densities (:, matrix_id ) end function conv_data_get_density !> @brief Get DIIS error matrix for a specific iteration and matrix ID !> @param[in] n Slot ID (1 = oldest, -1 = latest) !> @param[in] matrix_id Error matrix index (1 = alpha, 2 = beta) !> @return Pointer to the error matrix function conv_data_get_err ( self , n , matrix_id ) result ( res ) class ( converger_data ), intent ( in ), target :: self integer , intent ( in ) :: n , matrix_id real ( kind = dp ), pointer :: res (:) integer :: slot slot = self % get_slot ( n ) res => self % buffer ( slot )% errs (:, matrix_id ) end function conv_data_get_err !> @brief Get SCF energy for a specific iteration !> @param[in] n Slot ID (1 = oldest, -1 = latest) !> @return SCF energy value function conv_data_get_energy ( self , n ) result ( res ) class ( converger_data ), intent ( in ) :: self integer , intent ( in ) :: n real ( kind = dp ) :: res integer :: slot slot = self % get_slot ( n ) res = self % buffer ( slot )% energy end function conv_data_get_energy !> @brief Compute slot index from iteration number !> @param[in] n Iteration number (1 = oldest, -1 = latest) !> @return Slot index in the ring buffer function conv_data_get_slot ( self , n ) result ( slot ) class ( converger_data ), intent ( in ) :: self integer , intent ( in ) :: n integer :: slot , num_saved num_saved = self % num_saved if ( n == - 1 ) then slot = self % slot else slot = modulo ( self % slot - num_saved + n - 1 , self % num_slots ) + 1 end if end function !============================================================================== ! scf_conv_result Methods !============================================================================== !> @brief Form the new Fock matrix !> @detail Placeholder for derived types to override. Does nothing by default. subroutine conv_result_dummy_get_fock ( self , matrix , istat ) class ( scf_conv_result ), intent ( in ) :: self integer , intent ( out ) :: istat real ( kind = dp ), intent ( inout ) :: matrix (:,:) istat = 0 end subroutine conv_result_dummy_get_fock !> @brief Form the new density matrix !> @detail Placeholder for derived types to override. Does nothing by default. subroutine conv_result_dummy_get_density ( self , matrix , istat ) class ( scf_conv_result ), intent ( in ) :: self integer , intent ( out ) :: istat real ( kind = dp ), intent ( inout ) :: matrix (:,:) istat = 0 end subroutine conv_result_dummy_get_density subroutine conv_result_dummy_get_mo_a ( self , matrix , istat ) class ( scf_conv_result ), intent ( in ) :: self integer , intent ( out ) :: istat real ( kind = dp ), intent ( inout ) :: matrix (:,:) istat = 0 end subroutine conv_result_dummy_get_mo_a subroutine conv_result_dummy_get_mo_b ( self , matrix , istat ) class ( scf_conv_result ), intent ( in ) :: self integer , intent ( out ) :: istat real ( kind = dp ), intent ( inout ) :: matrix (:,:) istat = 0 end subroutine conv_result_dummy_get_mo_b subroutine conv_result_dummy_get_mo_e_a ( self , vector , istat ) class ( scf_conv_result ), intent ( in ) :: self integer , intent ( out ) :: istat real ( kind = dp ), intent ( inout ) :: vector (:) istat = 0 end subroutine conv_result_dummy_get_mo_e_a subroutine conv_result_dummy_get_mo_e_b ( self , vector , istat ) class ( scf_conv_result ), intent ( in ) :: self integer , intent ( out ) :: istat real ( kind = dp ), intent ( inout ) :: vector (:) istat = 0 end subroutine conv_result_dummy_get_mo_e_b function conv_result_dummy_get_rms_g ( self ) result ( istat ) class ( scf_conv_result ), intent ( in ) :: self real ( kind = dp ) :: istat istat = 0 end function conv_result_dummy_get_rms_g function conv_result_dummy_get_iter ( self ) result ( istat ) class ( scf_conv_result ), intent ( in ) :: self real ( kind = dp ) :: istat istat = 0 end function conv_result_dummy_get_iter function conv_result_dummy_get_rms_dp ( self ) result ( istat ) class ( scf_conv_result ), intent ( in ) :: self real ( kind = dp ) :: istat istat = 0 end function conv_result_dummy_get_rms_dp function conv_result_dummy_get_etot ( self ) result ( istat ) class ( scf_conv_result ), intent ( in ) :: self real ( kind = dp ) :: istat istat = 0 end function conv_result_dummy_get_etot !> @brief Form the interpolated Fock matrix !> @detail F_n = \\sum_{i=start}&#94;{end} F_i * c_i subroutine conv_result_interp_get_fock ( self , matrix , istat ) class ( scf_conv_interp_result ), intent ( in ) :: self integer , intent ( out ) :: istat real ( kind = dp ), intent ( inout ) :: matrix (:,:) if ( self % ierr == 0 ) then call self % interpolate ( matrix , 'fock' , istat ) else istat = self % ierr end if end subroutine conv_result_interp_get_fock !> @brief Get error value from result !> @return Current error value !> @brief Get the current convergence error !> @return Current error value for the active converger function conv_result_get_error ( self ) result ( err ) class ( scf_conv_result ), intent ( in ) :: self real ( kind = dp ) :: err err = self % error end function conv_result_get_error !============================================================================== ! DIIS Result Methods !============================================================================== !> @brief Form the interpolated density matrix !> @detail D_n = \\sum_{i=start}&#94;{end} D_i * c_i subroutine conv_result_interp_get_density ( self , matrix , istat ) class ( scf_conv_interp_result ), intent ( in ) :: self integer , intent ( out ) :: istat real ( kind = dp ), intent ( inout ) :: matrix (:,:) if ( self % ierr == 0 ) then call self % interpolate ( matrix , 'density' , istat ) else istat = self % ierr end if end subroutine conv_result_interp_get_density !> @brief Form the interpolated matrix (Fock or density) !> @param[inout] matrix Output matrix (Fock or density) !> @param[in] datatype 'fock' or 'density' to specify which matrix to interpolate !> @param[out] istat Status code (0 = success) subroutine conv_result_interpolate ( self , matrix , datatype , istat ) class ( scf_conv_interp_result ), intent ( in ) :: self integer , intent ( out ) :: istat real ( kind = dp ), intent ( inout ) :: matrix (:,:) character ( len =* ), intent ( in ) :: datatype integer :: i , ifock if ( self % ierr /= 0 ) then istat = self % ierr return end if matrix = 0.0_dp do ifock = 1 , self % dat % num_focks do i = self % pstart , self % pend select case ( datatype ) case ( 'fock' ) matrix (:, ifock ) = matrix (:, ifock ) + self % coeffs ( i ) * self % dat % get_fock ( i , ifock ) case ( 'density' ) matrix (:, ifock ) = matrix (:, ifock ) + self % coeffs ( i ) * self % dat % get_density ( i , ifock ) end select end do end do istat = 0 end subroutine conv_result_interpolate !============================================================================== ! SOSCF Result Methods !============================================================================== !> @brief Get alpha MO coefficients from SOSCF result subroutine conv_result_soscf_get_mo_a ( self , matrix , istat ) class ( scf_conv_soscf_result ), intent ( in ) :: self integer , intent ( out ) :: istat real ( kind = dp ), intent ( inout ) :: matrix (:,:) if ( self % ierr /= 0 ) then istat = self % ierr return end if matrix = self % dat % buffer ( self % dat % slot )% mo_a istat = 0 end subroutine conv_result_soscf_get_mo_a !> @brief Get beta MO coefficients from SOSCF result subroutine conv_result_soscf_get_mo_b ( self , matrix , istat ) class ( scf_conv_soscf_result ), intent ( in ) :: self integer , intent ( out ) :: istat real ( kind = dp ), intent ( inout ) :: matrix (:,:) if ( self % ierr /= 0 ) then istat = self % ierr return end if matrix = self % dat % buffer ( self % dat % slot )% mo_b istat = 0 end subroutine conv_result_soscf_get_mo_b !> @brief Get alpha orbital energies from SOSCF result subroutine conv_result_soscf_get_mo_e_a ( self , vector , istat ) class ( scf_conv_soscf_result ), intent ( in ) :: self integer , intent ( out ) :: istat real ( kind = dp ), intent ( inout ) :: vector (:) if ( self % ierr /= 0 ) then istat = self % ierr return end if vector = self % dat % buffer ( self % dat % slot )% mo_e_a istat = 0 end subroutine conv_result_soscf_get_mo_e_a !> @brief Get beta orbital energies from SOSCF result subroutine conv_result_soscf_get_mo_e_b ( self , vector , istat ) class ( scf_conv_soscf_result ), intent ( in ) :: self integer , intent ( out ) :: istat real ( kind = dp ), intent ( inout ) :: vector (:) if ( self % ierr /= 0 ) then istat = self % ierr return end if vector = self % dat % buffer ( self % dat % slot )% mo_e_b istat = 0 end subroutine conv_result_soscf_get_mo_e_b function conv_result_soscf_get_rms_g ( self ) result ( rms ) class ( scf_conv_soscf_result ), intent ( in ) :: self real ( kind = dp ) :: rms rms = self % rms_grad end function conv_result_soscf_get_rms_g function conv_result_soscf_get_rms_dp ( self ) result ( rms ) class ( scf_conv_soscf_result ), intent ( in ) :: self real ( kind = dp ) :: rms rms = self % rms_dp end function conv_result_soscf_get_rms_dp !============================================================================== ! TRAH Result Methods !============================================================================== !> @brief Get alpha MO coefficients from TRAH result subroutine conv_result_trah_get_mo_a ( self , matrix , istat ) class ( scf_conv_trah_result ), intent ( in ) :: self integer , intent ( out ) :: istat real ( kind = dp ), intent ( inout ) :: matrix (:,:) if ( self % ierr /= 0 ) then istat = self % ierr return end if matrix = self % dat % buffer ( self % dat % slot )% mo_a istat = 0 end subroutine conv_result_trah_get_mo_a !> @brief Get beta MO coefficients from TRAH result subroutine conv_result_trah_get_mo_b ( self , matrix , istat ) class ( scf_conv_trah_result ), intent ( in ) :: self integer , intent ( out ) :: istat real ( kind = dp ), intent ( inout ) :: matrix (:,:) if ( self % ierr /= 0 ) then istat = self % ierr return end if matrix = self % dat % buffer ( self % dat % slot )% mo_b istat = 0 end subroutine conv_result_trah_get_mo_b subroutine conv_result_trah_get_mo_e_a ( self , vector , istat ) class ( scf_conv_trah_result ), intent ( in ) :: self integer , intent ( out ) :: istat real ( kind = dp ), intent ( inout ) :: vector (:) if ( self % ierr /= 0 ) then istat = self % ierr return end if vector = self % dat % buffer ( self % dat % slot )% mo_e_a istat = 0 end subroutine conv_result_trah_get_mo_e_a subroutine conv_result_trah_get_mo_e_b ( self , vector , istat ) class ( scf_conv_trah_result ), intent ( in ) :: self integer , intent ( out ) :: istat real ( kind = dp ), intent ( inout ) :: vector (:) if ( self % ierr /= 0 ) then istat = self % ierr return end if vector = self % dat % buffer ( self % dat % slot )% mo_e_b istat = 0 end subroutine conv_result_trah_get_mo_e_b subroutine conv_result_trah_get_fock ( self , matrix , istat ) class ( scf_conv_trah_result ), intent ( in ) :: self integer , intent ( out ) :: istat real ( kind = dp ), intent ( inout ) :: matrix (:,:) if ( self % ierr /= 0 ) then istat = self % ierr return end if matrix = self % dat % buffer ( self % dat % slot )% focks istat = 0 end subroutine conv_result_trah_get_fock function conv_result_trah_get_rms_g ( self ) result ( rms ) class ( scf_conv_trah_result ), intent ( in ) :: self real ( kind = dp ) :: rms rms = self % rms_grad end function conv_result_trah_get_rms_g function conv_result_trah_get_iter ( self ) result ( rms ) class ( scf_conv_trah_result ), intent ( in ) :: self real ( kind = dp ) :: rms rms = self % iter end function conv_result_trah_get_iter !============================================================================== ! scf_conv Methods !============================================================================== !> @brief Finalize scf_conv datatype subroutine scf_conv_clean ( self ) class ( scf_conv ), intent ( inout ) :: self self % verbose = 0 self % step = 0 self % state = conv_state_not_initialized call self % dat % clean () if ( allocated ( self % thresholds )) deallocate ( self % thresholds ) if ( allocated ( self % sconv )) deallocate ( self % sconv ) nullify ( self % overlap ) nullify ( self % overlap_sqrt ) end subroutine scf_conv_clean !> @brief Initializes the SCF converger driver !> @param[in] ldim Number of orbitals !> @param[in] maxvec Size of SCF converger linear space (e.g., number of DIIS vectors) !> @param[in] subconvergers Array of SCF subconverger codes !> @param[in] thresholds Thresholds to initiate subconvergers, where !>                       subconvergers[i] runs when current error is less than thresholds[i] !> @param[in] overlap Overlap matrix (S) in full format !> @param[in] overlap_sqrt S&#94;(1/2) matrix in full format !> @param[in] num_focks 1 if R/ROHF, 2 if UHF !> @param[in] verbose Verbosity level subroutine scf_conv_init ( self , ldim , nelec_a , nelec_b , maxvec , subconvergers , thresholds , & overlap , overlap_sqrt , num_focks , scf_type , verbose , sd_scf ) class ( scf_conv ), intent ( inout ) :: self integer , intent ( in ) :: ldim integer , optional , intent ( in ) :: nelec_a integer , optional , intent ( in ) :: nelec_b integer , optional , intent ( in ) :: maxvec integer , optional , intent ( in ) :: subconvergers (:) real ( kind = dp ), optional , intent ( in ) :: thresholds (:) real ( kind = dp ), optional , target , intent ( in ) :: overlap (:,:), overlap_sqrt (:,:) integer , optional , intent ( in ) :: num_focks integer , optional , intent ( in ) :: verbose integer :: nfocks , istat , i integer , optional , intent ( in ) :: scf_type logical ( c_bool ), optional , intent ( in ) :: sd_scf if ( self % state /= conv_state_not_initialized ) call self % clean () if ( present ( thresholds )) then allocate ( self % thresholds ( 0 : ubound ( thresholds , 1 ))) self % thresholds ( 0 :) = [ thresholds , 0.0_dp ] else allocate ( self % thresholds ( 0 : 1 )) self % thresholds ( 0 :) = [ 1.0_dp , 0.0_dp ] end if self % overlap => null () if ( present ( overlap )) self % overlap => overlap self % overlap_sqrt => null () if ( present ( overlap_sqrt )) self % overlap_sqrt => overlap_sqrt nfocks = 1 if ( present ( num_focks )) nfocks = num_focks if ( present ( scf_type )) self % scf_type = scf_type self % verbose = 0 if ( present ( verbose )) self % verbose = verbose self % iter_space_size = 15 if ( present ( maxvec )) self % iter_space_size = maxvec self % step = 0 if ( present ( nelec_a ) . and . present ( nelec_b )) then call self % dat % init ( ldim , nfocks , self % iter_space_size , istat , nelec_a , nelec_b ) else call self % dat % init ( ldim , nfocks , self % iter_space_size , istat ) end if if ( istat /= 0 ) then self % state = conv_state_not_initialized return end if if ( present ( sd_scf )) then if (. not . sd_scf ) self % step = self % step + 1 end if if ( present ( subconvergers )) then allocate ( self % sconv ( 0 : ubound ( subconvergers , 1 ))) allocate ( noconv_converger :: self % sconv ( 0 )% s ) call self % sconv ( 0 )% s % init ( self ) do i = 1 , ubound ( subconvergers , 1 ) select case ( subconvergers ( i )) case ( conv_none ) allocate ( noconv_converger :: self % sconv ( i )% s ) case ( conv_cdiis ) allocate ( cdiis_converger :: self % sconv ( i )% s ) case ( conv_ediis ) allocate ( ediis_converger :: self % sconv ( i )% s ) case ( conv_adiis ) allocate ( adiis_converger :: self % sconv ( i )% s ) case ( conv_soscf ) allocate ( soscf_converger :: self % sconv ( i )% s ) case ( conv_trah ) allocate ( trah_converger :: self % sconv ( i )% s ) end select call self % sconv ( i )% s % init ( self ) end do end if self % state = conv_state_initialized end subroutine scf_conv_init !> @brief Store data from the new SCF iteration !> @param[in] f Fock matrix/matrices !> @param[in] dens Density matrix/matrices !> @param[in] e SCF energy (optional) subroutine scf_conv_add_data ( self , f , dens , e , mo_a , mo_b , mo_e_a , mo_e_b , & pfon ) class ( scf_conv ), intent ( inout ) :: self real ( kind = dp ), intent ( in ), optional :: f (:,:) ! Fock matrices real ( kind = dp ), intent ( in ), optional :: dens (:,:) ! Density matrices real ( kind = dp ), intent ( in ), optional :: e ! SCF energy real ( kind = dp ), intent ( in ), optional :: mo_a (:,:) ! Alpha MO coefficients real ( kind = dp ), intent ( in ), optional :: mo_b (:,:) ! Beta MO coefficients real ( kind = dp ), intent ( in ), optional :: mo_e_a (:) ! Alpha MO energies real ( kind = dp ), intent ( in ), optional :: mo_e_b (:) ! Beta MO energies type ( pfon_t ), pointer , intent ( in ), optional :: pfon ! Pseudo-Fractional Occupation Number (pFON) object integer :: i call self % dat % next_slot () ! Save the current Fock and density matrices if ( present ( f )) call self % dat % put ( fock = f ) if ( present ( dens )) call self % dat % put ( dens = dens ) if ( present ( e )) call self % dat % put ( energy = e ) if ( present ( mo_a )) call self % dat % put ( mo_a = mo_a ) if ( present ( mo_b )) call self % dat % put ( mo_b = mo_b ) if ( present ( mo_e_a )) call self % dat % put ( mo_e_a = mo_e_a ) if ( present ( mo_e_b )) call self % dat % put ( mo_e_b = mo_e_b ) if ( present ( pfon )) call self % dat % put ( pfon_obj = pfon ) ! Compute the current error self % current_error = self % compute_error () ! Update subconverger states do i = lbound ( self % sconv , 1 ), ubound ( self % sconv , 1 ) self % sconv ( i )% s % last_setup = self % sconv ( i )% s % last_setup + 1 end do end subroutine scf_conv_add_data !> @brief Computes the new guess to the SCF wavefunction !> @param[out] conv_result Results of the calculation subroutine scf_conv_run ( self , conv_result ) class ( scf_conv ), target , intent ( inout ) :: self class ( scf_conv_result ), allocatable , intent ( out ) :: conv_result class ( subconverger ), pointer :: conv class ( scf_conv_result ), allocatable :: tmp_result conv => self % select_method ( self % current_error ) if ( self % state == conv_state_not_initialized ) then conv_result = scf_conv_result ( error = self % current_error ) return end if conv % iter = conv % iter + 1 self % step = self % step + 1 call conv % setup () ! Nothing left to do on the first iteration, exit if ( self % step == 1 ) then conv_result = scf_conv_result ( & ierr = 0 , & active_converger_name = 'SD' , & error = self % current_error ) return end if ! Solve the set of DIIS linear equations call conv % run ( tmp_result ) call move_alloc ( from = tmp_result , to = conv_result ) end subroutine scf_conv_run !> @brief Select subconverger basing on the current DIIS error value !> @param[in] error DIIS error value !> @return  pointer to selected converger function scf_conv_select ( self , error ) result ( conv ) implicit none class ( scf_conv ), target :: self real ( kind = dp ), intent ( in ) :: error class ( subconverger ), pointer :: conv integer :: i , nconv nconv = ubound ( self % thresholds , 1 ) do i = 0 , nconv if ( error > self % thresholds ( i )) exit end do conv => self % sconv ( min ( i , nconv ))% s ! Continue using the 'SD' converger if ! already initiated if ( i == 0 . and . self % step > 0 ) then conv => self % sconv ( 1 )% s end if ! Use SD by default if no other converger selected if (. not . associated ( conv )) then conv => self % sconv ( 0 )% s end if end function !> @brief Calculate the DIIS error matrix: \\f$ \\mathrm{Err} = FDS - SDF \\f$ !> @details This routine is general for RHF, ROHF, and UHF. !>          Since each of `F`, `D`, `S` are symmetric, this means calculate \\f$ FDS \\f$, !>          and then subtract the transpose from that result. !>          Before entry, `F`, `D` and `S` must be expanded to square storage. !> @return DIIS error value (infinity norm across all matrices) function scf_conv_compute_error ( self ) result ( diis_error ) use mathlib , only : antisymmetrize_matrix , unpack_matrix , pack_matrix use oqp_linalg class ( scf_conv ), target , intent ( inout ) :: self real ( kind = dp ) :: diis_error real ( kind = dp ), pointer :: f (:), d (:), err (:) !   all are (nbf, nbf) square matrices real ( kind = dp ), allocatable :: fock_full (:,:), dens_full (:,:), err_full (:,:), wrk (:,:) integer :: nbf , ifock , nfocks , slot nfocks = self % dat % num_focks nbf = self % dat % ldim slot = self % dat % slot allocate ( fock_full ( nbf , nbf ), & dens_full ( nbf , nbf ), & err_full ( nbf , nbf ), & wrk ( nbf , nbf )) diis_error = 0.0_dp do ifock = 1 , nfocks f => self % dat % get_fock ( - 1 , ifock ) d => self % dat % get_density ( - 1 , ifock ) call unpack_matrix ( f , fock_full , nbf , 'u' ) call unpack_matrix ( d , dens_full , nbf , 'u' ) ! F*D call dsymm ( 'l' , 'u' , nbf , nbf , 1.0_dp , fock_full , nbf , dens_full , nbf , 0.0_dp , wrk , nbf ) ! (F*D)*S call dgemm ( 'n' , 'n' , nbf , nbf , nbf , 1.0_dp , wrk , nbf , self % overlap , nbf , 0.0_dp , err_full , nbf ) ! F*D*S - S*D*F call antisymmetrize_matrix ( err_full , nbf ) ! MV: This step is not really necessary ! Put error matrix into consistent orthonormal basis ! Pulay uses S**-1/2, but here we use Q, Q obeys Q-dagger*S*Q=I ! E-orth = Q-dagger * E * Q, FCKA is used as a scratch `nbf` vector. call dgemm ( 't' , 'n' , nbf , nbf , nbf , 1.0_dp , self % overlap_sqrt , nbf , err_full , nbf , 0.0_dp , wrk , nbf ) call dgemm ( 'n' , 'n' , nbf , nbf , nbf , 1.0_dp , wrk , nbf , self % overlap_sqrt , nbf , 0.0_dp , err_full , nbf ) err => self % dat % buffer ( slot )% errs (:, ifock ) call pack_matrix ( err_full , nbf , err , 'u' ) ! Compute DIIS error (infinity norm of error matrix) diis_error = diis_error + maxval ( abs ( err )) end do deallocate ( fock_full , dens_full , err_full , wrk ) end function scf_conv_compute_error !============================================================================== ! Subconverger Methods !============================================================================== !> @brief Initialize subconverger !> @detail This subroutine takes SCF converger driver as argument. !>         It should be initialized and include all the required parameters. !> @param[in] params Current SCF converger driver subroutine subconverger_init ( self , params ) class ( subconverger ), intent ( inout ) :: self type ( scf_conv ), target , intent ( in ) :: params self % iter = 0 self % last_setup = 1024 self % dat => params % dat end subroutine subconverger_init !> @brief Finalize subconverger subroutine subconverger_clean ( self ) class ( subconverger ), intent ( inout ) :: self self % iter = 0 self % last_setup = 1024 self % dat => null () end subroutine subconverger_clean !============================================================================== ! noconv_converger Methods !============================================================================== !> @brief Initialize SD subconverger !> @param[in] params current SCF converger driver subroutine noconv_init ( self , params ) class ( noconv_converger ), intent ( inout ) :: self type ( scf_conv ), target , intent ( in ) :: params if ( self % iter > 0 ) call self % clean () call self % subconverger_init ( params ) self % conv_name = 'SD' end subroutine noconv_init !> @brief Computes the new guess to the SCF wavefunction !> @param[out] res results of the calculation subroutine noconv_run ( self , res ) class ( noconv_converger ), target , intent ( inout ) :: self class ( scf_conv_result ), allocatable , intent ( out ) :: res real ( kind = dp ) :: diis_error integer :: ifock allocate ( scf_conv_result :: res ) res = scf_conv_result ( ierr = 0 , active_converger_name = 'SD' , dat = self % dat ) ! Compute error diis_error = 0.0_dp do ifock = 1 , self % dat % num_focks diis_error = max ( diis_error , maxval ( abs ( self % dat % get_err ( - 1 , ifock )))) end do res % error = diis_error end subroutine noconv_run !> @brief Prepare subconverger to run subroutine noconv_setup ( self ) class ( noconv_converger ), intent ( inout ) :: self self % last_setup = 0 end subroutine noconv_setup !============================================================================== ! cdiis_converger Methods !============================================================================== !> @brief Initialize C-DIIS subconverger !> @detail This subroutine takes SCF converger driver as argument. !>         It should be initialized and include all the required parameters. !> @param[in] params Current SCF converger driver subroutine cdiis_init ( self , params ) class ( cdiis_converger ), intent ( inout ) :: self type ( scf_conv ), target , intent ( in ) :: params if ( self % iter > 0 ) call self % clean () call self % subconverger_init ( params ) self % conv_name = 'C-DIIS' self % verbose = params % verbose self % maxdiis = params % iter_space_size allocate ( self % a ( self % maxdiis , self % maxdiis ), source = 0.0_dp ) end subroutine cdiis_init !> @brief Finalize C-DIIS subconverger subroutine cdiis_clean ( self ) class ( cdiis_converger ), intent ( inout ) :: self call self % subconverger_clean () self % verbose = 0 if ( allocated ( self % a )) deallocate ( self % a ) end subroutine cdiis_clean !> @brief Computes the new guess to the SCF wavefunction using C-DIIS !> @param[out] res Results of the calculation subroutine cdiis_run ( self , res ) use mathlib , only : solve_linear_equations use io_constants , only : iw class ( cdiis_converger ), target , intent ( inout ) :: self class ( scf_conv_result ), allocatable , intent ( out ) :: res !      integer :: i, na, cur, info, ifock !    real(kind=dp) :: a_loc(self%maxdiis+1, self%maxdiis+1) integer :: i , na , cur , info , ifock , trial , k real ( kind = dp ) :: a_loc ( self % maxdiis + 1 , self % maxdiis + 1 ), a_sys ( self % maxdiis + 1 , self % maxdiis + 1 ) real ( kind = dp ) :: delta real ( kind = dp ) :: x_loc ( self % maxdiis + 1 ) real ( kind = dp ), allocatable :: x (:) real ( kind = dp ), pointer :: err (:) real ( kind = dp ) :: diis_error allocate ( scf_conv_interp_result :: res ) res % dat => self % dat res % active_converger_name = self % conv_name select type ( res ) class is ( scf_conv_interp_result ) res % pstart = 1 res % pend = self % dat % num_saved end select res % ierr = 3 ! Need to set up DIIS equations first if ( self % last_setup /= 0 ) return na = self % dat % num_saved ! Solve the set of DIIS linear equations ! Add mild Tikhonov regularization before shrinking the subspace a_loc (: self % maxdiis , : self % maxdiis ) = self % a a_loc ( 1 : na , na + 1 ) = - 1.0_dp a_loc ( na + 1 , 1 : na ) = - 1.0_dp a_loc ( na + 1 , na + 1 ) = 0.0_dp do i = na , 1 , - 1 ! Helper index, needed for dimension reduction in case of instability cur = na - i + 1 x_loc = 0.0_dp x_loc ( na + 1 ) = - 1.0_dp info = 0 a_sys = a_loc call solve_linear_equations ( a_sys ( cur :, cur :), x_loc ( cur :), i + 1 , 1 , self % maxdiis + 1 , info ) if ( info > 0 ) then do trial = 1 , 3 delta = 1.0e-12_dp * ( 1 0.0_dp ** ( trial - 1 )) a_sys = a_loc do k = 0 , i - 1 a_sys ( cur + k , cur + k ) = a_sys ( cur + k , cur + k ) + delta end do call solve_linear_equations ( a_sys ( cur :, cur :), x_loc ( cur :), i + 1 , 1 , self % maxdiis + 1 , info ) if ( info == 0 ) exit end do end if if ( info <= 0 ) exit write ( iw , * ) 'Reducing DIIS Equation size by 1 for numerical stability' end do ! if ( info < 0 ) then res % ierr = 2 ! Illegal value in DSYSV else if ( info > 0 ) then res % ierr = 1 ! Singular DIIS matrix else res % ierr = 0 ! normal exit x = x_loc ( 1 : self % maxdiis ) select type ( res ) class is ( scf_conv_interp_result ) call move_alloc ( from = x , to = res % coeffs ) end select end if ! Compute DIIS error from the latest iteration diis_error = 0.0_dp do ifock = 1 , self % dat % num_focks err => self % dat % get_err ( - 1 , ifock ) diis_error = max ( diis_error , maxval ( abs ( err ))) end do res % error = diis_error end subroutine cdiis_run !> @brief Prepare C-DIIS subconverger to run subroutine cdiis_setup ( self ) class ( cdiis_converger ), intent ( inout ) :: self integer :: i , j , na , maxdiis , ifock , nfocks real ( kind = dp ) :: factor maxdiis = self % maxdiis na = self % dat % num_saved nfocks = self % dat % num_focks ! Factor to account RHF/UHF cases factor = 1.0_dp / nfocks if ( self % last_setup > 1 ) then ! DIIS matrix is rather old, generate it from scratch self % old_dim = na self % a = 0.0_dp do ifock = 1 , nfocks do i = 1 , na do j = 1 , i self % a ( j , i ) = self % a ( j , i ) + factor * dot_product ( & self % dat % get_err ( j , ifock ), & self % dat % get_err ( i , ifock )) end do end do end do else if ( self % last_setup == 1 ) then ! DIIS matrix is old by 1 iteration, just update it ! If the current number of iterations exceeds the dimension of A matrix: ! discard the data of oldest iteration by shifting the bottom-rigth square ! to the top-left corner if ( self % old_dim >= maxdiis ) then self % a ( 1 : maxdiis - 1 , 1 : maxdiis - 1 ) = self % a ( 2 : maxdiis , 2 : maxdiis ) end if self % old_dim = na !     Compute new elements (`na`-th column) self % a (:, na ) = 0.0_dp do ifock = 1 , nfocks do i = 1 , na self % a ( i , na ) = self % a ( i , na ) + factor * dot_product ( & self % dat % get_err ( na , ifock ), & self % dat % get_err ( i , ifock )) end do end do end if ! DIIS matrix is already prepared nothing to do here self % last_setup = 0 end subroutine cdiis_setup !============================================================================== ! ediis_converger Methods !============================================================================== !> @brief Initialize E-DIIS subconverger !> @detail This subroutine takes SCF converger driver as argument. !>   It should be initialized and include all the required parameters. !> @param[in] params current SCF converger driver subroutine ediis_init ( self , params ) class ( ediis_converger ), intent ( inout ) :: self type ( scf_conv ), target , intent ( in ) :: params call self % cdiis_converger % init ( params ) self % conv_name = 'E-DIIS' self % fun => ediis_fun allocate ( self % b ( self % maxdiis )) allocate ( self % xlog ( self % maxdiis , self % maxdiis ), source = 0.0_dp ) end subroutine ediis_init !> @brief Finalize E-DIIS subconverger subroutine ediis_clean ( self ) class ( ediis_converger ), intent ( inout ) :: self call self % cdiis_converger % clean () if ( allocated ( self % b )) deallocate ( self % b ) if ( allocated ( self % xlog )) deallocate ( self % xlog ) end subroutine ediis_clean !> @brief Prepare E-DIIS subconverger to run subroutine ediis_setup ( self ) class ( ediis_converger ), intent ( inout ) :: self integer :: i , j , na , maxdiis , ifock , nfocks real ( kind = dp ) :: factor maxdiis = self % maxdiis na = self % dat % num_saved nfocks = self % dat % num_focks ! Factor to account RHF/UHF cases factor = 1.0_dp / nfocks if ( self % last_setup > 1 ) then ! DIIS matrix is rather old, generate it from scratch self % old_dim = na self % a = 0.0_dp do ifock = 1 , nfocks do i = 1 , na do j = 1 , i - 1 self % a ( j , i ) = self % a ( j , i ) + factor * dot_product ( & self % dat % get_density ( j , ifock ) - self % dat % get_density ( i , ifock ), & self % dat % get_fock ( j , ifock ) - self % dat % get_fock ( i , ifock )) self % a ( i , j ) = self % a ( j , i ) end do end do end do else if ( self % last_setup == 1 ) then ! DIIS matrix is old by 1 iteration, just update it ! If the current number of iterations exceeds the dimension of A matrix: ! discard the data of oldest iteration by shifting the bottom-rigth square ! to the top-left corner if ( self % old_dim >= maxdiis ) then self % a ( 1 : maxdiis - 1 , 1 : maxdiis - 1 ) = self % a ( 2 : maxdiis , 2 : maxdiis ) end if self % old_dim = na !     Compute new elements (`na`-th column) self % a (:, na ) = 0.0_dp do ifock = 1 , nfocks do j = 1 , na self % a ( j , na ) = self % a ( j , na ) + factor * dot_product ( & self % dat % get_density ( j , ifock ) - self % dat % get_density ( na , ifock ), & self % dat % get_fock ( j , ifock ) - self % dat % get_fock ( na , ifock )) end do end do self % a ( na , 1 : na - 1 ) = self % a ( 1 : na - 1 , na ) end if do i = 1 , na self % b ( i ) = self % dat % get_energy ( i ) end do ! DIIS matrix is already prepared nothing to do here self % last_setup = 0 end subroutine ediis_setup !> @brief Computes the new guess to the SCF wavefunction using E-DIIS !> @param[out] res  results of the calculation subroutine ediis_run ( self , res ) use io_constants , only : iw use nlopt class ( ediis_converger ), target , intent ( inout ) :: self class ( scf_conv_result ), allocatable , intent ( out ) :: res real ( kind = dp ), parameter :: tol = 1.0e-5_dp real ( kind = dp ), parameter :: constrtol = 1.0e-8_dp real ( kind = dp ) :: minf , minf_min real ( kind = dp ), allocatable :: x (:), xmin (:) real ( kind = dp ), pointer :: err (:) real ( kind = dp ) :: diis_error integer ( kind = 4 ) :: ires integer :: na , i , j , ifock logical :: is_a_repeat ! NLOpt's f77-style API stores a C POINTER in the opt handle argument ! (NLOpt documents it as integer*8), so the handles must be 8 bytes ! REGARDLESS of the build's default integer width. With a default-width ! declaration, LP64 builds (4-byte default integer, e.g. native macOS ! Accelerate) let nlo_create() write an 8-byte pointer into 4-byte storage ! => stack corruption => SIGSEGV (exit -11) in every EDIIS/ADIIS SCF. integer ( kind = 8 ) :: opt_global , opt_lbfgs type ( ediis_opt_data ) :: t allocate ( scf_conv_interp_result :: res ) res % dat => self % dat res % active_converger_name = self % conv_name select type ( res ) class is ( scf_conv_interp_result ) res % pstart = 1 res % pend = self % dat % num_saved end select res % ierr = 3 ! Need to set up DIIS equations first if ( self % last_setup /= 0 ) return na = self % dat % num_saved if ( self % iter > self % maxdiis ) then do i = 1 , self % maxdiis - 1 self % xlog (:, i ) = cshift ( self % xlog (:, i + 1 ), 1 ) self % xlog ( i + 1 :, i ) = 0.0_dp end do end if allocate ( x ( na ), xmin ( na )) opt_global = 0 minf_min = huge ( 1.0_dp ) ! Initialize E-DIIS equation parameters for NLOpt t = ediis_opt_data ( A = self % a ( 1 : na , 1 : na ), b = self % b ( 1 : na ), fun = self % fun ) ! Set up the Improved Stochastic Ranking Evolution Strategy ! It will run coarse global optimization, which will be further refined via L-BFGS call nlo_create ( opt_global , NLOPT_GN_ISRES , na ) ! Max. number of calls to the objective function call nlo_set_maxeval ( ires , opt_global , 100 * ( na + 1 )) ! Relative convergence tolerance for arguments call nlo_set_xtol_rel ( ires , opt_global , 1.0e-2_dp ) ! Absolute convergence tolerance for function value call nlo_set_ftol_abs ( ires , opt_global , 1.0e-4_dp ) ! Relative convergence tolerance for function value call nlo_set_ftol_rel ( ires , opt_global , 1.0e-4_dp ) ! Sum of coeffs equal to 1 call nlo_add_equality_constraint ( ires , opt_global , eadiis_constraints , 0 , constrtol ) ! 0 <= c_i <= 1 call nlo_set_lower_bounds1 ( ires , opt_global , 0.0_dp ) call nlo_set_upper_bounds1 ( ires , opt_global , 1.0_dp ) ! Objective function call nlo_set_min_objective ( ires , opt_global , eadiis_fun , t ) x = 1.0_dp / na call nlo_optimize ( ires , opt_global , x (: na ), minf ) call nlo_destroy ( opt_global ) ! Refine the results of global optimization via L-BFGS opt_lbfgs = 0 call nlo_create ( opt_lbfgs , NLOPT_LD_LBFGS , na ) call nlo_set_xtol_rel ( ires , opt_lbfgs , tol ) call nlo_set_ftol_abs ( ires , opt_lbfgs , tol * tol ) call nlo_set_ftol_rel ( ires , opt_lbfgs , tol * tol ) ! Here, the modified E-DIIS equations are used, because L-BFGS does not support ! equality constraints ! They utilize the following variable substitution: ! c_i = t_i&#94;2/\\sum_i{t_i&#94;2} call nlo_set_min_objective ( ires , opt_lbfgs , eadiis_objective , t ) call nlo_optimize ( ires , opt_lbfgs , x (: na ), minf ) ! Because we used modified E-DIIS equations, we need to compute ! coefficients `c` from `t`: x = x ** 2 / sum ( x ** 2 ) ! Get prediction of the new SCF energy call eadiis_fun ( minf , int ( na , 4 ), x , x , int ( 0 , 4 ), t ) if ( ires < 0 ) then if ( self % verbose > 2 ) write ( iw , '(10X,\"*** nlopt0 failed:\",I4,\" ***\")' ) ires elseif ( minf < minf_min ) then is_a_repeat = any ([( norm2 ( self % xlog (: na , j ) - x (: na )) < 1.0e-4_dp , & j = 1 , min ( self % iter , self % maxdiis ))]) . or . & any ( 1.0_dp - x ( 1 : na - 1 ) < 1.0e-4_dp ) if (. not . is_a_repeat ) then minf_min = minf xmin = x if ( self % verbose > 2 ) then write ( iw , '(A,*(F15.6))' ) 'nlopt0: improving x at ' , xmin (:) write ( iw , '(A,*(F15.6))' ) 'nlopt0: improved val = ' , minf end if elseif ( self % verbose > 2 ) then write ( iw , '(A,*(F15.6))' ) 'nlopt0: found rep at ' , x (:) write ( iw , '(A,*(F15.6))' ) 'nlopt0: rep val = ' , minf end if else if ( self % verbose > 2 ) then write ( iw , '(A,*(F15.6))' ) 'nlopt0: found min at ' , x (:) write ( iw , '(A,*(F15.6))' ) 'nlopt0: min val = ' , minf end if end if ! If no solution found, try the alternative: ! Start from the trivial guess [x(1:n-1)=0, x(n) = 1] ! then run two L-BFGS iterations and average with ! [x(1:i-i), x(i+1:n) = 0, x(i) = 1] vector and run few L-BFGS steps again ! for all [ i = n-1, 1 ] and then [i = 1, n] if ( minf_min > 1.0e99_dp ) then call nlo_set_maxeval ( ires , opt_lbfgs , 2 ) call nlo_set_xtol_rel ( ires , opt_lbfgs , 0.1_dp ) xmin = 0.0_dp xmin ( na ) = 1.0_dp do i = na - 1 , 1 , - 1 x = 0.0_dp x ( i ) = 1.0_dp xmin = ( xmin + x ) / ( 1 + sum ( x )) call nlo_optimize ( ires , opt_lbfgs , xmin , minf ) if ( ires < 0 ) then if ( self % verbose > 2 ) then write ( iw , '(10X,\"*** nlopt2 failed:\",I4,\" ***\")' ) ires end if exit end if xmin = xmin ** 2 / sum ( xmin ** 2 ) end do if ( ires >= 0 ) then do i = 1 , na x = 0.0_dp x ( i ) = 1.0_dp xmin = ( xmin + x ) / ( 1 + sum ( x )) call nlo_optimize ( ires , opt_lbfgs , xmin , minf ) if ( ires < 0 ) then if ( self % verbose > 2 ) then write ( iw , '(10X,\"*** nlopt2 failed:\",I4,\" ***\")' ) ires end if exit end if xmin = xmin ** 2 / sum ( xmin ** 2 ) end do end if ! If still no success, the default is minimum energy + small contribution from others: if ( ires < 0 ) then xmin = 1.0_dp xmin ( minloc ( self % b ( 1 : na - 1 ))) = 1 0.0_dp xmin = xmin / sum ( xmin ) if ( self % verbose > 2 ) write ( iw , * ) 'nlopt2: unoptimal default' end if call eadiis_fun ( minf_min , int ( na , 4 ), xmin , xmin , int ( 0 , 4 ), t ) end if minf = minf_min self % xlog (: na , min ( self % iter , self % maxdiis )) = xmin ( 1 : na ) call nlo_destroy ( opt_lbfgs ) res % ierr = 0 select type ( res ) class is ( scf_conv_interp_result ) call move_alloc ( from = xmin , to = res % coeffs ) end select ! compute diis error from the latest iteration diis_error = 0.0_dp do ifock = 1 , self % dat % num_focks err => self % dat % get_err ( - 1 , ifock ) diis_error = max ( diis_error , maxval ( abs ( err ))) end do res % error = diis_error end subroutine ediis_run !============================================================================== ! adiis_converger Methods !============================================================================== !> @brief Initialize A-DIIS subconverger !> @detail This subroutine takes SCF converger driver as argument. !>   It should be initialized and include all the required parameters. !> @param[in] params current SCF converger driver subroutine adiis_init ( self , params ) class ( adiis_converger ), intent ( inout ) :: self type ( scf_conv ), target , intent ( in ) :: params call self % cdiis_converger % init ( params ) self % conv_name = 'A-DIIS' self % fun => adiis_fun allocate ( self % b ( self % maxdiis )) allocate ( self % xlog ( self % maxdiis , self % maxdiis ), source = 0.0_dp ) end subroutine adiis_init !> @brief Prepare A-DIIS subconverger to run subroutine adiis_setup ( self ) class ( adiis_converger ), intent ( inout ) :: self integer :: i , j , na , maxdiis , ifock , nfocks real ( kind = dp ) :: factor maxdiis = self % maxdiis na = self % dat % num_saved nfocks = self % dat % num_focks ! Factor to account RHF/UHF cases factor = 1.0_dp / nfocks self % old_dim = na self % a = 0.0_dp self % b = 0.0_dp do ifock = 1 , nfocks do i = 1 , na do j = 1 , na self % a ( j , i ) = self % a ( j , i ) + 0.5_dp * factor * dot_product ( & self % dat % get_density ( j , ifock ) - self % dat % get_density ( - 1 , ifock ), & self % dat % get_fock ( j , ifock ) - self % dat % get_fock ( - 1 , ifock )) end do self % b ( i ) = self % b ( i ) + factor * dot_product ( & self % dat % get_density ( i , ifock ) - self % dat % get_density ( - 1 , ifock ), & self % dat % get_fock ( - 1 , ifock )) end do end do ! DIIS matrix is already prepared nothing to do here self % last_setup = 0 end subroutine adiis_setup !============================================================================== ! Optimization Helper Routines !============================================================================== !> @brief Modified E/A-DIIS objective function wrapper, which allows to use unconstrained optimization !> @details The following variable substitution is used: !>          \\f$ c_i = t_i&#94;2 / \\sum_i{t_i&#94;2} \\f$ !> @note This is standard interface to work with NLOpt library !> @param[out] val Function value !> @param[in] n Dimension of the problem !> @param[in] t Vector of arguments !> @param[out] grad Vector of function gradient !> @param[in] need_gradient Flag to turn on computing gradient, 0 - gradient not computed !> @param[in] d Datatype storing function parameters subroutine eadiis_objective ( val , n , t , grad , need_gradient , d ) integer ( kind = 4 ), intent ( in ) :: n , need_gradient real ( kind = 8 ) :: val , t ( n ), grad ( n ) type ( ediis_opt_data ), intent ( in ) :: d real ( kind = 8 ) :: x ( n ), tnorm , jac ( n , n ) integer :: i , j tnorm = 1.0_dp / sum ( t ( 1 : n ) ** 2 ) x = ( t ( 1 : n ) ** 2 ) * tnorm call d % fun ( val , n , x , grad , need_gradient , d ) if ( need_gradient /= 0 ) then jac = 0.0_dp do i = 1 , n jac ( i , i ) = 1.0_dp do j = 1 , n jac ( j , i ) = 2.0_dp * tnorm * t ( j ) * ( jac ( j , i ) - x ( i )) end do end do grad ( 1 : n ) = matmul ( jac , grad ( 1 : n )) end if end subroutine eadiis_objective !> @brief Non-modified E/A-DIIS objective function wrapper !> @note This is standard interface to work with NLOpt library !> @param[out] val Function value !> @param[in] n Dimension of the problem !> @param[in] t Vector of arguments !> @param[out] grad Vector of function gradient !> @param[in] need_gradient Flag to turn on computing gradient, 0 - gradient not computed !> @param[in] d Datatype storing function parameters subroutine eadiis_fun ( val , n , x , grad , need_gradient , d ) integer ( kind = 4 ), intent ( in ) :: n , need_gradient real ( kind = 8 ) :: val , x ( n ), grad ( n ) type ( ediis_opt_data ), intent ( in ) :: d call d % fun ( val , n , x , grad , need_gradient , d ) end subroutine eadiis_fun !> @brief E-DIIS objective function calculation !> @note This is standard interface to work with NLOpt library !> @param[out] val Function value !> @param[in] n Dimension of the problem !> @param[in] t Vector of arguments !> @param[out] grad Vector of function gradient !> @param[in] need_gradient Flag to turn on computing gradient, 0 - gradient not computed !> @param[in] d Datatype storing function parameters subroutine ediis_fun ( val , n , x , grad , need_gradient , d ) integer ( kind = 4 ), intent ( in ) :: n , need_gradient real ( kind = 8 ) :: val , x ( * ), grad ( * ) type ( ediis_opt_data ), intent ( in ) :: d if ( need_gradient /= 0 ) then grad ( 1 : n ) = d % b ( 1 : n ) - matmul ( d % A ( 1 : n , 1 : n ), x ( 1 : n )) end if val = dot_product ( x ( 1 : n ), d % b ( 1 : n )) - & 0.5_dp * dot_product ( x ( 1 : n ), matmul ( d % A ( 1 : n , 1 : n ), x ( 1 : n ))) end subroutine ediis_fun !> @brief E/A-DIIS constraints !> @note This is standard interface to work with NLOpt library !> @param[out] val Function value !> @param[in] n Dimension of the problem !> @param[in] t Vector of arguments !> @param[out] grad Vector of function gradient !> @param[in] need_gradient Flag to turn on computing gradient, 0 - gradient not computed !> @param[in] d Datatype storing function parameters subroutine eadiis_constraints ( val , n , x , grad , need_gradient , d ) integer ( kind = 4 ), intent ( in ) :: n , need_gradient real ( kind = 8 ) :: val , x ( n ), grad ( n ) class ( ediis_converger ), intent ( in ) :: d if ( need_gradient /= 0 ) grad = 1.0_dp val = sum ( x ) - 1.0_dp end subroutine eadiis_constraints !> @brief A-DIIS objective function calculation !> @note This is standard interface to work with NLOpt library !> @param[out] val Function value !> @param[in] n Dimension of the problem !> @param[in] t Vector of arguments !> @param[out] grad Vector of function gradient !> @param[in] need_gradient Flag to turn on computing gradient, 0 - gradient not computed !> @param[in] d Datatype storing function parameters subroutine adiis_fun ( val , n , x , grad , need_gradient , d ) integer ( kind = 4 ), intent ( in ) :: n , need_gradient real ( kind = 8 ) :: val , x ( * ), grad ( * ) type ( ediis_opt_data ), intent ( in ) :: d if ( need_gradient /= 0 ) then grad ( 1 : n ) = 2.0_dp * d % b ( 1 : n ) + matmul ( d % A ( 1 : n , 1 : n ), x ( 1 : n )) + & matmul ( x ( 1 : n ), d % A ( 1 : n , 1 : n )) end if val = d % b ( n ) + 2.0_dp * dot_product ( x ( 1 : n ), d % b ( 1 : n )) + & dot_product ( x ( 1 : n ), matmul ( d % A ( 1 : n , 1 : n ), x ( 1 : n ))) end subroutine adiis_fun !============================================================================== ! Debug Printing (optional) !============================================================================== !> @brief Debug printing of the DIIS equation data subroutine diis_print_equation ( self ) use printing , only : print_square use io_constants , only : iw class ( cdiis_converger ), intent ( in ) :: self integer :: num_saved num_saved = self % dat % num_saved write ( iw , '(\"(dbg) --------------------------------------------------\")' ) write ( iw , '(\"(dbg) DIIS iteration / max.dim. : \",G0,\" / \",G0)' ) self % iter , self % maxdiis write ( iw , '(\"(dbg)\",I4,\" Fock sets stored\")' ) num_saved write ( iw , '(\"(dbg) --------------------------------------------------\")' ) write ( iw , '(\"(dbg) Current DIIS equation matrix:\")' ) call print_square ( self % a , num_saved , num_saved , ubound ( self % a , 1 ), tag = '(dbg)' ) write ( iw , '(\"(dbg) --------------------------------------------------\")' ) select type ( self ) class is ( ediis_converger ) write ( iw , '(\"(dbg) Current DIIS equation vector:\")' ) write ( iw , '(*(ES15.7,\",\"))' ) self % b ( 1 : num_saved ) end select end subroutine diis_print_equation !============================================================================== ! soscf_converger Methods !============================================================================== !> @brief Initialize the SOSCF converger !> @param[inout] self The SOSCF converger instance !> @param[in] params SCF convergence parameters from the driver subroutine soscf_init ( self , params ) class ( soscf_converger ), intent ( inout ) :: self type ( scf_conv ), target , intent ( in ) :: params integer :: nvec , m_max , istat , nvir_a , nvir_b ! Initialize base class call self % subconverger_init ( params ) self % conv_name = 'SOSCF' self % nfocks = params % dat % num_focks self % verbose = params % verbose self % nbf = params % dat % ldim self % nocc_a = params % dat % nelec_a self % nocc_b = params % dat % nelec_b self % nbf_tri = self % nbf * ( self % nbf + 1 ) / 2 self % m_max = params % dat % num_slots self % m_history = 0 self % dat => params % dat self % overlap => params % overlap self % overlap_invsqrt => params % overlap_sqrt self % first_macro = . true . self % scf_type = params % scf_type nvir_a = self % nbf - self % nocc_a nvir_b = self % nbf - self % nocc_b ! Calculate gradient vector size (nvec) select case ( self % scf_type ) case ( 1 ) ! RHF self % nvec = self % nocc_a * nvir_a case ( 2 ) ! UHF self % nvec = self % nocc_a * nvir_a + self % nocc_b * nvir_b case ( 3 ) ! ROHF self % nvec = self % nocc_b * nvir_b + ( self % nocc_a - self % nocc_b ) * nvir_a end select ! Allocate working matrices istat = 0 if (. not . allocated ( self % rho_history )) & allocate ( self % rho_history ( self % m_max ), stat = istat , source = 0.0_dp ) if (. not . allocated ( self % work_1 )) & allocate ( self % work_1 ( self % nbf , self % nbf ), stat = istat , source = 0.0_dp ) if (. not . allocated ( self % work_2 )) & allocate ( self % work_2 ( self % nbf , self % nbf ), stat = istat , source = 0.0_dp ) if (. not . allocated ( self % work_3 )) & allocate ( self % work_3 ( self % nbf , self % nbf ), stat = istat , source = 0.0_dp ) ! Allocate L-BFGS history arrays if (. not . allocated ( self % s_history )) & allocate ( self % s_history ( self % nvec , self % m_max ), stat = istat , source = 0.0_dp ) if (. not . allocated ( self % grad )) & allocate ( self % grad ( self % nvec ), stat = istat , source = 0.0_dp ) if (. not . allocated ( self % x )) & allocate ( self % x ( self % nvec ), stat = istat , source = 0.0_dp ) if (. not . allocated ( self % x_prev )) & allocate ( self % x_prev ( self % nvec ), stat = istat , source = 0.0_dp ) if (. not . allocated ( self % grad_prev )) & allocate ( self % grad_prev ( self % nvec ), stat = istat , source = 0.0_dp ) if (. not . allocated ( self % y_history )) & allocate ( self % y_history ( self % nvec , self % m_max ), stat = istat , source = 0.0_dp ) if (. not . allocated ( self % upd_history )) & allocate ( self % upd_history ( self % nvec , self % m_max ), stat = istat , source = 0.0_dp ) if (. not . allocated ( self % h_inv )) & allocate ( self % h_inv ( self % nvec ), stat = istat , source = 0.0_dp ) ! Allocate SOSCF arrays if (. not . allocated ( self % mo_a )) & allocate ( self % mo_a ( self % nbf , self % nbf ), stat = istat , source = 0.0_dp ) if (. not . allocated ( self % dens_a )) & allocate ( self % dens_a ( self % nbf_tri ), stat = istat , source = 0.0_dp ) if (. not . allocated ( self % dens_a_old )) & allocate ( self % dens_a_old ( self % nbf_tri ), stat = istat , source = 0.0_dp ) if ( self % scf_type > 1 ) then if (. not . allocated ( self % mo_b )) & allocate ( self % mo_b ( self % nbf , self % nbf ), stat = istat , source = 0.0_dp ) if (. not . allocated ( self % dens_b )) & allocate ( self % dens_b ( self % nbf_tri ), stat = istat , source = 0.0_dp ) if (. not . allocated ( self % dens_b_old )) & allocate ( self % dens_b_old ( self % nbf_tri ), stat = istat , source = 0.0_dp ) end if if ( istat /= 0 ) then write ( iw , '(A)' ) 'ERROR: Failed to allocate arrays in soscf_init' stop end if end subroutine soscf_init !> @brief Clean up SOSCF converger !> @param[inout] self The SOSCF converger instance subroutine soscf_clean ( self ) class ( soscf_converger ), intent ( inout ) :: self if ( allocated ( self % rho_history )) deallocate ( self % rho_history ) if ( allocated ( self % work_1 )) deallocate ( self % work_1 ) if ( allocated ( self % work_2 )) deallocate ( self % work_2 ) if ( allocated ( self % work_3 )) deallocate ( self % work_3 ) if ( allocated ( self % s_history )) deallocate ( self % s_history ) if ( allocated ( self % y_history )) deallocate ( self % y_history ) if ( allocated ( self % upd_history )) deallocate ( self % upd_history ) if ( allocated ( self % grad )) deallocate ( self % grad ) if ( allocated ( self % grad_prev )) deallocate ( self % grad_prev ) if ( allocated ( self % x_prev )) deallocate ( self % x_prev ) if ( allocated ( self % x )) deallocate ( self % x ) if ( allocated ( self % h_inv )) deallocate ( self % h_inv ) if ( allocated ( self % mo_a )) deallocate ( self % mo_a ) if ( allocated ( self % dens_a )) deallocate ( self % dens_a ) if ( allocated ( self % mo_b )) deallocate ( self % mo_b ) if ( allocated ( self % dens_b )) deallocate ( self % dens_b ) if ( allocated ( self % dens_a_old )) deallocate ( self % dens_a_old ) if ( allocated ( self % dens_b_old )) deallocate ( self % dens_b_old ) call self % subconverger_clean () end subroutine soscf_clean !> @brief Setup SOSCF for the current iteration !> @param[inout] self The SOSCF converger instance subroutine soscf_setup ( self ) class ( soscf_converger ), intent ( inout ) :: self ! Data verification on each setup call self % last_setup = 0 end subroutine soscf_setup !> @brief Run the SOSCF convergence step !> @param[inout] self The SOSCF converger instance !> @param[out] res Convergence result subroutine soscf_run ( self , res ) use mathlib , only : unpack_matrix use oqp_linalg class ( soscf_converger ), target , intent ( inout ) :: self class ( scf_conv_result ), allocatable , intent ( out ) :: res ! Local variables type ( pfon_t ), pointer :: pfon => null () real ( kind = dp ), pointer :: occ_a (:) => null () real ( kind = dp ), pointer :: occ_b (:) => null () real ( kind = dp ), pointer :: fock_ao_a (:), fock_ao_b (:) real ( kind = dp ), pointer :: mo_e_a (:), mo_e_b (:) real ( kind = dp ) :: grad_norm , alpha , sy , rms_dp real ( kind = dp ) :: grad_norm_ratio integer :: iter , istat integer :: i , nocc ! Allocate result object allocate ( scf_conv_soscf_result :: res ) res % dat => self % dat res % active_converger_name = self % conv_name if ( self % last_setup /= 0 ) then if ( self % verbose > 0 ) write ( iw , '(A)' ) 'SOSCF: Setup not called, returning' return end if res % ierr = 0 istat = 0 ! --- Step 1: Extract current data from converger_data --- mo_e_a => self % dat % get_mo_e_a ( - 1 ) fock_ao_a => self % dat % get_fock ( - 1 , 1 ) self % mo_a = self % dat % get_mo_a ( - 1 ) self % dens_a = self % dat % get_density ( - 1 , 1 ) if ( self % scf_type > 1 ) then mo_e_b => self % dat % get_mo_e_b ( - 1 ) fock_ao_b => self % dat % get_fock ( - 1 , 2 ) self % mo_b = self % dat % get_mo_b ( - 1 ) self % dens_b = self % dat % get_density ( - 1 , 2 ) end if if ( self % scf_type == 1 ) then call self % rms_density ( d_new_a = self % dens_a , & d_old_a = self % dens_a_old , & rms_dp = rms_dp ) self % dens_a_old = self % dens_a else call self % rms_density ( self % dens_a , self % dens_b , & self % dens_a_old , self % dens_b_old , rms_dp ) self % dens_a_old = self % dens_a self % dens_b_old = self % dens_b end if pfon => self % dat % get_pfon ( - 1 ) if ( associated ( pfon )) then ! Get occupation arrays directly from pfon occ_a => pfon % occ_a if ( self % scf_type > 1 ) then occ_b => pfon % occ_b end if else ! Allocate local occupation arrays nocc = min ( self % nocc_a , self % nocc_b ) allocate ( occ_a ( nocc ), source = 0.0_dp ) occ_a = 2 if ( self % scf_type /= 1 ) occ_a = 1 end if ! --- Step 2: Initialize LBFGS history --- if ( self % first_macro ) then self % s_history = 0.0_dp self % y_history = 0.0_dp self % upd_history = 0.0_dp self % grad_prev = 0.0_dp self % grad = 0.0_dp self % x = 0.0_dp self % x_prev = 0.0_dp self % m_history = 0 if ( self % m_history == 0 ) & call self % init_hess_inv ( mo_e_a , mo_e_b ) self % first_macro = . false . if ( self % verbose > 1 ) then write ( iw , '(A,E20.10)' ) 'DEBUG: soscf_run: Input: grad_thresh=' , self % grad_thresh write ( iw , '(A,E20.10)' ) 'DEBUG: soscf_run: Input: level_shift=' , self % level_shift end if end if call self % calc_orb_grad ( self % grad , fock_ao_a , fock_ao_b , self % mo_a , self % mo_b ) grad_norm = sqrt ( dot_product ( self % grad , self % grad ) / self % nvec ) if ( self % m_history == 0 ) self % rms_grad_prev = grad_norm if ( self % verbose > 1 ) & write ( iw , '(A,I3,A,E20.10)' ) 'DEBUG soscf_run:1:calc_orb_grad: iter=' , 0 , ' grad_norm=' , grad_norm if ( self % verbose > 1 ) & write ( iw , '(A,E20.10)' ) 'DEBUG soscf_run: init: grad_thresh=' , self % grad_thresh ! Check convergence if ( grad_norm < self % grad_thresh ) then if ( self % verbose > 1 ) & write ( iw , '(A,I3,A,E20.10)' ) 'DEBUG soscf_run: loop exit: iter=' , iter , ' grad_norm=' , grad_norm end if ! Compute trail vector x using J. Phys. Chem. 1992, 96, 9768-9774 call self % bfgs ( self % x ) if ( self % scf_type == 1 ) then call self % rotate_orbs ( self % x , self % nocc_a , self % nocc_a , self % mo_a ) elseif ( self % scf_type == 2 ) then call self % rotate_orbs ( self % x , self % nocc_a , self % nocc_a , self % mo_a ) call self % rotate_orbs ( self % x ( self % nocc_a * ( self % nbf - self % nocc_a ) + 1 : self % nvec )& , self % nocc_b , self % nocc_b , self % mo_b ) elseif ( self % scf_type == 3 ) then call self % rotate_orbs ( self % x , self % nocc_a , self % nocc_b , self % mo_a ) self % mo_b ( 1 : self % nbf , 1 : self % nbf ) = self % mo_a ( 1 : self % nbf , 1 : self % nbf ) end if self % m_history = self % m_history + 1 self % grad_prev = self % grad ! --- Step 4: Update result and converger_data --- res % ierr = 0 res % error = grad_norm select type ( res ) class is ( scf_conv_soscf_result ) res % rms_grad = res % error res % rms_dp = rms_dp end select ! Update MO coefficients and compute MO energies self % dat % buffer ( self % dat % slot )% mo_a = self % mo_a if ( self % scf_type == 2 ) self % dat % buffer ( self % dat % slot )% mo_b = self % mo_b call compute_mo_energies ( self , fock_ao_a , self % mo_a , & self % dat % buffer ( self % dat % slot )% mo_e_a , self % work_1 , self % work_2 ) if ( self % scf_type == 2 ) then call compute_mo_energies ( self , fock_ao_b , self % mo_b , & self % dat % buffer ( self % dat % slot )% mo_e_b , self % work_1 , self % work_2 ) end if if ( self % soscf_reset_mod == 0 ) return if ( mod ( self % m_history , self % soscf_reset_mod ) == 0 ) then if ( self % rms_grad_prev > 1.0d-12 ) then grad_norm_ratio = grad_norm / self % rms_grad_prev self % rms_grad_prev = grad_norm if ( grad_norm_ratio > 0.95_dp ) then write ( iw , '(8X, \"Resetting Hessian, gradient norm ratio = \", F8.5)' ) grad_norm_ratio self % m_history = 0 self % first_macro = . true . end if end if end if end subroutine soscf_run subroutine rms_density ( self , d_new_a , d_new_b , & d_old_a , d_old_b , rms_dp , max_dp ) use , intrinsic :: iso_fortran_env , only : dp => real64 implicit none class ( soscf_converger ), intent ( in ) :: self real ( dp ), intent ( in ) :: d_new_a (:), d_old_a (:) real ( dp ), intent ( in ), optional :: d_new_b (:), d_old_b (:) real ( dp ), intent ( out ) :: rms_dp real ( dp ), intent ( out ), optional :: max_dp integer :: ntri , k real ( dp ) :: sum_sq , sum_sq_b real ( dp ) :: max_loc , max_loc_b real ( dp ) :: diff ntri = self % nbf_tri sum_sq = 0.0_dp max_loc = 0.0_dp !$omp   parallel do default(shared) private(k,diff)             & !$omp&  reduction(+:sum_sq) reduction(max:max_loc) do k = 1 , ntri diff = d_new_a ( k ) - d_old_a ( k ) sum_sq = sum_sq + diff * diff max_loc = max ( max_loc , abs ( diff )) end do !$omp   end parallel do rms_dp = sqrt ( sum_sq / real ( ntri , dp ) ) if ( present ( max_dp )) max_dp = max_loc if ( present ( d_new_b ) . and . present ( d_old_b )) then sum_sq_b = 0.0_dp max_loc_b = 0.0_dp !$omp   parallel do default(shared) private(k,diff)             & !$omp&  reduction(+:sum_sq_b) reduction(max:max_loc_b) do k = 1 , ntri diff = d_new_b ( k ) - d_old_b ( k ) sum_sq_b = sum_sq_b + diff * diff max_loc_b = max ( max_loc_b , abs ( diff )) end do !$omp   end parallel do rms_dp = 0.5_dp * ( rms_dp + sqrt ( sum_sq_b / real ( ntri , dp ) ) ) if ( present ( max_dp )) max_dp = max ( max_dp , max_loc_b ) end if end subroutine rms_density !> @brief Computes the initial diagonal inverse Hessian for SOSCF !> @details Approximates the inverse Hessian diagonal using orbital energy differences, !>          adjusted for SCF type: !>          - RHF: h_inv = 0.25 / (ε_a - ε_i) for closed-shell. !>          - UHF: h_inv combines alpha and beta energy differences. !>          - ROHF: h_inv varies by orbital region (closed-virtual, open-virtual). !>          Includes level-shifting for stability. !> @param[out] self%h_inv Diagonal inverse Hessian (size depends on scf_type) !> @param[in] mo_e_a Alpha orbital energies (size: nbf) !> @param[in] mo_e_b Beta orbital energies (size: nbf, ignored for RHF/ROHF) subroutine init_hess_inv ( self , mo_e_a , mo_e_b ) implicit none class ( soscf_converger ) :: self real ( kind = dp ), pointer , intent ( in ) :: mo_e_a (:) real ( kind = dp ), pointer , intent ( in ) :: mo_e_b (:) real ( kind = dp ) :: diff , scale integer :: i , a , k , istart associate ( nbf => self % nbf , & nocc_a => self % nocc_a , & nocc_b => self % nocc_b , & scf_type => self % scf_type , & lvl_shift => self % level_shift , & thresh => self % hess_thresh ) select case ( scf_type ) case ( 1 ) ! RHF: Closed-shell system ! Single set of orbitals, nocc_a = nocc_b, 4 * (ε_a - ε_i) scaling k = 0 do i = 1 , nocc_a if ( i <= nocc_b ) then istart = nocc_b + 1 scale = 0.25_dp ! Closed-virtual: like RHF else istart = nocc_a + 1 scale = 0.25_dp ! Open-virtual: like UHF (singly occupied) end if do a = istart , nbf k = k + 1 diff = mo_e_a ( a ) - mo_e_a ( i ) if ( abs ( diff ) < thresh ) then diff = sign ( thresh + lvl_shift , diff ) end if self % h_inv ( k ) = scale / diff end do end do case ( 2 ) ! UHF: Unrestricted, separate alpha and beta orbitals ! Alpha occupied -> alpha virtual, beta occupied -> beta virtual k = 0 ! Alpha rotations do i = 1 , nocc_a do a = nocc_a + 1 , nbf k = k + 1 diff = mo_e_a ( a ) - mo_e_a ( i ) if ( abs ( diff ) < thresh ) then diff = sign ( thresh + lvl_shift , diff ) end if self % h_inv ( k ) = 0.5_dp / diff end do end do ! Beta rotations do i = 1 , nocc_b do a = nocc_b + 1 , nbf k = k + 1 diff = mo_e_b ( a ) - mo_e_b ( i ) if ( abs ( diff ) < thresh ) then diff = sign ( thresh + lvl_shift , diff ) end if self % h_inv ( k ) = 0.5_dp / diff end do end do case ( 3 ) ! ROHF: Restricted open-shell ! Regions: closed (j <= nocc_b) !          open (nocc_b < j <= nocc_a) !          virtual (j > nocc_a) k = 0 do i = 1 , nocc_a if ( i <= nocc_b ) then istart = nocc_b + 1 scale = 0.25_dp ! Closed-virtual: like RHF else istart = nocc_a + 1 scale = 0.50_dp ! Open-virtual: like UHF (singly occupied) end if do a = istart , nbf k = k + 1 diff = mo_e_a ( a ) - mo_e_a ( i ) if ( abs ( diff ) < thresh ) then diff = sign ( thresh + lvl_shift , diff ) end if self % h_inv ( k ) = scale / diff end do end do end select end associate end subroutine init_hess_inv !> @brief Computes orbital gradient. !> @details Calculates the gradient for occupied-virtual orbital rotations: !>          - RHF: g(i,a) = 4 * F(i,a), single gradient. !>          - UHF: g_a(i,a) = 2 * F_a(i,a), g_b(i,a) = 2 * F_b(i,a), separate gradients. !>          - ROHF: g(c,v) = 2 * F_b(c,v) for doubly occ -> singly occ, !>                  g(o,v) = 2 * (F_a(o,v) + F_b(o,v)) doubly occ ->virt, !>                  g(o,v) = 2 * F_a(o,v) for singly occ -> virt !> @param[out] grad_a Alpha gradient for RHF, ROHF, and UHF !> @param[out] grad_b Beta gradient for UHF (optional, size: nocc_b * (nbf - nocc_b)) !> @param[in] fock_a Packed alpha/single Fock matrix (size: nbf*(nbf+1)/2) !> @param[in] fock_b Packed beta Fock matrix for UHF (optional, size: nbf*(nbf+1)/2) subroutine calc_orb_grad ( self , grad , fock_a , fock_b , mo_a , mo_b ) implicit none class ( soscf_converger ) :: self real ( kind = dp ), intent ( out ) :: grad (:) real ( kind = dp ), pointer , intent ( in ) :: fock_a (:) real ( kind = dp ), pointer , intent ( in ) :: fock_b (:) real ( kind = dp ), intent ( in ) :: mo_a (:,:) real ( kind = dp ), intent ( in ) :: mo_b (:,:) integer :: i , a , k , nvir_a , nvir_b , istart if (. not . ASSOCIATED ( fock_a )) & call show_message ( 'Failed to use Fock array in calc_orb_grad' , & with_abort ) associate ( nbf => self % nbf , & nocc_a => self % nocc_a , & nocc_b => self % nocc_b ) nvir_a = nbf - nocc_a nvir_b = nbf - nocc_b grad = 0.0_dp select case ( self % scf_type ) case ( 1 ) ! RHF ! Unpack AO-basis Fock matrix self % work_1 = 0.0_dp call unpack_matrix ( fock_a , self % work_1 ) ! Convert AO Fock to MO Fock. ! self%work_2 = F_ao * C_virt call dgemm ( 'N' , 'N' , nbf , nvir_a , nbf , & 1.0_dp , self % work_1 , nbf , & mo_a (:, nocc_a + 1 :), nbf , & 0.0_dp , self % work_2 , nbf ) ! self%work_1 = C_occ&#94;T * self%work_2 call dgemm ( 'T' , 'N' , nocc_a , nvir_a , nbf , & 1.0_dp , mo_a (:, 1 : nocc_a ), nbf , & self % work_2 , nbf , & 0.0_dp , self % work_1 ( 1 : nocc_a , 1 : nvir_a ), nocc_a ) k = 0 do i = 1 , nocc_a if ( i <= nocc_b ) then istart = nbf - nocc_b else istart = nbf - nocc_a end if do a = 1 , istart k = k + 1 grad ( k ) = 4.0_dp * self % work_1 ( i , a ) end do end do case ( 2 ) ! UHF if (. not . associated ( fock_b )) & call show_message ( 'Failed to use Fock arrays in calc_orb_grad' , & with_abort ) ! Alpha call unpack_matrix ( fock_a , self % work_1 ) call dgemm ( 'N' , 'N' , nbf , nvir_a , nbf , & 1.0_dp , self % work_1 , nbf , & mo_a (:, nocc_a + 1 :), nbf , & 0.0_dp , self % work_2 , nbf ) call dgemm ( 'T' , 'N' , nocc_a , nvir_a , nbf , & 1.0_dp , mo_a (:, 1 : nocc_a ), nbf , & self % work_2 , nbf , & 0.0_dp , self % work_1 ( 1 : nocc_a , 1 : nvir_a ), nocc_a ) k = 0 do i = 1 , nocc_a do a = 1 , nvir_a k = k + 1 grad ( k ) = 2.0_dp * self % work_1 ( i , a ) end do end do ! Beta self % work_1 = 0.0_dp call unpack_matrix ( fock_b , self % work_1 ) call dgemm ( 'N' , 'N' , nbf , nvir_b , nbf , & 1.0_dp , self % work_1 , nbf , & mo_b (:, nocc_b + 1 :), nbf , & 0.0_dp , self % work_2 , nbf ) call dgemm ( 'T' , 'N' , nocc_b , nvir_b , nbf , & 1.0_dp , mo_b (:, 1 : nocc_b ), nbf , & self % work_2 , nbf , & 0.0_dp , self % work_1 ( 1 : nocc_b , 1 : nvir_b ), nocc_b ) do i = 1 , nocc_b do a = 1 , nvir_b k = k + 1 grad ( k ) = 2.0_dp * self % work_1 ( i , a ) end do end do case ( 3 ) ! ROHF self % work_1 = 0.0_dp self % work_3 = 0.0_dp call unpack_matrix ( fock_a , self % work_1 ) call unpack_matrix ( fock_b , self % work_3 ) call dgemm ( 'N' , 'N' , nbf , nvir_a , nbf , & 1.0_dp , self % work_1 , nbf , & mo_a (:, nocc_a + 1 :), nbf , & 0.0_dp , self % work_2 , nbf ) call dgemm ( 'T' , 'N' , nocc_a , nvir_a , nbf , & 1.0_dp , mo_a (:, 1 : nocc_a ), nbf , & self % work_2 , nbf , & 0.0_dp , self % work_1 ( 1 : nocc_a , 1 : nvir_a ), nocc_a ) self % work_2 = 0.0_dp call dgemm ( 'N' , 'N' , nbf , nvir_b , nbf , & 1.0_dp , self % work_3 , nbf , & mo_a (:, nocc_b + 1 :), nbf , & 0.0_dp , self % work_2 , nbf ) call dgemm ( 'T' , 'N' , nocc_b , nvir_b , nbf , & 1.0_dp , mo_a (:, 1 : nocc_b ), nbf , & self % work_2 , nbf , & 0.0_dp , self % work_3 ( 1 : nocc_b , 1 : nvir_b ), nocc_b ) k = 0 do i = 1 , nocc_a if ( i <= nocc_b ) then istart = nbf - nocc_b else istart = nbf - nocc_a end if do a = 1 , istart k = k + 1 if ( i <= nocc_b ) then if ( a <= ( nocc_a - nocc_b )) then grad ( k ) = 2.0_dp * self % work_3 ( i , a ) else grad ( k ) = 2.0_dp * ( self % work_3 ( i , a ) + self % work_1 ( i , a - nocc_a + nocc_b )) end if else grad ( k ) = 2.0_dp * self % work_1 ( i , a ) end if end do end do end select end associate end subroutine calc_orb_grad subroutine bfgs_original_legacy ( self , x ) implicit none class ( soscf_converger ) :: self real ( kind = dp ), intent ( out ) :: x (:) real ( kind = dp ) :: displn ( self % nvec ) real ( kind = dp ) :: dgrad ( self % nvec ) real ( kind = dp ) :: updti ( self % nvec ) real ( kind = dp ) :: alpha , beta , t , t1 , t2 , t3 , t4 , scale , norm_disp real ( kind = dp ) :: s1 , s2 , s3 , s4 , s5 , s6 integer :: i , j ! Initialize displacement and preconditioned gradient difference if ( self % m_history < 1 ) then scale = 1.0_dp x = - scale * self % h_inv * self % grad where ( isnan ( x )) x = 0.0_dp else displn = self % h_inv * self % grad dgrad = self % grad - self % grad_prev updti = self % h_inv * dgrad if ( self % m_history > 1 ) then do i = 1 , self % m_history - 1 s1 = dot_product ( self % s_history (:, i ), self % y_history (:, i )) s2 = dot_product ( self % y_history (:, i ), self % upd_history (:, i )) s3 = dot_product ( self % s_history (:, i ), self % grad ) s4 = dot_product ( self % upd_history (:, i ), self % grad ) s5 = dot_product ( self % s_history (:, i ), dgrad ) s6 = dot_product ( self % upd_history (:, i ), dgrad ) s1 = 1.0d0 / s1 s2 = 1.0d0 / s2 t = 1.0d0 + s1 / s2 t2 = s1 * s3 t4 = s1 * s5 t1 = t * t2 - s1 * s4 t3 = t * t4 - s1 * s6 displn = displn + t1 * self % s_history (:, i ) - t2 * self % upd_history (:, i ) updti = updti + t3 * self % s_history (:, i ) - t4 * self % upd_history (:, i ) end do end if ! Final correction using current dgrad and updti s1 = dot_product ( self % x_prev , dgrad ) s2 = dot_product ( dgrad , updti ) s3 = dot_product ( self % x_prev , self % grad ) s4 = dot_product ( updti , self % grad ) s1 = 1.0_dp / s1 s2 = 1.0_dp / s2 t = 1.0_dp + s1 / s2 t2 = s1 * s3 t1 = t * t2 - s1 * s4 displn = displn + t1 * self % x_prev - t2 * updti self % s_history (:, self % m_history ) = self % x_prev self % y_history (:, self % m_history ) = dgrad self % upd_history (:, self % m_history ) = updti x = - displn end if norm_disp = sqrt ( dot_product ( x , x ) / self % nvec ) if ( norm_disp > 0.1 ) then x = x * 0.1 / norm_disp end if self % x_prev = x self % grad_prev = self % grad end subroutine bfgs_original_legacy subroutine bfgs_stable_only_impl ( self , x ) implicit none class ( soscf_converger ) :: self real ( kind = dp ), intent ( out ) :: x (:) ! --- locals --- real ( kind = dp ) :: displn ( self % nvec ) ! preconditioned (approx) H&#94;{-1} g real ( kind = dp ) :: dgrad ( self % nvec ) ! y_k = g_k - g_{k-1} real ( kind = dp ) :: updti ( self % nvec ) ! H0&#94;{-1} y_k  (H0 diagonal from gaps) real ( kind = dp ) :: s1 , s2 , s3 , s4 , s5 , s6 ! scalars used in the L-BFGS application real ( kind = dp ) :: t , t1 , t2 , t3 , t4 integer :: i ! cheap step control scalars real ( kind = dp ) :: gg , hh , alpha , cg , kappa_max , norm_rms real ( kind = dp ), parameter :: eps = 1.0e-16_dp real ( kind = dp ), parameter :: alpha_min = 0.05_dp !real(kind=dp), parameter :: alpha_max = 1.00_dp !real(kind=dp), parameter :: kappa_lim = 0.30_dp   ! cap on max |rotation element| real ( dp ) :: alpha_max , kappa_l alpha_max = self % alpha_cap kappa_l = self % kappa_lim ! -------- form search direction p (in x) via diagonal-precond L-BFGS -------- if ( self % m_history < 1 ) then ! first step: preconditioned steepest descent x = - self % h_inv * self % grad where ( isnan ( x )) x = 0.0_dp else displn = self % h_inv * self % grad dgrad = self % grad - self % grad_prev updti = self % h_inv * dgrad ! apply stored pairs (i = 1 .. m_history-1) with curvature checks if ( self % m_history > 1 ) then do i = 1 , self % m_history - 1 s1 = dot_product ( self % s_history (:, i ), self % y_history (:, i )) ! s·y s2 = dot_product ( self % y_history (:, i ), self % upd_history (:, i )) ! y·(H0&#94;{-1}y) ! skip ill-conditioned pairs if ( s1 <= 1.0e-12_dp * & sqrt ( max ( dot_product ( self % s_history (:, i ), self % s_history (:, i )), eps )) * & sqrt ( max ( dot_product ( self % y_history (:, i ), self % y_history (:, i )), eps )) ) cycle if ( abs ( s2 ) <= eps ) cycle s3 = dot_product ( self % s_history (:, i ), self % grad ) ! s·g s4 = dot_product ( self % upd_history (:, i ), self % grad ) ! (H0&#94;{-1}y)·g s5 = dot_product ( self % s_history (:, i ), dgrad ) ! s·y_k s6 = dot_product ( self % upd_history (:, i ), dgrad ) ! (H0&#94;{-1}y)·y_k s1 = 1.0_dp / s1 s2 = 1.0_dp / s2 t = 1.0_dp + s1 / s2 t2 = s1 * s3 t4 = s1 * s5 t1 = t * t2 - s1 * s4 t3 = t * t4 - s1 * s6 displn = displn + t1 * self % s_history (:, i ) - t2 * self % upd_history (:, i ) updti = updti + t3 * self % s_history (:, i ) - t4 * self % upd_history (:, i ) end do end if ! final correction using the current pair (x_prev, dgrad) s1 = dot_product ( self % x_prev , dgrad ) ! s·y with current pair s2 = dot_product ( dgrad , updti ) ! y·(H0&#94;{-1}y) if ( s1 > 1.0e-12_dp * sqrt ( max ( dot_product ( self % x_prev , self % x_prev ), eps )) * & sqrt ( max ( dot_product ( dgrad , dgrad ), eps )) . and . abs ( s2 ) > eps ) then s3 = dot_product ( self % x_prev , self % grad ) ! s·g s4 = dot_product ( updti , self % grad ) ! (H0&#94;{-1}y)·g s1 = 1.0_dp / s1 s2 = 1.0_dp / s2 t = 1.0_dp + s1 / s2 t2 = s1 * s3 t1 = t * t2 - s1 * s4 displn = displn + t1 * self % x_prev - t2 * updti ! store the current pair for the next iteration (safe to reuse) self % s_history (:, self % m_history ) = self % x_prev self % y_history (:, self % m_history ) = dgrad self % upd_history (:, self % m_history ) = updti else ! neutral store (keeps indexing consistent; pair will be skipped next time) self % s_history (:, self % m_history ) = 0.0_dp self % y_history (:, self % m_history ) = 0.0_dp self % upd_history (:, self % m_history ) = 0.0_dp end if x = - displn end if ! -------------------- CHEAP step length and safeguards --------------------- ! Quadratic one-shot step along p = x using diagonal Hessian H0 gg = dot_product ( self % grad , x ) ! g·p hh = sum ( x * x / max ( self % h_inv , eps ) ) ! p·H0·p  (H0 = diag(1/h_inv)) if ( hh > eps ) then alpha = - gg / hh else alpha = 0.1_dp end if alpha = min ( max ( alpha , alpha_min ), alpha_max ) ! angle safeguard: if p is poorly aligned with -g, be conservative cg = - gg / ( sqrt ( max ( dot_product ( self % grad , self % grad ), eps )) * & sqrt ( max ( dot_product ( x , x ), eps )) ) if ( cg < 0.2_dp ) alpha = 0.5_dp * alpha ! elementwise amplitude cap (keeps exponential/orbital update in safe regime) kappa_max = maxval ( abs ( x )) if ( kappa_max > 0.0_dp ) then if ( alpha * kappa_max > kappa_l ) alpha = ( kappa_l / kappa_max ) end if ! scale the step x = alpha * x ! existing RMS clamp (RMS amplitude <= 0.1) norm_rms = sqrt ( dot_product ( x , x ) / self % nvec ) if ( norm_rms > 0.1_dp ) x = x * ( 0.1_dp / norm_rms ) where ( isnan ( x )) x = 0.0_dp ! keep these for the next macro-iteration self % x_prev = x self % grad_prev = self % grad self % alpha_last = alpha self % gg_last = gg self % hh_last = hh self % g_rms_last = sqrt ( sum ( self % grad * self % grad ) / real ( self % nvec , dp ) ) end subroutine bfgs_stable_only_impl subroutine bfgs_quad_ls_impl ( self , x ) !! Mode 2: Curvature-safe L-BFGS + robust quadratic line search + 1-D trust region !! - No extra J/K builds. !! - Conservative early caps; bolder near the end. !! - Guarantees descent direction; falls back to precond. SD if needed. implicit none class ( soscf_converger ) :: self real ( kind = dp ), intent ( out ) :: x (:) integer :: n , i , m real ( kind = dp ) :: eps , sTy , rho_i , qdot , sN , yN , tol_curv real ( kind = dp ) :: gnorm , pnorm , g_rms , p_rms , p_inf , cg real ( kind = dp ) :: gg , hh , alpha , alpha_min , alpha_max real ( kind = dp ) :: delta_rms , kappa_lim , dEmodel ! Two-loop temporaries (automatic arrays) real ( kind = dp ) :: q ( size ( x )), r ( size ( x )) real ( kind = dp ), allocatable :: alpha_buf (:) n = size ( x ) eps = 1.0e-16_dp ! ------------------------------- ! 1) Curvature-safe L-BFGS two-loop ! ------------------------------- m = self % m_history q = self % grad if ( m > 0 ) then allocate ( alpha_buf ( m )) ! backward loop do i = m , 1 , - 1 sTy = dot_product ( self % s_history (:, i ), self % y_history (:, i )) ! Nocedal curvature tolerance: skip weak/indef pairs sN = sqrt ( max ( dot_product ( self % s_history (:, i ), self % s_history (:, i )), eps ) ) yN = sqrt ( max ( dot_product ( self % y_history (:, i ), self % y_history (:, i )), eps ) ) tol_curv = 1.0e-12_dp * sN * yN if ( sTy > tol_curv ) then rho_i = 1.0_dp / sTy alpha_buf ( i ) = rho_i * dot_product ( self % s_history (:, i ), q ) q = q - alpha_buf ( i ) * self % y_history (:, i ) else alpha_buf ( i ) = 0.0_dp end if end do end if ! Initial inverse-Hessian action via diagonal preconditioner H0&#94;{-1} r = self % h_inv * q if ( m > 0 ) then ! forward loop do i = 1 , m sTy = dot_product ( self % s_history (:, i ), self % y_history (:, i )) sN = sqrt ( max ( dot_product ( self % s_history (:, i ), self % s_history (:, i )), eps ) ) yN = sqrt ( max ( dot_product ( self % y_history (:, i ), self % y_history (:, i )), eps ) ) tol_curv = 1.0e-12_dp * sN * yN if ( sTy <= tol_curv ) cycle rho_i = 1.0_dp / sTy qdot = rho_i * dot_product ( self % y_history (:, i ), r ) r = r + self % s_history (:, i ) * ( alpha_buf ( i ) - qdot ) end do deallocate ( alpha_buf ) end if ! Unscaled search direction x = - r ! ------------------------------- ! 2) Robust step control (no extra J/K) !    - quadratic step on diagonal model !    - descent/angle checks !    - 1-D trust region (RMS + ∞-norm) ! ------------------------------- g_rms = sqrt ( sum ( self % grad * self % grad ) / real ( self % nvec , dp ) ) gnorm = sqrt ( max ( dot_product ( self % grad , self % grad ), eps ) ) pnorm = sqrt ( max ( dot_product ( x , x ), eps ) ) p_rms = sqrt ( dot_product ( x , x ) / real ( self % nvec , dp ) ) p_inf = maxval ( abs ( x )) ! If L-BFGS gave a non-descent direction, fall back to preconditioned SD gg = dot_product ( self % grad , x ) ! g·p  (p == x at this point) if ( gg >= 0.0_dp ) then x = - self % h_inv * self % grad ! safe fallback pnorm = sqrt ( max ( dot_product ( x , x ), eps ) ) p_rms = sqrt ( dot_product ( x , x ) / real ( self % nvec , dp ) ) p_inf = maxval ( abs ( x )) gg = dot_product ( self % grad , x ) end if ! Diagonal quadratic curvature along p: H0 = diag(1/h_inv) hh = sum ( x * x / max ( self % h_inv , eps ) ) ! p·H0·p ! Stationary step on the quadratic model if ( hh > eps ) then alpha = - gg / hh else alpha = 0.10_dp end if ! Conservative bounds far from minimum; relax as ||g||_rms shrinks if ( g_rms > 5.0e-3_dp ) then alpha_min = 0.02_dp ; alpha_max = 0.50_dp delta_rms = 0.08_dp ; kappa_lim = 0.25_dp elseif ( g_rms > 1.0e-3_dp ) then alpha_min = 0.05_dp ; alpha_max = 0.75_dp delta_rms = 0.12_dp ; kappa_lim = 0.40_dp elseif ( g_rms > 2.0e-4_dp ) then alpha_min = 0.10_dp ; alpha_max = 0.90_dp delta_rms = 0.16_dp ; kappa_lim = 0.50_dp else alpha_min = 0.20_dp ; alpha_max = 1.00_dp delta_rms = 0.20_dp ; kappa_lim = 0.60_dp end if if ( alpha < alpha_min ) alpha = alpha_min if ( alpha > alpha_max ) alpha = alpha_max ! Descent-angle safeguard (only damp far from minimum) if ( pnorm > 0.0_dp ) then cg = - gg / ( gnorm * pnorm ) ! cos(angle(-g, p)) else cg = 1.0_dp end if if ( g_rms > 3.0e-3_dp ) then if ( cg < 0.10_dp ) alpha = 0.50_dp * alpha if ( cg < 0.00_dp ) alpha = 0.25_dp * alpha end if ! 1-D trust region caps if ( p_rms > 0.0_dp ) alpha = min ( alpha , delta_rms / p_rms ) if ( p_inf > 0.0_dp ) alpha = min ( alpha , kappa_lim / p_inf ) ! Model-based sufficient decrease (on the quadratic, not extra Fock): ! Ensure m(alpha) = alpha*gg + 0.5*alpha&#94;2*hh is negative and not tiny positive. dEmodel = alpha * gg + 0.5_dp * alpha * alpha * hh if ( dEmodel >= 0.0_dp . and . hh > eps ) then ! move to half of stationary step on the model alpha = min ( alpha , - 0.5_dp * gg / hh ) dEmodel = alpha * gg + 0.5_dp * alpha * alpha * hh if ( dEmodel >= 0.0_dp ) alpha = 0.5_dp * alpha end if ! Final scaled step x = alpha * x ! Keep these for the next iteration (unchanged behavior) self % x_prev = x self % grad_prev = self % grad end subroutine bfgs_quad_ls_impl subroutine bfgs ( self , x ) !! Dispatcher so that soscf_mode = 0 is *bit-identical* to original. implicit none class ( soscf_converger ) :: self real ( kind = dp ), intent ( out ) :: x (:) select case ( self % variant ) case ( SOSCF_VARIANT_ORIGINAL ) call bfgs_original_legacy ( self , x ) ! exact copy from original file case ( SOSCF_VARIANT_STABLE_ONLY ) call bfgs_stable_only_impl ( self , x ) ! curvature-safe L-BFGS + legacy RMS clamp case ( SOSCF_VARIANT_QUAD_LS ) call bfgs_quad_ls_impl ( self , x ) ! stable + quadratic line search (no extra J/K) case default call bfgs_original_legacy ( self , x ) end select end subroutine bfgs subroutine rotate_orbs ( self , x , nocc_a , nocc_b , mo ) implicit none class ( soscf_converger ) :: self real ( kind = dp ), intent ( in ) :: x (:) integer , intent ( in ) :: nocc_a , nocc_b real ( kind = dp ), intent ( inout ) :: mo (:,:) integer :: nbf , i , idx logical :: second_term nbf = self % nbf self % work_1 = 0 self % work_2 = 0 idx = 0 second_term = . true . if ( self % scf_type == 3 ) then ! ROHF second_term = . false . end if call exp_scaling ( self % work_1 , x , idx , nocc_a , nocc_b , nbf , second_term ) call orthonormalize ( self % work_1 , nbf ) call dgemm ( 'N' , 'N' , nbf , nbf , nbf , 1.0_dp , mo , nbf , self % work_1 , nbf , 0.0_dp , self % work_2 , nbf ) mo = self % work_2 contains subroutine exp_scaling ( G , x , idx , nocc_a , nocc_b , nbf , second_term ) real ( kind = dp ), intent ( out ) :: G (:,:) real ( kind = dp ), intent ( in ) :: x (:) integer , intent ( inout ) :: idx integer , intent ( in ) :: nocc_a , nocc_b , nbf real ( kind = dp ), allocatable :: K (:,:), K2 (:,:) integer :: occ , virt , istart , i logical , intent ( inout ) :: second_term allocate ( K ( nbf , nbf ), source = 0.0_dp ) allocate ( K2 ( nbf , nbf ), source = 0.0_dp ) do occ = 1 , nocc_a istart = merge ( nocc_b + 1 , nocc_a + 1 , occ <= nocc_b ) do virt = istart , nbf idx = idx + 1 K ( virt , occ ) = x ( idx ) K ( occ , virt ) = - x ( idx ) end do end do G = 0.0_dp do i = 1 , nbf G ( i , i ) = 1.0_dp end do G = G + K if ( second_term ) then call dgemm ( 'N' , 'T' , nbf , nbf , nbf , 1.0_dp , K , nbf , K , nbf , 0.0_dp , K2 , nbf ) G = G + 0.5_dp * K2 end if deallocate ( K , K2 ) end subroutine exp_scaling subroutine orthonormalize ( G , nbf ) real ( kind = dp ), intent ( inout ) :: G (:,:) integer , intent ( in ) :: nbf integer :: i , j real ( kind = dp ) :: norm , dot do i = 1 , nbf norm = sqrt ( dot_product ( G (:, i ), G (:, i ))) call dscal ( nbf , 1.0_dp / norm , G ( 1 , i ), 1 ) if ( i == nbf ) cycle do j = i + 1 , nbf dot = dot_product ( G (:, i ), G (:, j )) call daxpy ( nbf , - dot , G ( 1 , i ), 1 , G ( 1 , j ), 1 ) end do end do end subroutine orthonormalize end subroutine rotate_orbs !> @brief Computes MO energies from the Fock matrix and updated MO coefficients. !> @details Projects the Fock matrix onto the MO basis: F_mo = C&#94;T * F * C, !>          taking diagonal elements as approximate MO energies for monitoring. !> @param[in] self The SOSCF converger object (for nbf). !> @param[in] fock Packed Fock matrix (nbf_tri). !> @param[in] mo_coeffs MO coefficients (nbf, nbf). !> @param[out] mo_energies MO energies (nbf). subroutine compute_mo_energies ( self , fock , mo_coeffs , mo_energies , work_1 , work_2 ) use mathlib , only : unpack_matrix implicit none class ( soscf_converger ), intent ( in ) :: self real ( kind = dp ), intent ( in ) :: fock (:) real ( kind = dp ), intent ( in ) :: mo_coeffs (:, :) real ( kind = dp ), intent ( out ) :: mo_energies (:) real ( kind = dp ), intent ( inout ) :: work_1 (:, :) real ( kind = dp ), intent ( inout ) :: work_2 (:, :) real ( kind = dp ), allocatable :: f_full (:, :), temp (:, :), f_mo (:, :) integer :: nbf , i nbf = self % nbf call unpack_matrix ( fock , work_1 ) call dgemm ( 'T' , 'N' , nbf , nbf , nbf , & 1.0_dp , mo_coeffs , nbf , & work_1 , nbf , & 0.0_dp , work_2 , nbf ) call dgemm ( 'N' , 'N' , nbf , nbf , nbf , & 1.0_dp , work_2 , nbf , & mo_coeffs , nbf , & 0.0_dp , work_1 , nbf ) do i = 1 , nbf mo_energies ( i ) = work_1 ( i , i ) end do end subroutine compute_mo_energies !==================================================================== ! Trust region agumnted hessian subroutines !==================================================================== !> @brief Initialize the TRAH (Trust-Region Augmented Hessian) converger. !> @detail Copies basic problem dimensions and pointers from `params`, sets !>         up spin/occ/vir sizes, counts the optimization variables, and !>         allocates working arrays via `alloc_workspace`. !> @param[inout] self    TRAH converger object. !> @param[in]    params  SCF convergence context (dimensions, data handles). !> @author Mohsen Mazaherifar !> @date August 2025 subroutine trah_init ( self , params ) implicit none class ( trah_converger ), intent ( inout ) :: self type ( scf_conv ), target , intent ( in ) :: params call self % subconverger_init ( params ) self % conv_name = 'TRAH' self % nfocks = params % dat % num_focks self % verbose = params % verbose self % nbf = params % dat % ldim self % nocc_a = params % dat % nelec_a self % nocc_b = params % dat % nelec_b self % nbf_tri = self % nbf * ( self % nbf + 1 ) / 2 self % dat => params % dat self % overlap => params % overlap self % overlap_invsqrt => params % overlap_sqrt self % scf_type = params % scf_type self % nvir_a = self % nbf - self % nocc_a self % nvir_b = self % nbf - self % nocc_b !    self%is_dft  = (infos%control%hamilton >= 20) !    self%hf_scale = merge(infos%dft%HFscale, 1.0_dp, self%is_dft) select case ( self % scf_type ) case ( SCF_RHF ) self % n_param = int (( self % nocc_a * self % nvir_a ), kind = int32 ) case ( 2 ) self % n_param = int (( self % nocc_a * self % nvir_a ) + ( self % nocc_b * self % nvir_b ), kind = int32 ) case ( SCF_ROHF ) self % n_param = int ( self % nvir_a * ( self % nocc_a - self % nocc_b ) + ( self % nocc_b * self % nvir_b ), kind = int32 ) end select call alloc_workspace ( self ) end subroutine trah_init !> @brief Initialize the TRAH (Trust-Region Augmented Hessian) converger. !> @detail Copies basic problem dimensions and pointers from `params`, sets !>         up spin/occ/vir sizes, counts the optimization variables, and !>         allocates working arrays via `alloc_workspace`. !> @param[inout] self    TRAH converger object. !> @param[in]    params  SCF convergence context (dimensions, data handles). !> @author Mohsen Mazaherifar !> @date August 2025 subroutine alloc_workspace ( self ) implicit none class ( trah_converger ), intent ( inout ) :: self integer :: nbf , nbf_tri nbf = self % nbf nbf_tri = nbf * ( nbf + 1 ) / 2 if (. not . allocated ( self % work1 )) allocate ( self % work1 ( nbf , nbf )) if (. not . allocated ( self % work2 )) allocate ( self % work2 ( nbf , nbf )) if (. not . allocated ( self % work3 )) allocate ( self % work3 ( nbf , nbf )) if (. not . allocated ( self % v )) allocate ( self % v ( nbf , nbf )) if (. not . allocated ( self % dm )) allocate ( self % dm ( nbf , nbf )) if (. not . allocated ( self % pfock )) allocate ( self % pfock ( nbf_tri , self % nfocks )) if (. not . allocated ( self % dens )) allocate ( self % dens ( nbf_tri , self % nfocks )) if (. not . allocated ( self % fock_ao )) allocate ( self % fock_ao ( nbf_tri , self % nfocks )) if (. not . allocated ( self % d_old )) allocate ( self % d_old ( nbf_tri , self % nfocks )) if (. not . allocated ( self % f_old )) allocate ( self % f_old ( nbf_tri , self % nfocks )) if (. not . allocated ( self % dm_tri )) allocate ( self % dm_tri ( nbf_tri , self % nfocks )) if ( self % scf_type == SCF_RHF . or . self % scf_type == SCF_ROHF . or . self % scf_type == SCF_UHF ) then if (. not . allocated ( self % mo_a )) allocate ( self % mo_a ( nbf , nbf )) if (. not . allocated ( self % foo_a )) allocate ( self % foo_a ( self % nocc_a , self % nocc_a )) if (. not . allocated ( self % fvv_a )) allocate ( self % fvv_a ( self % nvir_a , self % nvir_a )) if (. not . allocated ( self % xmat_a )) allocate ( self % xmat_a ( self % nvir_a , self % nocc_a )) if (. not . allocated ( self % x2mat_a )) allocate ( self % x2mat_a ( self % nvir_a , self % nocc_a )) end if if ( self % scf_type == SCF_UHF . or . self % scf_type == SCF_ROHF ) then if (. not . allocated ( self % mo_b )) allocate ( self % mo_b ( nbf , nbf )) if (. not . allocated ( self % foo_b )) allocate ( self % foo_b ( self % nocc_b , self % nocc_b )) if (. not . allocated ( self % fvv_b )) allocate ( self % fvv_b ( self % nvir_b , self % nvir_b )) if (. not . allocated ( self % xmat_b )) allocate ( self % xmat_b ( self % nvir_b , self % nocc_b )) if (. not . allocated ( self % x2mat_b )) allocate ( self % x2mat_b ( self % nvir_b , self % nocc_b )) end if end subroutine alloc_workspace !> @brief Free all allocated TRAH work arrays. !> @detail Deallocates AO work buffers, spin-resolved slices, packed !>         densities/Focks, and incremental-update buffers (d_old, f_old). !> @param[inout] self  TRAH converger object to clean up. !> @author Mohsen Mazaherifar !> @date August 2025 subroutine trah_clean ( self ) implicit none class ( trah_converger ), intent ( inout ) :: self if ( allocated ( self % work1 )) deallocate ( self % work1 ) if ( allocated ( self % work2 )) deallocate ( self % work2 ) if ( allocated ( self % work3 )) deallocate ( self % work3 ) if ( allocated ( self % v )) deallocate ( self % v ) if ( allocated ( self % dm )) deallocate ( self % dm ) if ( allocated ( self % pfock )) deallocate ( self % pfock ) if ( allocated ( self % dm_tri )) deallocate ( self % dm_tri ) if ( allocated ( self % foo_a )) deallocate ( self % foo_a ) if ( allocated ( self % fvv_a )) deallocate ( self % fvv_a ) if ( allocated ( self % xmat_a )) deallocate ( self % xmat_a ) if ( allocated ( self % x2mat_a )) deallocate ( self % x2mat_a ) if ( allocated ( self % foo_b )) deallocate ( self % foo_b ) if ( allocated ( self % fvv_b )) deallocate ( self % fvv_b ) if ( allocated ( self % xmat_b )) deallocate ( self % xmat_b ) if ( allocated ( self % x2mat_b )) deallocate ( self % x2mat_b ) if ( allocated ( self % d_old )) deallocate ( self % d_old ) if ( allocated ( self % f_old )) deallocate ( self % f_old ) end subroutine trah_clean !> @brief Lightweight (re)setup before a TRAH iteration. !> @detail Resets internal flags that track whether data-dependent setup !>         has been performed for the current iteration/step. !> @param[inout] self  TRAH converger object. !> @author Mohsen Mazaherifar !> @date August 2025 subroutine trah_setup ( self ) class ( trah_converger ), intent ( inout ) :: self ! Data verification on each setup call self % last_setup = 0 end subroutine trah_setup !> @brief Entry point to run a TRAH step (skeleton). !> @detail Pulls the latest Fock, density, and MO blocks from `self%dat` !>         and creates a `scf_conv_trah_result`. Actual step logic is !>         intended to be added where noted. !> @param[inout] self  TRAH converger object. !> @param[out]   res   Result object produced by TRAH iteration. !> @author Mohsen Mazaherifar !> @date August 2025 subroutine trah_run ( self , res ) !    use otr_interface, only: init_trah_solver, run_trah_solver class ( trah_converger ), target , intent ( inout ) :: self class ( scf_conv_result ), allocatable , intent ( out ) :: res ! --- Step 1: Extract current data from converger_data --- self % fock_ao (:, 1 ) = self % dat % get_fock ( - 1 , 1 ) self % mo_a = self % dat % get_mo_a ( - 1 ) self % dens (:, 1 ) = self % dat % get_density ( - 1 , 1 ) if ( self % scf_type > 1 ) then self % fock_ao (:, 2 ) = self % dat % get_fock ( - 1 , 2 ) self % mo_b = self % dat % get_mo_b ( - 1 ) self % dens (:, 2 ) = self % dat % get_density ( - 1 , 2 ) end if allocate ( scf_conv_trah_result :: res ) res % dat => self % dat res % active_converger_name = self % conv_name res % ierr = 0 end subroutine trah_run !> @brief Build orbital-rotation gradient and diagonal of the Hessian proxy. !> @detail Transforms packed AO Fock to MO space (FOO/FVV blocks) and !>         constructs the orbital-gradient (off-diagonal Fock) and a !>         diagonal approximation to the Hessian using eigenvalue gaps. !>         Covers RHF, UHF (α/β), and ROHF cases. !> @param[inout] self    TRAH converger. !> @param[out]   grad    Orbital-rotation gradient (vectorized). !> @param[out]   h_diag  Diagonal of the Hessian approximation. !> @author Mohsen Mazaherifar !> @date August 2025 subroutine calc_g_h ( self , grad , h_diag ) use precision , only : dp use mathlib , only : unpack_matrix implicit none class ( trah_converger ), intent ( inout ) :: self real ( dp ), intent ( out ) :: grad (:) real ( dp ), intent ( out ) :: h_diag (:) real ( dp ), allocatable :: ugd (:), uh (:) integer :: i , a , k , k_rohf associate ( nbf => self % nbf , & nocc_a => self % nocc_a , & nocc_b => self % nocc_b , & nvir_a => self % nvir_a , & nvir_b => self % nvir_b , & w1 => self % work1 , & w2 => self % work2 , & w3 => self % work3 , & fock_ao => self % fock_ao ,& mo_a => self % mo_a , & mo_b => self % mo_b , & foo => self % foo_a , fvv => self % fvv_a ,& foo_b => self % foo_b , fvv_b => self % fvv_b ) select case ( self % scf_type ) case ( SCF_RHF ) call unpack_matrix ( fock_ao (:, 1 ), w1 ) w2 = 0.0_dp w3 = 0.0_dp call dgemm ( 'N' , 'N' , nbf , nbf , nbf , 1.0_dp , w1 , nbf , mo_a , nbf , 0.0_dp , w2 , nbf ) call dgemm ( 'T' , 'N' , nbf , nbf , nbf , 1.0_dp , mo_a , nbf , w2 , nbf , 0.0_dp , w3 , nbf ) foo = w3 ( 1 : nocc_a , 1 : nocc_a ) fvv = w3 ( nocc_a + 1 : nbf , nocc_a + 1 : nbf ) k = 0 do i = nocc_a + 1 , nbf do a = 1 , nocc_a k = k + 1 grad ( k ) = 2.0_dp * w3 ( i , a ) h_diag ( k ) = 2.0_dp * ( w3 ( i , i ) - w3 ( a , a ) ) end do end do case ( SCF_UHF ) ! ---- UHF α block ---- call unpack_matrix ( fock_ao (:, 1 ), w1 ) w2 = 0.0_dp w3 = 0.0_dp call dgemm ( 'N' , 'N' , nbf , nbf , nbf , 1.0_dp , w1 , nbf , mo_a , nbf , 0.0_dp , w2 , nbf ) call dgemm ( 'T' , 'N' , nbf , nbf , nbf , 1.0_dp , mo_a , nbf , w2 , nbf , 0.0_dp , w3 , nbf ) foo = w3 ( 1 : nocc_a , 1 : nocc_a ) fvv = w3 ( nocc_a + 1 : nbf , nocc_a + 1 : nbf ) k = 0 do i = nocc_a + 1 , nbf do a = 1 , nocc_a k = k + 1 grad ( k ) = w3 ( i , a ) h_diag ( k ) = ( w3 ( i , i ) - w3 ( a , a ) ) end do end do ! ---- UHF beta block ---- call unpack_matrix ( fock_ao (:, 2 ), w1 ) w2 = 0.0_dp w3 = 0.0_dp call dgemm ( 'N' , 'N' , nbf , nbf , nbf , 1.0_dp , w1 , nbf , mo_b , nbf , 0.0_dp , w2 , nbf ) call dgemm ( 'T' , 'N' , nbf , nbf , nbf , 1.0_dp , mo_b , nbf , w2 , nbf , 0.0_dp , w3 , nbf ) foo_b = w3 ( 1 : nocc_b , 1 : nocc_b ) fvv_b = w3 ( nocc_b + 1 : nbf , nocc_b + 1 : nbf ) k = self % nvir_a * nocc_a do i = nocc_b + 1 , nbf do a = 1 , nocc_b k = k + 1 grad ( k ) = w3 ( i , a ) h_diag ( k ) = ( w3 ( i , i ) - w3 ( a , a ) ) end do end do case ( SCF_ROHF ) ! ---- ROHF α block ---- call unpack_matrix ( fock_ao (:, 1 ), w1 ) w2 = 0.0_dp call dgemm ( 'N' , 'N' , nbf , nbf , nbf , 1.0_dp , w1 , nbf , mo_a , nbf , 0.0_dp , w2 , nbf ) call dgemm ( 'T' , 'N' , nbf , nbf , nbf , 1.0_dp , mo_a , nbf , w2 , nbf , 0.0_dp , w1 , nbf ) foo = w1 ( 1 : nocc_a , 1 : nocc_a ) fvv = w1 ( nocc_a + 1 : nbf , nocc_a + 1 : nbf ) call unpack_matrix ( fock_ao (:, 2 ), w3 ) w2 = 0.0_dp call dgemm ( 'N' , 'N' , nbf , nbf , nbf , 1.0_dp , w3 , nbf , mo_b , nbf , 0.0_dp , w2 , nbf ) call dgemm ( 'T' , 'N' , nbf , nbf , nbf , 1.0_dp , mo_b , nbf , w2 , nbf , 0.0_dp , w3 , nbf ) foo_b = w3 ( 1 : nocc_b , 1 : nocc_b ) fvv_b = w3 ( nocc_b + 1 : nbf , nocc_b + 1 : nbf ) k = 0 do i = nocc_b + 1 , nocc_a do a = 1 , nocc_b k = k + 1 grad ( k ) = w3 ( i , a ) h_diag ( k ) = w3 ( i , i ) - w3 ( a , a ) end do end do do i = nocc_a + 1 , nbf do a = 1 , nocc_b k = k + 1 grad ( k ) = w3 ( i , a ) + w1 ( i , a ) h_diag ( k ) = ( w3 ( i , i ) - w3 ( a , a )) + ( w1 ( i , i ) - w1 ( a , a )) end do end do do i = nocc_a + 1 , nbf do a = nocc_b + 1 , nocc_a k = k + 1 grad ( k ) = w1 ( i , a ) h_diag ( k ) = w1 ( i , i ) - w1 ( a , a ) end do end do case default error stop 'calc_g_h: unsupported scftype' end select end associate end subroutine calc_g_h !> @brief Apply the Hessian/operator to a trial vector (H·x) for TRAH. !> @detail Maps trial rotations `x` (RHF/UHF/ROHF) to AO-space density !>         perturbations, calls `get_response_packed` to obtain the !>         packed Coulomb/exchange(+XC) response, transforms back to MO, !>         and assembles the resulting vector `x2` in rotation space. !> @param[inout] self   TRAH converger (uses work arrays, MO blocks). !> @param[inout] infos  System/control information (basis, DFT flags, grid). !> @param[in]    x      Trial vector (packed rotations; α then β for UHF). !> @param[out]   x2     Result of operator application (same layout as x). !> @author Mohsen Mazaherifar !> @date August 2025 subroutine calc_h_op ( self , infos , x , x2 ) use precision , only : dp use types , only : information use mathlib , only : pack_matrix , unpack_matrix use scf_addons , only : get_response_packed implicit none class ( trah_converger ), intent ( inout ) :: self class ( information ), intent ( inout ), target :: infos real ( dp ), intent ( in ) :: x (:) ! length nocc*nvir (α then β for UHF) real ( dp ), intent ( out ) :: x2 (:) ! same length integer :: nbf , nocc_a , nocc_b , nvir_a , nvir_b integer :: i , a , k associate ( nbf => self % nbf , & nocc_a => self % nocc_a , nocc_b => self % nocc_b , & nvir_a => self % nvir_a , nvir_b => self % nvir_b , & work1 => self % work1 , & work2 => self % work2 , & work3 => self % work3 , & fock_ao => self % fock_ao ,& mo => self % mo_a , & mo_b => self % mo_b , & dm => self % dm , pfock => self % pfock , dm_tri => self % dm_tri , v => self % v , & foo => self % foo_a , fvv => self % fvv_a , xmat => self % xmat_a , x2mat => self % x2mat_a , & foo_b => self % foo_b , fvv_b => self % fvv_b , xmat_b => self % xmat_b , x2mat_b => self % x2mat_b ) select case ( self % scf_type ) !============================== RHF ============================== case ( SCF_RHF ) k = 0 do i = 1 , nvir_a do a = 1 , nocc_a k = k + 1 xmat ( i , a ) = x ( k ) end do end do call dgemm ( 'N' , 'N' , nvir_a , nocc_a , nvir_a , & 1.0_dp , fvv , nvir_a , & xmat , nvir_a , & 0.0_dp , x2mat , nvir_a ) call dgemm ( 'N' , 'N' , nvir_a , nocc_a , nocc_a , & - 1.0_dp , xmat , nvir_a , & foo , nocc_a , & 1.0_dp , x2mat , nvir_a ) dm = 0.0_dp work2 = 0 call dgemm ( 'N' , 'N' , nbf , nocc_a , nvir_a , & 2.0_dp , mo (:, nocc_a + 1 : nbf ), nbf , & xmat , nvir_a , & 0.0_dp , work2 , nbf ) call dgemm ( 'N' , 'T' , nbf , nbf , nocc_a , & 1.0_dp , work2 , nbf , & mo (:, 1 : nocc_a ), nbf , & 0.0_dp , work3 , nbf ) do i = 1 , nbf do a = 1 , nbf dm ( i , a ) = work3 ( i , a ) + work3 ( a , i ) end do end do call pack_matrix ( dm , dm_tri (:, 1 )) call get_response_packed ( infos % basis , infos , self % molGrid , mo , dm_tri , pfock ) call unpack_matrix ( pfock (:, 1 ), v ) work2 = 0 call dgemm ( 'T' , 'N' , nbf , nbf , nbf , & 1.0_dp , mo , nbf , & v , nbf , & 0.0_dp , work2 , nbf ) work3 = 0 call dgemm ( 'N' , 'N' , nbf , nbf , nbf , & 1.0_dp , work2 , nbf , & mo , nbf , & 0.0_dp , work3 , nbf ) x2mat = x2mat + work3 ( nocc_a + 1 :, 1 : nocc_a ) k = 0 do i = 1 , nvir_a do a = 1 , nocc_a k = k + 1 x2 ( k ) = 2 * x2mat ( i , a ) end do end do !============================== UHF ============================== case ( scf_uhf ) ! ---- α channel ---- k = 0 do i = 1 , nvir_a do a = 1 , nocc_a k = k + 1 xmat ( i , a ) = x ( k ) end do end do call dgemm ( 'N' , 'N' , nvir_a , nocc_a , nvir_a , & 1.0_dp , fvv , nvir_a , & xmat , nvir_a , & 0.0_dp , x2mat , nvir_a ) call dgemm ( 'N' , 'N' , nvir_a , nocc_a , nocc_a , & - 1.0_dp , xmat , nvir_a , & foo , nocc_a , & 1.0_dp , x2mat , nvir_a ) dm = 0.0_dp work2 = 0 call dgemm ( 'N' , 'N' , nbf , nocc_a , nvir_a , & 1.0_dp , mo (:, nocc_a + 1 : nbf ), nbf , & xmat , nvir_a , & 0.0_dp , work2 , nbf ) call dgemm ( 'N' , 'T' , nbf , nbf , nocc_a , & 1.0_dp , work2 , nbf , & mo (:, 1 : nocc_a ), nbf , & 0.0_dp , work3 , nbf ) do i = 1 , nbf do a = 1 , nbf dm ( i , a ) = work3 ( i , a ) + work3 ( a , i ) end do end do call pack_matrix ( dm , dm_tri (:, 1 )) k = nvir_a * nocc_a do i = 1 , nvir_b do a = 1 , nocc_b k = k + 1 xmat_b ( i , a ) = x ( k ) end do end do call dgemm ( 'N' , 'N' , nvir_b , nocc_b , nvir_b , & 1.0_dp , fvv_b , nvir_b , & xmat_b , nvir_b , & 0.0_dp , x2mat_b , nvir_b ) call dgemm ( 'N' , 'N' , nvir_b , nocc_b , nocc_b , & - 1.0_dp , xmat_b , nvir_b , & foo_b , nocc_b , & 1.0_dp , x2mat_b , nvir_b ) dm = 0.0_dp work2 = 0 call dgemm ( 'N' , 'N' , nbf , nocc_b , nvir_b , & 1.0_dp , mo_b (:, nocc_b + 1 : nbf ), nbf , & xmat_b , nvir_b , & 0.0_dp , work2 , nbf ) call dgemm ( 'N' , 'T' , nbf , nbf , nocc_b , & 1.0_dp , work2 , nbf , & mo_b (:, 1 : nocc_b ), nbf , & 0.0_dp , work3 , nbf ) do i = 1 , nbf do a = 1 , nbf dm ( i , a ) = work3 ( i , a ) + work3 ( a , i ) end do end do call pack_matrix ( dm , dm_tri (:, 2 )) ! end of dm calculation call get_response_packed ( infos % basis , infos , self % molGrid , mo , dm_tri , pfock , mo_b ) ! alpha x2mat call unpack_matrix ( pfock (:, 1 ), v ) work2 = 0 call dgemm ( 'T' , 'N' , nbf , nbf , nbf , & 1.0_dp , mo , nbf , & v , nbf , & 0.0_dp , work2 , nbf ) work3 = 0 call dgemm ( 'N' , 'N' , nbf , nbf , nbf , & 1.0_dp , work2 , nbf , & mo , nbf , & 0.0_dp , work3 , nbf ) x2mat = x2mat + work3 ( nocc_a + 1 :, 1 : nocc_a ) ! beta x2mat call unpack_matrix ( pfock (:, 2 ), v ) work2 = 0 call dgemm ( 'T' , 'N' , nbf , nbf , nbf , & 1.0_dp , mo_b , nbf , & v , nbf , & 0.0_dp , work2 , nbf ) work3 = 0 call dgemm ( 'N' , 'N' , nbf , nbf , nbf , & 1.0_dp , work2 , nbf , & mo_b , nbf , & 0.0_dp , work3 , nbf ) x2mat_b = x2mat_b + work3 ( nocc_b + 1 :, 1 : nocc_b ) k = 0 do i = 1 , nvir_a do a = 1 , nocc_a k = k + 1 x2 ( k ) = x2mat ( i , a ) end do end do do i = 1 , nvir_b do a = 1 , nocc_b k = k + 1 x2 ( k ) = x2mat_b ( i , a ) end do end do !============================== ROHF ============================== case ( scf_ROHF ) ! alpha call unpack_rohf_trial ( x , xmat , xmat_b , nbf , nocc_a , nocc_b ) call dgemm ( 'N' , 'N' , nvir_a , nocc_a , nvir_a , & 1.0_dp , fvv , nvir_a , & xmat , nvir_a , & 0.0_dp , x2mat , nvir_a ) call dgemm ( 'N' , 'N' , nvir_a , nocc_a , nocc_a , & - 1.0_dp , xmat , nvir_a , & foo , nocc_a , & 1.0_dp , x2mat , nvir_a ) dm = 0.0_dp work2 = 0 call dgemm ( 'N' , 'N' , nbf , nocc_a , nvir_a , & 1.0_dp , mo (:, nocc_a + 1 : nbf ), nbf , & xmat , nvir_a , & 0.0_dp , work2 , nbf ) call dgemm ( 'N' , 'T' , nbf , nbf , nocc_a , & 1.0_dp , work2 , nbf , & mo (:, 1 : nocc_a ), nbf , & 0.0_dp , work3 , nbf ) do i = 1 , nbf do a = 1 , nbf dm ( i , a ) = work3 ( i , a ) + work3 ( a , i ) end do end do call pack_matrix ( dm , dm_tri (:, 1 )) ! beta call dgemm ( 'N' , 'N' , nvir_b , nocc_b , nvir_b , & 1.0_dp , fvv_b , nvir_b , & xmat_b , nvir_b , & 0.0_dp , x2mat_b , nvir_b ) call dgemm ( 'N' , 'N' , nvir_b , nocc_b , nocc_b , & - 1.0_dp , xmat_b , nvir_b , & foo_b , nocc_b , & 1.0_dp , x2mat_b , nvir_b ) dm = 0.0_dp work2 = 0 call dgemm ( 'N' , 'N' , nbf , nocc_b , nvir_b , & 1.0_dp , mo_b (:, nocc_b + 1 : nbf ), nbf , & xmat_b , nvir_b , & 0.0_dp , work2 , nbf ) call dgemm ( 'N' , 'T' , nbf , nbf , nocc_b , & 1.0_dp , work2 , nbf , & mo_b (:, 1 : nocc_b ), nbf , & 0.0_dp , work3 , nbf ) do i = 1 , nbf do a = 1 , nbf dm ( i , a ) = work3 ( i , a ) + work3 ( a , i ) end do end do call pack_matrix ( dm , dm_tri (:, 2 )) ! end of dm calculation call get_response_packed ( infos % basis , infos , self % molGrid , mo , dm_tri , pfock , mo_b ) ! alpha x2mat call unpack_matrix ( pfock (:, 1 ), v ) work2 = 0 call dgemm ( 'T' , 'N' , nbf , nbf , nbf , & 1.0_dp , mo , nbf , & v , nbf , & 0.0_dp , work2 , nbf ) work3 = 0 call dgemm ( 'N' , 'N' , nbf , nbf , nbf , & 1.0_dp , work2 , nbf , & mo , nbf , & 0.0_dp , work3 , nbf ) x2mat = x2mat + work3 ( nocc_a + 1 :, 1 : nocc_a ) ! beta x2mat call unpack_matrix ( pfock (:, 2 ), v ) work2 = 0 call dgemm ( 'T' , 'N' , nbf , nbf , nbf , & 1.0_dp , mo_b , nbf , & v , nbf , & 0.0_dp , work2 , nbf ) work3 = 0 call dgemm ( 'N' , 'N' , nbf , nbf , nbf , & 1.0_dp , work2 , nbf , & mo_b , nbf , & 0.0_dp , work3 , nbf ) x2mat_b = x2mat_b + work3 ( nocc_b + 1 :, 1 : nocc_b ) call pack_rohf_trial ( x2 , x2mat , x2mat_b , nbf , nocc_a , nocc_b ) end select end associate end subroutine calc_h_op !> @brief Pack ROHF α/β trial matrices into a single rotation vector. !> @detail Packs S↔D, V↔D, and V↔S blocks according to the ROHF layout !>         (assuming nocc_a ≥ nocc_b), producing the linearized step. !> @param[inout] x       Output vector of packed rotations. !> @param[in]    xa      α-block trial matrix (V×Occ_α). !> @param[in]    xb      β-block trial matrix (V×Occ_β with offset). !> @param[in]    nbf     Number of basis functions. !> @param[in]    nocc_a  Number of α occupied orbitals. !> @param[in]    nocc_b  Number of β occupied orbitals. !> @author Mohsen Mazaherifar !> @date August 2025 subroutine pack_rohf_trial ( x , xa , xb , nbf , nocc_a , nocc_b ) use iso_fortran_env , only : dp => real64 implicit none real ( dp ), intent ( inout ) :: x (:) real ( dp ), intent ( in ) :: xa (:,:), xb (:,:) integer , intent ( in ) :: nbf , nocc_a , nocc_b integer :: nvir_a , nvir_b , offset , npar , k , iv , a nvir_a = nbf - nocc_a nvir_b = nbf - nocc_b offset = nocc_a - nocc_b npar = nocc_b * nvir_b + offset * nvir_a x = 0.0_dp k = 0 if ( offset > 0 ) then do iv = 1 , offset do a = 1 , nocc_b k = k + 1 x ( k ) = xb ( iv , a ) end do end do end if do iv = 1 , nvir_a do a = 1 , nocc_b k = k + 1 x ( k ) = xa ( iv , a ) + xb ( offset + iv , a ) end do end do if ( offset > 0 ) then do iv = 1 , nvir_a do a = 1 , offset k = k + 1 x ( k ) = xa ( iv , nocc_b + a ) end do end do end if end subroutine !> @brief Unpack ROHF packed rotation vector into α/β trial matrices. !> @detail Inverse of `pack_rohf_trial`. Reconstructs α and β trial blocks !>         from the linearized ROHF step layout (nocc_a ≥ nocc_b). !> @param[in]    x       Input packed rotation vector. !> @param[out]   xa      α-block trial matrix (V×Occ_α). !> @param[out]   xb      β-block trial matrix (V×Occ_β with offset). !> @param[in]    nbf     Number of basis functions. !> @param[in]    nocc_a  Number of α occupied orbitals. !> @param[in]    nocc_b  Number of β occupied orbitals. !> @author Mohsen Mazaherifar !> @date August 2025 subroutine unpack_rohf_trial ( x , xa , xb , nbf , nocc_a , nocc_b ) use precision , only : dp implicit none real ( dp ), intent ( in ) :: x (:) real ( dp ), intent ( out ) :: xa (:,:), xb (:,:) integer , intent ( in ) :: nbf , nocc_a , nocc_b integer :: nvir_a , nvir_b , ndocc , offset integer :: k , iv , a nvir_a = nbf - nocc_a nvir_b = nbf - nocc_b ndocc = nocc_b offset = nocc_a - nocc_b xa = 0.0_dp xb = 0.0_dp k = 0 if ( offset > 0 ) then do iv = 1 , offset do a = 1 , nocc_b k = k + 1 xb ( iv , a ) = x ( k ) end do end do end if do iv = 1 , nvir_a do a = 1 , nocc_b k = k + 1 xa ( iv , a ) = x ( k ) xb ( offset + iv , a ) = x ( k ) end do end do if ( offset > 0 ) then do iv = 1 , nvir_a do a = 1 , offset k = k + 1 xa ( iv , nocc_b + a ) = x ( k ) end do end do end if end subroutine !> @brief Build a skew-symmetric orbital-rotation generator K from a step. !> @detail Fills K with V↔Occ (and ROHF S↔D, V↔D, V↔S) elements from the !>         linearized step vector. Handles RHF/UHF with explicit `nocc`, !>         and ROHF using `self`’s spin occupations. Aborts on size mismatch. !> @param[inout] self   TRAH converger (uses scf_type and occ/vir sizes). !> @param[in]    step   Linearized rotation vector. !> @param[inout] K      Output skew-symmetric generator (nbf×nbf). !> @param[in,opt] nocc  Occupied count for non-ROHF (RHF/UHF) paths. !> @author Mohsen Mazaherifar !> @date August 2025 subroutine skew_sym_k ( self , step , K , nocc ) use precision , only : dp implicit none class ( trah_converger ), intent ( inout ) :: self real ( dp ), intent ( in ) :: step (:) real ( dp ), intent ( inout ) :: K (:,:) integer , intent ( in ), optional :: nocc ! used for non-ROHF paths integer :: nbf , nocc_a , nocc_b , nvir_a , nvir_b , scftype integer :: i , a , idx , expected , offset nbf = self % nbf nocc_a = self % nocc_a nocc_b = self % nocc_b nvir_a = self % nvir_a nvir_b = self % nvir_b scftype = self % scf_type if ( size ( K , 1 ) /= nbf . or . size ( K , 2 ) /= nbf ) error stop \"skew_sym_k: bad K dims\" if ( nocc_a + nvir_a /= nbf ) error stop \"skew_sym_k: nocc_a+nvir_a != nbf\" if ( nocc_b + nvir_b /= nbf ) error stop \"skew_sym_k: nocc_b+nvir_b != nbf\" K = 0.0_dp idx = 0 if ( scftype == 3 ) then ! ---------------- ROHF (single spatial K), assume nocc_a >= nocc_b ---------------- ! Subspaces: D=1..nocc_b, S=nocc_b+1..nocc_a, V=nocc_a+1..nbf ! ! step packing (length npar): !  1) S<->D (β-only extras):      size = nocc_b*(nocc_a - nocc_b) !  2) V<->D (common spin-sum):    size = nocc_b*nvir_a !  3) V<->S (α-only extras):      size = (nocc_a - nocc_b)*nvir_a ! offset = nocc_a - nocc_b expected = nocc_b * offset + nocc_b * nvir_a + offset * nvir_a if ( size ( step ) /= expected ) error stop \"skew_sym_k(ROHF): step length mismatch\" if ( offset > 0 ) then do i = nocc_b + 1 , nocc_a do a = 1 , nocc_b idx = idx + 1 K ( i , a ) = step ( idx ) K ( a , i ) = - step ( idx ) end do end do end if do i = nocc_a + 1 , nbf do a = 1 , nocc_b idx = idx + 1 K ( i , a ) = step ( idx ) K ( a , i ) = - step ( idx ) end do end do if ( offset > 0 ) then do i = nocc_a + 1 , nbf do a = nocc_b + 1 , nocc_a idx = idx + 1 K ( i , a ) = step ( idx ) K ( a , i ) = - step ( idx ) end do end do end if else ! ---------------- RHF / UHF path (single block V<->Occ) ---------------- if (. not . present ( nocc )) error stop \"skew_sym_k: nocc required for non-ROHF\" if ( nocc < 0 . or . nocc > nbf ) error stop \"skew_sym_k: nocc out of range\" expected = ( nbf - nocc ) * nocc if ( size ( step ) /= expected ) error stop \"skew_sym_k: step length mismatch\" do i = nocc + 1 , nbf do a = 1 , nocc idx = idx + 1 K ( i , a ) = step ( idx ) K ( a , i ) = - step ( idx ) end do end do end if if ( idx /= size ( step )) error stop \"skew_sym_k: not all elements consumed\" end subroutine !> @brief Rotate MOs by an exponential map of the generator (TRAH step). !> @detail Builds the skew-symmetric generator K from `step`, evaluates a !>         truncated matrix exponential (optionally higher-order), re-orthonormalizes !>         the transform, and updates MO := MO · exp(K). !> @param[inout] self  TRAH converger. !> @param[in]    step  Linearized rotation vector (packed). !> @param[in]    nbf   Basis dimension. !> @param[in]    nocc  Occupied count (used for non-ROHF paths). !> @param[inout] mo    MO coefficient matrix to be rotated (nbf×nbf). !> @author Mohsen Mazaherifar !> @date August 2025 subroutine rotate_orbs_trah ( self , step , nbf , nocc , mo ) implicit none class ( trah_converger ), intent ( inout ) :: self real ( kind = dp ), intent ( in ) :: step (:) integer , intent ( in ) :: nbf , nocc real ( kind = dp ), intent ( inout ) :: mo (:,:) real ( kind = dp ), allocatable :: K (:,:) integer :: i , idx , occ , virt , istart logical :: second_term if ( all ( step == 0.0d0 )) return allocate ( K ( nbf , nbf ), source = 0.0_dp ) self % work1 = 0 self % work2 = 0 idx = 0 second_term = . true . ! ---- Build skew-symmetric K from \"step\" (same as before) ---- call skew_sym_k ( self , step , K , nocc ) if ( self % scf_type == 3 ) then ! ROHF second_term = . true . end if call exp_scaling ( self % work1 , K , second_term ) call orthonormalize ( self % work1 , nbf ) call dgemm ( 'N' , 'N' , nbf , nbf , nbf , 1.0_dp , mo , nbf , self % work1 , nbf , 0.0_dp , self % work2 , nbf ) mo = self % work2 if ( allocated ( K )) deallocate ( K ) contains subroutine exp_scaling ( G , K , higher_order ) implicit none real ( kind = dp ), intent ( out ) :: G (:,:) real ( kind = dp ), intent ( in ) :: K (:,:) logical , intent ( in ) :: higher_order real ( kind = dp ), allocatable :: Kpow (:,:), Tmp (:,:) integer :: i , m integer , parameter :: max_order = 6 ! increase to 8/10 if desired real ( kind = dp ) :: coef allocate ( Kpow ( nbf , nbf ), source = 0.0_dp ) allocate ( Tmp ( nbf , nbf ), source = 0.0_dp ) ! ---- Initialize G = I ---- G = 0.0_dp do i = 1 , nbf G ( i , i ) = 1.0_dp end do ! ---- First-order: G <- I + K (always) ---- G = G + K if ( higher_order ) then ! Accumulate higher Taylor terms up to max_order using BLAS ! Start from K&#94;1 already in hand; build K&#94;m iteratively. Kpow = K coef = 1.0_dp do m = 2 , max_order ! Kpow <- Kpow * K == K&#94;m call dgemm ( 'N' , 'N' , nbf , nbf , nbf , 1.0_dp , Kpow , nbf , K , nbf , 0.0_dp , Tmp , nbf ) Kpow = Tmp coef = coef / real ( m , dp ) ! 1/m! (incrementally) G = G + coef * Kpow end do end if deallocate ( Tmp , Kpow ) end subroutine exp_scaling subroutine orthonormalize ( G , nbf ) real ( kind = dp ), intent ( inout ) :: G (:,:) integer , intent ( in ) :: nbf integer :: i , j real ( kind = dp ) :: norm , dot do i = 1 , nbf norm = sqrt ( dot_product ( G (:, i ), G (:, i ))) call dscal ( nbf , 1.0_dp / norm , G ( 1 , i ), 1 ) if ( i == nbf ) cycle do j = i + 1 , nbf dot = dot_product ( G (:, i ), G (:, j )) call daxpy ( nbf , - dot , G ( 1 , i ), 1 , G ( 1 , j ), 1 ) end do end do end subroutine orthonormalize end subroutine rotate_orbs_trah end module scf_converger","tags":"","url":"sourcefile/scf_converger.f90.html"},{"title":"mathlib_types.F90 – OpenQP Fortran API","text":"Source Code #ifndef OQP_BLAS_INT #define OQP_BLAS_INT 4 #endif module mathlib_types implicit none integer , parameter :: BLAS_INT = OQP_BLAS_INT integer , parameter :: HUGE_BLAS_INT = HUGE ( 1_BLAS_INT ) logical , parameter :: INT_REQ_CONV = storage_size ( 1_blas_int ) == storage_size ( 1 ) end module mathlib_types","tags":"","url":"sourcefile/mathlib_types.f90.html"},{"title":"functionals.F90 – OpenQP Fortran API","text":"Source Code !> @brief  MODULE functionals !> @brief  The part of libxc driver !> @detail This module save information about DFT functional, !>         which will work !> @author Igor S. Gerasimov !> @date   July, 2019 !>         Adding ability for Ground State and TD calculations module functionals use xc_f03_lib_m use iso_c_binding , only : C_INT , C_SIZE_T use precision , only : fp implicit none private ! Code of errors if LibXC can not perform calculation of some derivatives integer , parameter :: ENERGY_ERROR = 1 , & !< energy calculation error FIRST_ERROR = 2 , & !< first derivatives calculation error SECOND_ERROR = 3 , & !< second derivatives calculation error THIRD_ERROR = 4 , & !< third derivatives calculation error MGGA_3RD_ERROR = 5 !< TD-DFT gradient is not allowed for meta-GGA functionals type functional_t type ( xc_f03_func_t ), dimension (:), allocatable , private :: functionals_list type ( xc_f03_func_info_t ), dimension (:), allocatable , private :: functionals_info real ( kind = fp ), dimension (:), allocatable , private :: coefficients logical :: needgrd = . false . !< toggles calculation of density gradient logical :: needtau = . false . !< toggles calculation of tau (\\sum dot_product(\\nabla \\phi, \\nabla \\phi)) logical :: needlapl = . false . !< toggles calculation of lapl (\\nabla&#94;2 \\rho) contains procedure :: add_functional , can_calculate , destroy procedure :: calc_evxc , calc_evfxc , calc_xc end type functional_t public functional_t contains !> @brief  Add functional into internal array of functionals !> @author Igor S. Gerasimov !> @date   July,  2019 --Initial release-- !> @date   March, 2021 Add optional hfex, alpha, beta, omega parameters !> @date   July,  2021 Using messages module !> @params func_id             - (in)            internal key of functional in libxc !> @params coeff               - (in)            coefficient before functional for parametric schemes like B3LYP of PBE0 !> @params external_parameters - (in, optional)  setting external parameters for some LibXC functionals !> @params hfex                - (out, optional) returns % of HF of added functional (should be used only for hybrid functionals) !> @params alpha               - (out, optional) returns short-range % of HF of added range-saparated functional (should be used only for range-saparated hybrid functionals) !> @params beta                - (out, optional) returns long-range % of HF of added range-saparated functional (should be used only for range-saparated hybrid functionals) !> @params omega               - (out, optional) returns error function parameter of added range-saparated functional (should be used only for range-saparated hybrid functionals) subroutine add_functional ( this , func_id , coeff , external_parameters , hfex , alpha , beta , omega ) use messages , only : show_message , WITH_ABORT class ( functional_t ), intent ( inout ) :: this integer ( C_INT ), intent ( in ) :: func_id real ( kind = fp ), intent ( in ) :: coeff real ( kind = fp ), dimension (:), intent ( in ), optional :: external_parameters real ( kind = fp ), intent ( out ), optional :: hfex , alpha , beta , omega ! internal variables type ( xc_f03_func_t ), dimension (:), allocatable :: tmp_functionals type ( xc_f03_func_info_t ), dimension (:), allocatable :: tmp_functionals_info real ( kind = fp ), dimension (:), allocatable :: tmp_coefficients type ( xc_f03_func_reference_t ) :: xc_ref type ( xc_f03_func_t ) :: xc_func integer ( C_INT ) :: refnum integer :: refnumt if (. not . allocated ( this % functionals_list )) then allocate ( this % functionals_list ( 0 )) allocate ( this % functionals_info ( 0 )) allocate ( this % coefficients ( 0 )) end if allocate ( tmp_functionals ( size ( this % functionals_list ) + 1 )) allocate ( tmp_functionals_info ( size ( this % functionals_info ) + 1 )) allocate ( tmp_coefficients ( size ( this % coefficients ) + 1 )) tmp_functionals ( 1 : size ( this % functionals_list )) = this % functionals_list ( 1 : size ( this % functionals_list )) tmp_functionals_info ( 1 : size ( this % functionals_info )) = this % functionals_info ( 1 : size ( this % functionals_info )) tmp_coefficients ( 1 : size ( this % coefficients )) = this % coefficients ( 1 : size ( this % coefficients )) call move_alloc ( tmp_functionals , this % functionals_list ) call move_alloc ( tmp_functionals_info , this % functionals_info ) call move_alloc ( tmp_coefficients , this % coefficients ) call xc_f03_func_init ( xc_func , func_id , XC_POLARIZED ) select case ( xc_f03_func_info_get_kind ( xc_f03_func_get_info ( xc_func ))) case ( XC_EXCHANGE ) call show_message ( \"(A,ES16.8E2,A)\" , \"The \" // trim ( xc_f03_func_info_get_name ( xc_f03_func_get_info ( xc_func ))) // & \" exchange functional will be used with a coefficient \" , coeff , \".\" ) case ( XC_CORRELATION ) call show_message ( \"(A,ES16.8E2,A)\" , \"The \" // trim ( xc_f03_func_info_get_name ( xc_f03_func_get_info ( xc_func ))) // & \" correlation functional will be used with a coefficient \" , coeff , \".\" ) case ( XC_EXCHANGE_CORRELATION ) call show_message ( \"(A,ES16.8E2,A)\" , \"The \" // trim ( xc_f03_func_info_get_name ( xc_f03_func_get_info ( xc_func ))) // & \" exchange-correlation functional will be used with a coefficient \" , coeff , \".\" ) case ( XC_KINETIC ) call show_message ( \"(A,ES16.8E2,A)\" , \"The \" // trim ( xc_f03_func_info_get_name ( xc_f03_func_get_info ( xc_func ))) // & \" kinetic functional will be used with a coefficient \" , coeff , \".\" ) end select select case ( xc_f03_func_info_get_family ( xc_f03_func_get_info ( xc_func ))) case ( XC_FAMILY_GGA , XC_FAMILY_HYB_GGA ) this % needgrd = . true . case ( XC_FAMILY_MGGA , XC_FAMILY_HYB_MGGA ) this % needtau = . true . case ( XC_FAMILY_LDA , XC_FAMILY_HYB_LDA ) case default end select ! checking, that functional can be used. if ( IAND ( xc_f03_func_info_get_flags ( xc_f03_func_get_info ( xc_func )), XC_FLAGS_DEVELOPMENT ) . ne . 0 ) then call show_message ( \"The behavior of this functional can be changed in the next versions of LibXC.\" ) end if if ( IAND ( xc_f03_func_info_get_flags ( xc_f03_func_get_info ( xc_func )), XC_FLAGS_NEEDS_LAPLACIAN ) . ne . 0 ) then call show_message ( \"This functional requires laplacian, but the calculation of laplacian is not implemented\" // & \" in the current version of OQP.\" , WITH_ABORT ) end if if ( IAND ( xc_f03_func_info_get_flags ( xc_f03_func_get_info ( xc_func )), XC_FLAGS_VV10 ) . ne . 0 ) then call show_message ( \"This functional uses VV10 correlation, but the calculation of VV10 correlation is not\" // & \" implemented in the current version of OQP.\" , WITH_ABORT ) end if ! Then showing referencies refnum = 0_C_INT call show_message ( \"The functional has been described in the following articles:\" ) do refnumt = 1 , XC_MAX_REFERENCES xc_ref = xc_f03_func_info_get_references ( xc_f03_func_get_info ( xc_func ), refnum ) call show_message ( \"(A,I1,A)\" , \"[\" , refnumt , \"] \" // trim ( xc_f03_func_reference_get_ref ( xc_ref )) // \"; DOI: \" // & trim ( xc_f03_func_reference_get_doi ( xc_ref ))) if ( refnum . lt . 0 ) exit end do if ( present ( external_parameters )) then call xc_f03_func_set_ext_params ( xc_func , external_parameters ) end if if ( present ( hfex )) then hfex = xc_f03_hyb_exx_coef ( xc_func ) end if if ( present ( alpha ). and . present ( beta ). and . present ( omega )) then call xc_f03_hyb_cam_coef ( xc_func , omega , alpha , beta ) ! LibXC has alpha as fraction of full exchange and beta - additional fraction for short-range ! In the same time, OQP has alpha as a fraction for short-range, and beta - additional fraction for long-range alpha = alpha + beta beta = - beta else if ( present ( alpha ). or . present ( beta ). or . present ( omega )) then call show_message ( \"Check this range-separated functional: it has incorrect calling of add_functional routine\" // & \" (see functionals.src and libxc.src)\" , WITH_ABORT ) end if this % functionals_list ( size ( this % functionals_list )) = xc_func this % functionals_info ( size ( this % functionals_info )) = xc_f03_func_get_info ( xc_func ) this % coefficients ( size ( this % coefficients )) = coeff end subroutine add_functional !> @brief  Checking that at least one functional is selected !> @author Igor S. Gerasimov !> @date   Sep, 2019 --Initial release-- logical function can_calculate ( this ) result ( OK ) class ( functional_t ), intent ( inout ) :: this OK = ( allocated ( this % functionals_list ) . and . size ( this % functionals_list ) . gt . 0 ) end function can_calculate !> @brief  Destroy internal variables !> @author Igor S. Gerasimov !> @date   Dec, 2020 --Initial release-- !> @date   Mar, 2021 Add destruction of functionals_list pointers subroutine destroy ( this ) class ( functional_t ), intent ( inout ) :: this integer :: i if ( allocated ( this % functionals_list )) then do i = 1 , size ( this % functionals_list ) call xc_f03_func_end ( this % functionals_list ( i )) end do end if if ( allocated ( this % functionals_list )) deallocate ( this % functionals_list ) if ( allocated ( this % functionals_info )) deallocate ( this % functionals_info ) if ( allocated ( this % coefficients )) deallocate ( this % coefficients ) end subroutine destroy !> @brief  Perform DFT energy and its first derivatives calculation !> @author Igor S. Gerasimov !> @date   July, 2019 !> @params NPoints  - (in)  number of points !> @params rho      - (in)  density at points !> @params sigma    - (in)  gradient of density at points !> @params tau      - (in)  local kinetic energy at points !> @params lapl     - (in)  laplacian of density at points !> @params energy   - (out) energy at points !> @params dedrho   - (out) first derivative energy by density !> @params dedsigma - (out) first derivative energy by normed gradient !> @params dedtau   - (out) first derivative energy by kinetic energy !> @params dedlapl  - (out) first derivative energy by laplacian subroutine calc_evxc ( this , NPoints , rho , sigma , tau , lapl , energy , dedrho , dedsigma , dedtau , dedlapl ) class ( functional_t ), intent ( inout ) :: this integer , intent ( in ) :: NPoints real ( kind = fp ), dimension ( * ), intent ( in ) :: rho , sigma , tau , lapl real ( kind = fp ), dimension ( * ), intent ( out ) :: energy real ( kind = fp ), dimension ( * ), intent ( out ) :: dedrho , dedsigma , dedtau , dedlapl ! iterators integer :: i ! temporary arrays for containing energy and derivatives real ( kind = fp ), dimension ( 1 * NPoints ) :: tmp_energy real ( kind = fp ), dimension ( 2 * NPoints ) :: tmp_dEdrho , tmp_dEdtau real ( kind = fp ), dimension ( 3 * NPoints ) :: tmp_dEdsigma real ( kind = fp ), dimension ( 2 * NPoints ) :: tmp_dedlapl ! count of point for LibXC integer ( C_SIZE_T ) :: libxc_int ! coefficient of functional real ( kind = fp ) :: coefficient ! saving total density of each point real ( kind = fp ), dimension ( NPoints ) :: rhosum ! Build array for multiplying energy at each point rhosum = rho ( 1 : 2 * npoints : 2 ) + rho ( 2 : 2 * npoints : 2 ) ! Convert npoints from integer(8) to integer(4), that was used by LibXC libxc_int = int ( npoints ) ! returned values energy ( 1 : 1 * npoints ) = 0.0_fp dedrho ( 1 : 2 * npoints ) = 0.0_fp dedsigma ( 1 : 3 * npoints ) = 0.0_fp dedtau ( 1 : 2 * npoints ) = 0.0_fp dedlapl ( 1 : 2 * npoints ) = 0.0_fp if (. not . allocated ( this % functionals_list )) return ! The sum by arrays must be from LDAs to GGAs to meta-GGAs for avoiding errors ! when first meta-GGA functional is calculated, and then LDA functional also is calculated, ! which leads to double counting of some derivatives of mGGA do i = 1 , size ( this % functionals_list ) coefficient = this % coefficients ( i ) select case ( xc_f03_func_info_get_family ( this % functionals_info ( i ))) case ( XC_FAMILY_LDA , XC_FAMILY_HYB_LDA ) call xc_f03_lda_exc_vxc ( this % functionals_list ( i ), libxc_int , rho , tmp_energy , tmp_dedrho ) energy ( 1 : 1 * npoints ) = energy ( 1 : 1 * npoints ) + tmp_energy * coefficient dedrho ( 1 : 2 * npoints ) = dedrho ( 1 : 2 * npoints ) + tmp_dedrho * coefficient case ( XC_FAMILY_GGA , XC_FAMILY_HYB_GGA ) call xc_f03_gga_exc_vxc ( this % functionals_list ( i ), libxc_int , rho , sigma , & tmp_energy , tmp_dedrho , tmp_dedsigma ) energy ( 1 : 1 * npoints ) = energy ( 1 : 1 * npoints ) + tmp_energy * coefficient dedrho ( 1 : 2 * npoints ) = dedrho ( 1 : 2 * npoints ) + tmp_dedrho * coefficient dedsigma ( 1 : 3 * npoints ) = dedsigma ( 1 : 3 * npoints ) + tmp_dedsigma * coefficient case ( XC_FAMILY_MGGA , XC_FAMILY_HYB_MGGA ) call xc_f03_mgga_exc_vxc ( this % functionals_list ( i ), libxc_int , rho , sigma , lapl , tau , & tmp_energy , tmp_dedrho , tmp_dedsigma , tmp_dedlapl , tmp_dedtau ) energy ( 1 : 1 * npoints ) = energy ( 1 : 1 * npoints ) + tmp_energy * coefficient dedrho ( 1 : 2 * npoints ) = dedrho ( 1 : 2 * npoints ) + tmp_dedrho * coefficient dedsigma ( 1 : 3 * npoints ) = dedsigma ( 1 : 3 * npoints ) + tmp_dedsigma * coefficient dedtau ( 1 : 2 * npoints ) = dedtau ( 1 : 2 * npoints ) + tmp_dedtau * coefficient dedlapl ( 1 : 2 * npoints ) = dedlapl ( 1 : 2 * npoints ) + tmp_dedlapl * coefficient case default call write_error ( FIRST_ERROR , this % functionals_info ( i )) end select end do ! LibXC returns density of energy per particle energy ( 1 : npoints ) = energy ( 1 : npoints ) * rhosum end subroutine calc_evxc !> @brief  Perform DFT energy and its first and second derivatives calculation !> @author Igor S. Gerasimov !> @date   Sep, 2019 !> @params NPoints     - (in)  number of points !> @params rho         - (in)  density at point !> @params sigma       - (in)  gradient of density at point !> @params tau         - (in)  local kinetic energy at point !> @params lapl        - (in)  laplacian of density at point !> @params energy      - (out) energy at point !> @params dedrho      - (out) first derivatives energy by density !> @params dedsigma    - (out) first derivatives energy by normed gradient !> @params dedtau      - (out) first derivatives energy by kinetic energy !> @params dedlapl     - (out) first derivatives energy by laplacian !> @params v2rho2      - (out) second derivatives by density and density !> @params v2sigma2    - (out) second derivatives by normed gradient and normed gradient !> @params v2tau2      - (out) second derivatives by kinetic energy and kinetic energy !> @params v2lapl2     - (out) second derivatives by laplacian and laplacian !> @params v2rhosigma  - (out) second derivatives by density and normed gradient !> @params v2rhotau    - (out) second derivatives by density and kinetic energy !> @params v2rholapl   - (out) second derivatives by density and laplacian !> @params v2sigmatau  - (out) second derivatives by normed gradient and kinetic energy !> @params v2sigmalapl - (out) second derivatives by normed gradient and laplacian !> @params v2lapltau   - (out) second derivatives by laplacian and kinetic energy subroutine calc_evfxc ( this , NPoints , & rho , sigma , tau , lapl , energy , dedrho , dedsigma , dedtau , dedlapl , & v2rho2 , v2sigma2 , v2tau2 , v2lapl2 , & v2rhosigma , v2rhotau , v2rholapl , v2sigmatau , v2sigmalapl , v2lapltau ) class ( functional_t ), intent ( inout ) :: this integer , intent ( in ) :: NPoints real ( kind = fp ), dimension ( * ), intent ( in ) :: rho , sigma , tau , lapl real ( kind = fp ), dimension ( * ), intent ( out ) :: energy real ( kind = fp ), dimension ( * ), intent ( out ) :: dedrho , dedsigma , dedtau , dedlapl real ( kind = fp ), dimension ( * ), intent ( out ) :: v2rho2 , v2sigma2 , v2tau2 , v2lapl2 real ( kind = fp ), dimension ( * ), intent ( out ) :: v2rhosigma , v2rhotau , v2rholapl , v2sigmatau , v2sigmalapl , v2lapltau ! internal variables integer :: i real ( kind = fp ), dimension ( 1 * NPoints ) :: tmp_energy real ( kind = fp ), dimension ( 2 * NPoints ) :: tmp_dedrho , tmp_dedtau , tmp_dedlapl real ( kind = fp ), dimension ( 3 * NPoints ) :: tmp_dedsigma , tmp_v2rho2 , tmp_v2tau2 , tmp_v2lapl2 real ( kind = fp ), dimension ( 4 * NPoints ) :: tmp_v2rhotau , tmp_v2rholapl , tmp_v2lapltau real ( kind = fp ), dimension ( 6 * NPoints ) :: tmp_v2sigma2 , tmp_v2rhosigma , tmp_v2sigmatau , tmp_v2sigmalapl ! count of point for LibXC integer ( C_SIZE_T ) :: libxc_int ! coefficient of functional real ( kind = fp ) :: coefficient ! saving total density of each point real ( kind = fp ), dimension ( NPoints ) :: rhosum ! Build array for multiplying energy at each point rhosum = rho ( 1 : 2 * npoints : 2 ) + rho ( 2 : 2 * npoints : 2 ) ! Convert npoints from integer(8) to integer(4), that was used by LibXC libxc_int = int ( npoints ) energy ( 1 : 1 * npoints ) = 0.0_fp dedrho ( 1 : 2 * npoints ) = 0.0_fp dedsigma ( 1 : 3 * npoints ) = 0.0_fp dedlapl ( 1 : 2 * npoints ) = 0.0_fp dedtau ( 1 : 2 * npoints ) = 0.0_fp v2rho2 ( 1 : 3 * npoints ) = 0.0_fp v2rhosigma ( 1 : 6 * npoints ) = 0.0_fp v2rholapl ( 1 : 4 * npoints ) = 0.0_fp v2rhotau ( 1 : 4 * npoints ) = 0.0_fp v2sigma2 ( 1 : 6 * npoints ) = 0.0_fp v2sigmalapl ( 1 : 6 * npoints ) = 0.0_fp v2sigmatau ( 1 : 6 * npoints ) = 0.0_fp v2lapl2 ( 1 : 3 * npoints ) = 0.0_fp v2lapltau ( 1 : 4 * npoints ) = 0.0_fp v2tau2 ( 1 : 3 * npoints ) = 0.0_fp if (. not . allocated ( this % functionals_list )) return ! The sum by arrays must be in \"select case\" block for avoiding errors ! when firstly mGGA functional is calculated, and then LDA functional also is calculated, ! that leads to double counting of some derivatives of mGGA do i = 1 , size ( this % functionals_list ) coefficient = this % coefficients ( i ) select case ( xc_f03_func_info_get_family ( this % functionals_info ( i ))) case ( XC_FAMILY_LDA , XC_FAMILY_HYB_LDA ) call xc_f03_lda_exc_vxc_fxc ( this % functionals_list ( i ), libxc_int , rho , & tmp_energy , tmp_dedrho , tmp_v2rho2 ) energy ( 1 : 1 * npoints ) = energy ( 1 : 1 * npoints ) + tmp_energy * coefficient dedrho ( 1 : 2 * npoints ) = dedrho ( 1 : 2 * npoints ) + tmp_dedrho * coefficient v2rho2 ( 1 : 3 * npoints ) = v2rho2 ( 1 : 3 * npoints ) + tmp_v2rho2 * coefficient case ( XC_FAMILY_GGA , XC_FAMILY_HYB_GGA ) call xc_f03_gga_exc_vxc_fxc ( this % functionals_list ( i ), libxc_int , rho , sigma , & tmp_energy , tmp_dedrho , tmp_dedsigma , tmp_v2rho2 , tmp_v2rhosigma , tmp_v2sigma2 ) energy ( 1 : 1 * npoints ) = energy ( 1 : 1 * npoints ) + tmp_energy * coefficient dedrho ( 1 : 2 * npoints ) = dedrho ( 1 : 2 * npoints ) + tmp_dedrho * coefficient dedsigma ( 1 : 3 * npoints ) = dedsigma ( 1 : 3 * npoints ) + tmp_dedsigma * coefficient v2rho2 ( 1 : 3 * npoints ) = v2rho2 ( 1 : 3 * npoints ) + tmp_v2rho2 * coefficient v2rhosigma ( 1 : 6 * npoints ) = v2rhosigma ( 1 : 6 * npoints ) + tmp_v2rhosigma * coefficient v2sigma2 ( 1 : 6 * npoints ) = v2sigma2 ( 1 : 6 * npoints ) + tmp_v2sigma2 * coefficient case ( XC_FAMILY_MGGA , XC_FAMILY_HYB_MGGA ) call xc_f03_mgga_exc_vxc_fxc ( this % functionals_list ( i ), libxc_int , rho , sigma , lapl , tau , & tmp_energy , tmp_dedrho , tmp_dedsigma , tmp_dedlapl , tmp_dedtau , & tmp_v2rho2 , tmp_v2rhosigma , tmp_v2rholapl , tmp_v2rhotau , & tmp_v2sigma2 , tmp_v2sigmalapl , tmp_v2sigmatau , tmp_v2lapl2 , tmp_v2lapltau , tmp_v2tau2 ) energy ( 1 : 1 * npoints ) = energy ( 1 : 1 * npoints ) + tmp_energy * coefficient dedrho ( 1 : 2 * npoints ) = dedrho ( 1 : 2 * npoints ) + tmp_dedrho * coefficient dedsigma ( 1 : 3 * npoints ) = dedsigma ( 1 : 3 * npoints ) + tmp_dedsigma * coefficient dedlapl ( 1 : 2 * npoints ) = dedlapl ( 1 : 2 * npoints ) + tmp_dedlapl * coefficient dedtau ( 1 : 2 * npoints ) = dedtau ( 1 : 2 * npoints ) + tmp_dedtau * coefficient v2rho2 ( 1 : 3 * npoints ) = v2rho2 ( 1 : 3 * npoints ) + tmp_v2rho2 * coefficient v2rhosigma ( 1 : 6 * npoints ) = v2rhosigma ( 1 : 6 * npoints ) + tmp_v2rhosigma * coefficient v2rholapl ( 1 : 4 * npoints ) = v2rholapl ( 1 : 4 * npoints ) + tmp_v2rholapl * coefficient v2rhotau ( 1 : 4 * npoints ) = v2rhotau ( 1 : 4 * npoints ) + tmp_v2rhotau * coefficient v2sigma2 ( 1 : 6 * npoints ) = v2sigma2 ( 1 : 6 * npoints ) + tmp_v2sigma2 * coefficient v2sigmalapl ( 1 : 6 * npoints ) = v2sigmalapl ( 1 : 6 * npoints ) + tmp_v2sigmalapl * coefficient v2sigmatau ( 1 : 6 * npoints ) = v2sigmatau ( 1 : 6 * npoints ) + tmp_v2sigmatau * coefficient v2lapl2 ( 1 : 3 * npoints ) = v2lapl2 ( 1 : 3 * npoints ) + tmp_v2lapl2 * coefficient v2lapltau ( 1 : 4 * npoints ) = v2lapltau ( 1 : 4 * npoints ) + tmp_v2lapltau * coefficient v2tau2 ( 1 : 3 * npoints ) = v2tau2 ( 1 : 3 * npoints ) + tmp_v2tau2 * coefficient case default call write_error ( SECOND_ERROR , this % functionals_info ( i )) end select end do ! LibXC returns density of energy per particle energy ( 1 : npoints ) = energy ( 1 : npoints ) * rhosum end subroutine calc_evfxc !> @brief  Perform DFT energy and its first, second and third derivatives calculation !> @author Igor S. Gerasimov !> @date   Sep, 2019 !> @params npoints        - (in)  number of points !> @params rho            - (in)  density at point !> @params sigma          - (in)  gradient of density at point !> @params tau            - (in)  local kinetic energy at point !> @params lapl           - (in)  laplacian of density at point !> @params energy         - (out) energy at point !> @params dedrho         - (out) first  derivatives energy by density !> @params dedsigma       - (out) first  derivatives energy by normed gradient !> @params dedlapl        - (out) first  derivatives energy by laplacian !> @params dedtau         - (out) first  derivatives energy by kinetic energy !> @params v2rho2         - (out) second derivatives by density         and density !> @params v2rhosigma     - (out) second derivatives by density         and normed gradient !> @params v2rholapl      - (out) second derivatives by density         and laplacian !> @params v2rhotau       - (out) second derivatives by density         and kinetic energy !> @params v2sigma2       - (out) second derivatives by normed gradient and normed gradient !> @params v2sigmalapl    - (out) second derivatives by normed gradient and laplacian !> @params v2sigmatau     - (out) second derivatives by normed gradient and kinetic energy !> @params v2lapl2        - (out) second derivatives by laplacian       and laplacian !> @params v2lapltau      - (out) second derivatives by laplacian       and kinetic energy !> @params v2tau2         - (out) second derivatives by kinetic energy  and kinetic energy !> @params v3rho3         - (out) third  derivatives by density         and density         and density !> @params v3rho2sigma    - (out) third  derivatives by density         and density         and normed gradient !> @params v3rho2lapl     - (out) third  derivatives by density         and density         and laplacian !> @params v3rho2tau      - (out) third  derivatives by density         and density         and kinetic energy !> @params v3rhosigma2    - (out) third  derivatives by density         and normed gradient and normed gradient !> @params v3rhosigmalapl - (out) third  derivatives by density         and normed gradient and laplacian !> @params v3rhosigmatau  - (out) third  derivatives by density         and normed gradient and density !> @params v3rholapl2     - (out) third  derivatives by density         and laplacian       and laplacian !> @params v3rholapltau   - (out) third  derivatives by density         and laplacian       and density !> @params v3rhotau2      - (out) third  derivatives by density         and kinetic energy  and kinetic energy !> @params v3sigma3       - (out) third  derivatives by normed gradient and normed gradient and normed gradient !> @params v3sigma2lapl   - (out) third  derivatives by normed gradient and normed gradient and laplacian !> @params v3sigma2tau    - (out) third  derivatives by normed gradient and normed gradient and kinetic energy !> @params v3sigmalapl2   - (out) third  derivatives by normed gradient and laplacian       and laplacian !> @params v3sigmalapltau - (out) third  derivatives by normed gradient and laplacian       and kinetic energy !> @params v3sigmatau2    - (out) third  derivatives by normed gradient and kinetic energy  and kinetic energy !> @params v3lapl3        - (out) third  derivatives by laplacian       and laplacian       and laplacian !> @params v3lapl2tau     - (out) third  derivatives by laplacian       and laplacian       and kinetic energy !> @params v3lapltau2     - (out) third  derivatives by laplacian       and kinetic energy  and kinetic energy !> @params v3tau3         - (out) third  derivatives by kinetic energy  and kinetic energy  and kinetic energy subroutine calc_xc ( this , npoints , & rho , sigma , tau , lapl , energy , dedrho , dedsigma , dedlapl , dedtau , & v2rho2 , v2rhosigma , v2rholapl , v2rhotau , & v2sigma2 , v2sigmalapl , v2sigmatau , v2lapl2 , v2lapltau , v2tau2 , & v3rho3 , v3rho2sigma , v3rho2lapl , v3rho2tau , v3rhosigma2 , v3rhosigmalapl , & v3rhosigmatau , v3rholapl2 , v3rholapltau , v3rhotau2 , v3sigma3 , v3sigma2lapl , & v3sigma2tau , v3sigmalapl2 , v3sigmalapltau , v3sigmatau2 , v3lapl3 , v3lapl2tau , & v3lapltau2 , v3tau3 ) class ( functional_t ), intent ( inout ) :: this integer , intent ( in ) :: NPoints real ( kind = fp ), dimension ( * ), intent ( in ) :: rho , sigma , tau , lapl real ( kind = fp ), dimension ( * ), intent ( out ) :: energy real ( kind = fp ), dimension ( * ), intent ( out ) :: dedrho , dedsigma , dedlapl , dedtau real ( kind = fp ), dimension ( * ), intent ( out ) :: v2rho2 , v2rhosigma , v2rholapl , v2rhotau real ( kind = fp ), dimension ( * ), intent ( out ) :: v2sigma2 , v2sigmalapl , v2sigmatau , v2lapl2 , v2lapltau , v2tau2 real ( kind = fp ), dimension ( * ), intent ( out ) :: v3rho3 , v3rho2sigma , v3rho2lapl , v3rho2tau , v3rhosigma2 , v3rhosigmalapl real ( kind = fp ), dimension ( * ), intent ( out ) :: v3rhosigmatau , v3rholapl2 , v3rholapltau , v3rhotau2 , v3sigma3 , v3sigma2lapl real ( kind = fp ), dimension ( * ), intent ( out ) :: v3sigma2tau , v3sigmalapl2 , v3sigmalapltau , v3sigmatau2 , v3lapl3 , v3lapl2tau real ( kind = fp ), dimension ( * ), intent ( out ) :: v3lapltau2 , v3tau3 ! internal variables integer :: i real ( kind = fp ), dimension ( 1 * NPoints ) :: tmp_energy real ( kind = fp ), dimension ( 2 * NPoints ) :: tmp_dedrho , tmp_dedtau , tmp_dedlapl real ( kind = fp ), dimension ( 3 * NPoints ) :: tmp_dedsigma , tmp_v2rho2 , tmp_v2tau2 , tmp_v2lapl2 real ( kind = fp ), dimension ( 4 * NPoints ) :: tmp_v2rhotau , tmp_v2rholapl , tmp_v2lapltau real ( kind = fp ), dimension ( 6 * NPoints ) :: tmp_v2sigma2 , tmp_v2rhosigma , tmp_v2sigmatau , tmp_v2sigmalapl !for third derivatives real ( kind = fp ), dimension ( 4 * NPoints ) :: tmp_v3rho3 , tmp_v3tau3 , tmp_v3lapl3 real ( kind = fp ), dimension ( 6 * NPoints ) :: tmp_v3rho2tau , tmp_v3rhotau2 , tmp_v3rho2lapl , tmp_v3rholapl2 , tmp_v3lapl2tau , & tmp_v3lapltau2 real ( kind = fp ), dimension ( 8 * NPoints ) :: tmp_v3rholapltau real ( kind = fp ), dimension ( 9 * NPoints ) :: tmp_v3rho2sigma , tmp_v3sigmatau2 , tmp_v3sigmalapl2 real ( kind = fp ), dimension ( 10 * NPoints ) :: tmp_v3sigma3 real ( kind = fp ), dimension ( 12 * NPoints ) :: tmp_v3rhosigma2 , tmp_v3rhosigmatau , tmp_v3sigma2tau , tmp_v3rhosigmalapl , & tmp_v3sigma2lapl , tmp_v3sigmalapltau ! count of point for LibXC integer ( C_SIZE_T ) :: libxc_int ! coefficient of functional real ( kind = fp ) :: coefficient ! saving total density of each point real ( kind = fp ), dimension ( NPoints ) :: rhosum ! Build array for multiplying energy at each point rhosum = rho ( 1 : 2 * npoints : 2 ) + rho ( 2 : 2 * npoints : 2 ) ! Convert npoints from integer(8) to integer(4), that was used by LibXC libxc_int = int ( npoints ) energy ( 1 : 1 * npoints ) = 0.0_fp dedrho ( 1 : 2 * npoints ) = 0.0_fp dedsigma ( 1 : 3 * npoints ) = 0.0_fp dedlapl ( 1 : 2 * npoints ) = 0.0_fp dedtau ( 1 : 2 * npoints ) = 0.0_fp v2rho2 ( 1 : 3 * npoints ) = 0.0_fp v2rhosigma ( 1 : 6 * npoints ) = 0.0_fp v2rholapl ( 1 : 4 * npoints ) = 0.0_fp v2rhotau ( 1 : 4 * npoints ) = 0.0_fp v2sigma2 ( 1 : 6 * npoints ) = 0.0_fp v2sigmalapl ( 1 : 6 * npoints ) = 0.0_fp v2sigmatau ( 1 : 6 * npoints ) = 0.0_fp v2lapl2 ( 1 : 3 * npoints ) = 0.0_fp v2lapltau ( 1 : 4 * npoints ) = 0.0_fp v2tau2 ( 1 : 3 * npoints ) = 0.0_fp v3rho3 ( 1 : 4 * npoints ) = 0.0_fp v3rho2sigma ( 1 : 9 * npoints ) = 0.0_fp v3rho2lapl ( 1 : 6 * npoints ) = 0.0_fp v3rho2tau ( 1 : 6 * npoints ) = 0.0_fp v3rhosigma2 ( 1 : 12 * npoints ) = 0.0_fp v3rhosigmalapl ( 1 : 12 * npoints ) = 0.0_fp v3rhosigmatau ( 1 : 12 * npoints ) = 0.0_fp v3rholapl2 ( 1 : 6 * npoints ) = 0.0_fp v3rholapltau ( 1 : 8 * npoints ) = 0.0_fp v3rhotau2 ( 1 : 6 * npoints ) = 0.0_fp v3sigma3 ( 1 : 10 * npoints ) = 0.0_fp v3sigma2lapl ( 1 : 12 * npoints ) = 0.0_fp v3sigma2tau ( 1 : 12 * npoints ) = 0.0_fp v3sigmalapl2 ( 1 : 9 * npoints ) = 0.0_fp v3sigmalapltau ( 1 : 12 * npoints ) = 0.0_fp v3sigmatau2 ( 1 : 9 * npoints ) = 0.0_fp v3lapl3 ( 1 : 4 * npoints ) = 0.0_fp v3lapl2tau ( 1 : 6 * npoints ) = 0.0_fp v3lapltau2 ( 1 : 6 * npoints ) = 0.0_fp v3tau3 ( 1 : 4 * npoints ) = 0.0_fp if (. not . allocated ( this % functionals_list )) return ! The sum by arrays must be in \"select case\" block for avoiding errors ! when firstly mGGA functional is calculated, and then LDA functional also is calculated, ! that leads to double counting of some derivatives of mGGA do i = 1 , size ( this % functionals_list ) coefficient = this % coefficients ( i ) select case ( xc_f03_func_info_get_family ( this % functionals_info ( i ))) case ( XC_FAMILY_LDA , XC_FAMILY_HYB_LDA ) call xc_f03_lda_exc_vxc_fxc_kxc ( this % functionals_list ( i ), libxc_int , rho , & tmp_energy , tmp_dedrho , tmp_v2rho2 , tmp_v3rho3 ) energy ( 1 : 1 * npoints ) = energy ( 1 : 1 * npoints ) + tmp_energy * coefficient dedrho ( 1 : 2 * npoints ) = dedrho ( 1 : 2 * npoints ) + tmp_dedrho * coefficient v2rho2 ( 1 : 3 * npoints ) = v2rho2 ( 1 : 3 * npoints ) + tmp_v2rho2 * coefficient v3rho3 ( 1 : 4 * npoints ) = v3rho3 ( 1 : 4 * npoints ) + tmp_v3rho3 * coefficient case ( XC_FAMILY_GGA , XC_FAMILY_HYB_GGA ) call xc_f03_gga_exc_vxc_fxc_kxc ( this % functionals_list ( i ), libxc_int , rho , sigma , & tmp_energy , tmp_dedrho , tmp_dedsigma , tmp_v2rho2 , tmp_v2rhosigma , tmp_v2sigma2 , & tmp_v3rho3 , tmp_v3rho2sigma , tmp_v3rhosigma2 , tmp_v3sigma3 ) energy ( 1 : 1 * npoints ) = energy ( 1 : 1 * npoints ) + tmp_energy * coefficient dedrho ( 1 : 2 * npoints ) = dedrho ( 1 : 2 * npoints ) + tmp_dedrho * coefficient dedsigma ( 1 : 3 * npoints ) = dedsigma ( 1 : 3 * npoints ) + tmp_dedsigma * coefficient v2rho2 ( 1 : 3 * npoints ) = v2rho2 ( 1 : 3 * npoints ) + tmp_v2rho2 * coefficient v2rhosigma ( 1 : 6 * npoints ) = v2rhosigma ( 1 : 6 * npoints ) + tmp_v2rhosigma * coefficient v2sigma2 ( 1 : 6 * npoints ) = v2sigma2 ( 1 : 6 * npoints ) + tmp_v2sigma2 * coefficient v3rho3 ( 1 : 4 * npoints ) = v3rho3 ( 1 : 4 * npoints ) + tmp_v3rho3 * coefficient v3rho2sigma ( 1 : 9 * npoints ) = v3rho2sigma ( 1 : 9 * npoints ) + tmp_v3rho2sigma * coefficient v3rhosigma2 ( 1 : 12 * npoints ) = v3rhosigma2 ( 1 : 12 * npoints ) + tmp_v3rhosigma2 * coefficient v3sigma3 ( 1 : 10 * npoints ) = v3sigma3 ( 1 : 10 * npoints ) + tmp_v3sigma3 * coefficient case ( XC_FAMILY_MGGA , XC_FAMILY_HYB_MGGA ) call xc_f03_mgga_exc_vxc_fxc_kxc ( this % functionals_list ( i ), libxc_int , rho , sigma , lapl , tau , & tmp_energy , tmp_dedrho , tmp_dedsigma , tmp_dedlapl , tmp_dedtau , tmp_v2rho2 , tmp_v2rhosigma , tmp_v2rholapl , & tmp_v2rhotau , tmp_v2sigma2 , tmp_v2sigmalapl , tmp_v2sigmatau , tmp_v2lapl2 , tmp_v2lapltau , tmp_v2tau2 , & tmp_v3rho3 , tmp_v3rho2sigma , tmp_v3rho2lapl , tmp_v3rho2tau , tmp_v3rhosigma2 , tmp_v3rhosigmalapl , & tmp_v3rhosigmatau , tmp_v3rholapl2 , tmp_v3rholapltau , tmp_v3rhotau2 , tmp_v3sigma3 , tmp_v3sigma2lapl , & tmp_v3sigma2tau , tmp_v3sigmalapl2 , tmp_v3sigmalapltau , tmp_v3sigmatau2 , tmp_v3lapl3 , tmp_v3lapl2tau , & tmp_v3lapltau2 , tmp_v3tau3 ) energy ( 1 : 1 * npoints ) = energy ( 1 : 1 * npoints ) + tmp_energy * coefficient dedrho ( 1 : 2 * npoints ) = dedrho ( 1 : 2 * npoints ) + tmp_dedrho * coefficient dedsigma ( 1 : 3 * npoints ) = dedsigma ( 1 : 3 * npoints ) + tmp_dedsigma * coefficient dedlapl ( 1 : 2 * npoints ) = dedlapl ( 1 : 2 * npoints ) + tmp_dedlapl * coefficient dedtau ( 1 : 2 * npoints ) = dedtau ( 1 : 2 * npoints ) + tmp_dedtau * coefficient v2rho2 ( 1 : 3 * npoints ) = v2rho2 ( 1 : 3 * npoints ) + tmp_v2rho2 * coefficient v2rhosigma ( 1 : 6 * npoints ) = v2rhosigma ( 1 : 6 * npoints ) + tmp_v2rhosigma * coefficient v2rholapl ( 1 : 4 * npoints ) = v2rholapl ( 1 : 4 * npoints ) + tmp_v2rholapl * coefficient v2rhotau ( 1 : 4 * npoints ) = v2rhotau ( 1 : 4 * npoints ) + tmp_v2rhotau * coefficient v2sigma2 ( 1 : 6 * npoints ) = v2sigma2 ( 1 : 6 * npoints ) + tmp_v2sigma2 * coefficient v2sigmalapl ( 1 : 6 * npoints ) = v2sigmalapl ( 1 : 6 * npoints ) + tmp_v2sigmalapl * coefficient v2sigmatau ( 1 : 6 * npoints ) = v2sigmatau ( 1 : 6 * npoints ) + tmp_v2sigmatau * coefficient v2lapl2 ( 1 : 3 * npoints ) = v2lapl2 ( 1 : 3 * npoints ) + tmp_v2lapl2 * coefficient v2lapltau ( 1 : 4 * npoints ) = v2lapltau ( 1 : 4 * npoints ) + tmp_v2lapltau * coefficient v2tau2 ( 1 : 3 * npoints ) = v2tau2 ( 1 : 3 * npoints ) + tmp_v2tau2 * coefficient v3rho3 ( 1 : 4 * npoints ) = v3rho3 ( 1 : 4 * npoints ) + tmp_v3rho3 * coefficient v3rho2sigma ( 1 : 9 * npoints ) = v3rho2sigma ( 1 : 9 * npoints ) + tmp_v3rho2sigma * coefficient v3rho2lapl ( 1 : 6 * npoints ) = v3rho2lapl ( 1 : 6 * npoints ) + tmp_v3rho2lapl * coefficient v3rho2tau ( 1 : 6 * npoints ) = v3rho2tau ( 1 : 6 * npoints ) + tmp_v3rho2tau * coefficient v3rhosigma2 ( 1 : 12 * npoints ) = v3rhosigma2 ( 1 : 12 * npoints ) + tmp_v3rhosigma2 * coefficient v3rhosigmalapl ( 1 : 12 * npoints ) = v3rhosigmalapl ( 1 : 12 * npoints ) + tmp_v3rhosigmalapl * coefficient v3rhosigmatau ( 1 : 12 * npoints ) = v3rhosigmatau ( 1 : 12 * npoints ) + tmp_v3rhosigmatau * coefficient v3rholapl2 ( 1 : 6 * npoints ) = v3rholapl2 ( 1 : 6 * npoints ) + tmp_v3rholapl2 * coefficient v3rholapltau ( 1 : 8 * npoints ) = v3rholapltau ( 1 : 8 * npoints ) + tmp_v3rholapltau * coefficient v3rhotau2 ( 1 : 6 * npoints ) = v3rhotau2 ( 1 : 6 * npoints ) + tmp_v3rhotau2 * coefficient v3sigma3 ( 1 : 10 * npoints ) = v3sigma3 ( 1 : 10 * npoints ) + tmp_v3sigma3 * coefficient v3sigma2lapl ( 1 : 12 * npoints ) = v3sigma2lapl ( 1 : 12 * npoints ) + tmp_v3sigma2lapl * coefficient v3sigma2tau ( 1 : 12 * npoints ) = v3sigma2tau ( 1 : 12 * npoints ) + tmp_v3sigma2tau * coefficient v3sigmalapl2 ( 1 : 9 * npoints ) = v3sigmalapl2 ( 1 : 9 * npoints ) + tmp_v3sigmalapl2 * coefficient v3sigmalapltau ( 1 : 12 * npoints ) = v3sigmalapltau ( 1 : 12 * npoints ) + tmp_v3sigmalapltau * coefficient v3sigmatau2 ( 1 : 9 * npoints ) = v3sigmatau2 ( 1 : 9 * npoints ) + tmp_v3sigmatau2 * coefficient v3lapl3 ( 1 : 4 * npoints ) = v3lapl3 ( 1 : 4 * npoints ) + tmp_v3lapl3 * coefficient v3lapl2tau ( 1 : 6 * npoints ) = v3lapl2tau ( 1 : 6 * npoints ) + tmp_v3lapl2tau * coefficient v3lapltau2 ( 1 : 6 * npoints ) = v3lapltau2 ( 1 : 6 * npoints ) + tmp_v3lapltau2 * coefficient v3tau3 ( 1 : 4 * npoints ) = v3tau3 ( 1 : 4 * npoints ) + tmp_v3tau3 * coefficient case default call write_error ( THIRD_ERROR , this % functionals_info ( i )) end select end do ! LibXC returns density of energy per particle energy ( 1 : npoints ) = energy ( 1 : npoints ) * rhosum end subroutine calc_xc !> @brief  Internal procedure for writing error !> @author Igor S. Gerasimov !> @date   Oct, 2019 - Initial release - !> @date   Jul, 2021 Using messages module !> @params error_code      - (in)  code of error !> @params functional_info - (in)  info about functional for getting of name subroutine write_error ( error_code , functional_info ) use messages , only : WITH_ABORT , show_message integer , intent ( in ) :: error_code type ( xc_f03_func_info_t ), intent ( in ) :: functional_info character ( len = :), allocatable :: functional_name character ( len = :), allocatable :: error_line select case ( xc_f03_func_info_get_kind ( functional_info )) case ( XC_EXCHANGE ) functional_name = trim ( xc_f03_func_info_get_name ( functional_info )) // \" exchange functional.\" case ( XC_CORRELATION ) functional_name = trim ( xc_f03_func_info_get_name ( functional_info )) // \" correlation functional.\" case ( XC_EXCHANGE_CORRELATION ) functional_name = trim ( xc_f03_func_info_get_name ( functional_info )) // \" exchange-correlation functional.\" case ( XC_KINETIC ) functional_name = trim ( xc_f03_func_info_get_name ( functional_info )) // \" kinetic functional.\" case default functional_name = \"Unnamed functional\" end select select case ( error_code ) case ( ENERGY_ERROR ) error_line = \"Something went wrong while the energy was tried to calculate using \" // functional_name case ( FIRST_ERROR ) error_line = \"Something went wrong while the first derivatives were tried to calculate using \" // functional_name case ( SECOND_ERROR ) error_line = \"Something went wrong while the second derivatives were tried to calculate using \" // functional_name case ( THIRD_ERROR ) error_line = \"Something went wrong while the third derivatives were tried to calculate using \" // functional_name case ( MGGA_3RD_ERROR ) error_line = \"TD-DFT third derivatives do not support for meta-GGA functionals like \" // functional_name case default error_line = \"Explore OQP error\" end select call show_message ( error_line ) call show_message ( \"Abort was produced by LibXC interface...\" , WITH_ABORT ) end subroutine write_error end module functionals","tags":"","url":"sourcefile/functionals.f90.html"},{"title":"huckel_lut.F90 – OpenQP Fortran API","text":"Source Code module huckel_lut use iso_fortran_env , only : real64 private public huckel_eneg public huckel_ncore public huckel_nval public huckel_ndval public huckel_lneg !> @brief Information on orbital energies and their sources. !> !> @details !>     ORBITAL ENERGIES FOR H-XE ARE TAKEN FROM: !>     E. Clementi, C. Roetti - AT. NUC. DATA TABLES, VOL 14. !>     Transition metal energies are from S**1 D**N configurations, !>     except for Sc, Ti, Zn, and Y, Zr, Cd. !> !>     ORBITAL ENERGIES FOR CS-RN ARE TAKEN FROM: !>     J. B. Mann - Los Alamos Reports Numbers LA-3690 and LA-3691. !>     Note that Mann's energies are in Rydberg units! !> !> @assumptions: !>     - H, He have valence S. !>     - Alkalis have valence S. !>     - Right main group elements have valence S and P. !>     - Transition metals have valence D and S. !>     - Lanthanides have valence F and S. !> !> @order: !>     The order of the energies is as follows: !>       - For H-BA: 1S, 2S, 2P, 3S, 3P, 3D, 4S, 4P, 4D, 5S, 5P, 5D, 6S, 6P !>         (Using 0.0 for the highest D and P for alkalis) !>       - For LA-YB: 1S, 2S, 2P, 3S, 3P, 3D, 4S, 4P, 4D, 5S, 5P, 4F, 6S !>       - For LU-RN: 1S, 2S, 2P, 3S, 3P, 3D, 4S, 4P, 4D, 4F, 5S, 5P, 5D, 6S, 6P !>       - For FR-RA: 1S, 2S, 2P, 3S, 3P, 3D, 4S, 4P, 4D, 4F, 5S, 5P, 5D, 6S, 6P, 7S !>       - For AC-TH: 1S, 2S, 2P, 3S, 3P, 3D, 4S, 4P, 4D, 4F, 5S, 5P, 5D, 6S, 6P, 6D, 7S !>       - For PA-LR: 1S, 2S, 2P, 3S, 3P, 3D, 4S, 4P, 4D, 4F, 5S, 5P, 5D, 6S, 6P, 5F, 6D, 7S !> !>     Note: Data for row 7 elements will require further consideration. real ( real64 ), parameter :: huckel_eneg ( 18 , 103 ) = reshape ([ & - 5.000000000000000D-01 , 0.000000000000000D+00 , 0.000000000000000D+00 , 0.000000000000000D+00 , 0.000000000000000D+00 , & 0.000000000000000D+00 , 0.000000000000000D+00 , 0.000000000000000D+00 , 0.000000000000000D+00 , 0.000000000000000D+00 , & 0.000000000000000D+00 , 0.000000000000000D+00 , 0.000000000000000D+00 , 0.000000000000000D+00 , 0.000000000000000D+00 , & 0.000000000000000D+00 , 0.000000000000000D+00 , 0.000000000000000D+00 , - 9.180000000000000D-01 , 0.000000000000000D+00 , & 0.000000000000000D+00 , 0.000000000000000D+00 , 0.000000000000000D+00 , 0.000000000000000D+00 , 0.000000000000000D+00 , & 0.000000000000000D+00 , 0.000000000000000D+00 , 0.000000000000000D+00 , 0.000000000000000D+00 , 0.000000000000000D+00 , & 0.000000000000000D+00 , 0.000000000000000D+00 , 0.000000000000000D+00 , 0.000000000000000D+00 , 0.000000000000000D+00 , & 0.000000000000000D+00 , - 2.480000000000000D+00 , - 1.960000000000000D-01 , 0.000000000000000D+00 , 0.000000000000000D+00 , & 0.000000000000000D+00 , 0.000000000000000D+00 , 0.000000000000000D+00 , 0.000000000000000D+00 , 0.000000000000000D+00 , & 0.000000000000000D+00 , 0.000000000000000D+00 , 0.000000000000000D+00 , 0.000000000000000D+00 , 0.000000000000000D+00 , & 0.000000000000000D+00 , 0.000000000000000D+00 , 0.000000000000000D+00 , 0.000000000000000D+00 , - 4.730000000000000D+00 , & - 3.090000000000000D-01 , 0.000000000000000D+00 , 0.000000000000000D+00 , 0.000000000000000D+00 , 0.000000000000000D+00 , & 0.000000000000000D+00 , 0.000000000000000D+00 , 0.000000000000000D+00 , 0.000000000000000D+00 , 0.000000000000000D+00 , & 0.000000000000000D+00 , 0.000000000000000D+00 , 0.000000000000000D+00 , 0.000000000000000D+00 , 0.000000000000000D+00 , & 0.000000000000000D+00 , 0.000000000000000D+00 , - 7.700000000000000D+00 , - 4.950000000000000D-01 , - 3.100000000000000D-01 , & 0.000000000000000D+00 , 0.000000000000000D+00 , 0.000000000000000D+00 , 0.000000000000000D+00 , 0.000000000000000D+00 , & 0.000000000000000D+00 , 0.000000000000000D+00 , 0.000000000000000D+00 , 0.000000000000000D+00 , 0.000000000000000D+00 , & 0.000000000000000D+00 , 0.000000000000000D+00 , 0.000000000000000D+00 , 0.000000000000000D+00 , 0.000000000000000D+00 , & - 1.130000000000000D+01 , - 7.060000000000000D-01 , - 4.330000000000000D-01 , 0.000000000000000D+00 , 0.000000000000000D+00 , & 0.000000000000000D+00 , 0.000000000000000D+00 , 0.000000000000000D+00 , 0.000000000000000D+00 , 0.000000000000000D+00 , & 0.000000000000000D+00 , 0.000000000000000D+00 , 0.000000000000000D+00 , 0.000000000000000D+00 , 0.000000000000000D+00 , & 0.000000000000000D+00 , 0.000000000000000D+00 , 0.000000000000000D+00 , - 1.560000000000000D+01 , - 9.450000000000000D-01 , & - 5.679999999999999D-01 , 0.000000000000000D+00 , 0.000000000000000D+00 , 0.000000000000000D+00 , 0.000000000000000D+00 , & 0.000000000000000D+00 , 0.000000000000000D+00 , 0.000000000000000D+00 , 0.000000000000000D+00 , 0.000000000000000D+00 , & 0.000000000000000D+00 , 0.000000000000000D+00 , 0.000000000000000D+00 , 0.000000000000000D+00 , 0.000000000000000D+00 , & 0.000000000000000D+00 , - 2.070000000000000D+01 , - 1.244000000000000D+00 , - 6.320000000000000D-01 , 0.000000000000000D+00 , & 0.000000000000000D+00 , 0.000000000000000D+00 , 0.000000000000000D+00 , 0.000000000000000D+00 , 0.000000000000000D+00 , & 0.000000000000000D+00 , 0.000000000000000D+00 , 0.000000000000000D+00 , 0.000000000000000D+00 , 0.000000000000000D+00 , & 0.000000000000000D+00 , 0.000000000000000D+00 , 0.000000000000000D+00 , 0.000000000000000D+00 , - 2.640000000000000D+01 , & - 1.573000000000000D+00 , - 7.300000000000000D-01 , 0.000000000000000D+00 , 0.000000000000000D+00 , 0.000000000000000D+00 , & 0.000000000000000D+00 , 0.000000000000000D+00 , 0.000000000000000D+00 , 0.000000000000000D+00 , 0.000000000000000D+00 , & 0.000000000000000D+00 , 0.000000000000000D+00 , 0.000000000000000D+00 , 0.000000000000000D+00 , 0.000000000000000D+00 , & 0.000000000000000D+00 , 0.000000000000000D+00 , - 3.280000000000000D+01 , - 1.930000000000000D+00 , - 8.500000000000000D-01 , & 0.000000000000000D+00 , 0.000000000000000D+00 , 0.000000000000000D+00 , 0.000000000000000D+00 , 0.000000000000000D+00 , & 0.000000000000000D+00 , 0.000000000000000D+00 , 0.000000000000000D+00 , 0.000000000000000D+00 , 0.000000000000000D+00 , & 0.000000000000000D+00 , 0.000000000000000D+00 , 0.000000000000000D+00 , 0.000000000000000D+00 , 0.000000000000000D+00 , & - 4.050000000000000D+01 , - 2.800000000000000D+00 , - 1.520000000000000D+00 , - 1.820000000000000D-01 , 0.000000000000000D+00 , & 0.000000000000000D+00 , 0.000000000000000D+00 , 0.000000000000000D+00 , 0.000000000000000D+00 , 0.000000000000000D+00 , & 0.000000000000000D+00 , 0.000000000000000D+00 , 0.000000000000000D+00 , 0.000000000000000D+00 , 0.000000000000000D+00 , & 0.000000000000000D+00 , 0.000000000000000D+00 , 0.000000000000000D+00 , - 4.900000000000000D+01 , - 3.770000000000000D+00 , & - 2.280000000000000D+00 , - 2.530000000000000D-01 , 0.000000000000000D+00 , 0.000000000000000D+00 , 0.000000000000000D+00 , & 0.000000000000000D+00 , 0.000000000000000D+00 , 0.000000000000000D+00 , 0.000000000000000D+00 , 0.000000000000000D+00 , & 0.000000000000000D+00 , 0.000000000000000D+00 , 0.000000000000000D+00 , 0.000000000000000D+00 , 0.000000000000000D+00 , & 0.000000000000000D+00 , - 5.850000000000000D+01 , - 4.910000000000000D+00 , - 3.220000000000000D+00 , - 3.930000000000000D-01 , & - 2.100000000000000D-01 , 0.000000000000000D+00 , 0.000000000000000D+00 , 0.000000000000000D+00 , 0.000000000000000D+00 , & 0.000000000000000D+00 , 0.000000000000000D+00 , 0.000000000000000D+00 , 0.000000000000000D+00 , 0.000000000000000D+00 , & 0.000000000000000D+00 , 0.000000000000000D+00 , 0.000000000000000D+00 , 0.000000000000000D+00 , - 6.880000000000000D+01 , & - 6.160000000000000D+00 , - 4.260000000000000D+00 , - 5.400000000000000D-01 , - 2.970000000000000D-01 , 0.000000000000000D+00 , & 0.000000000000000D+00 , 0.000000000000000D+00 , 0.000000000000000D+00 , 0.000000000000000D+00 , 0.000000000000000D+00 , & 0.000000000000000D+00 , 0.000000000000000D+00 , 0.000000000000000D+00 , 0.000000000000000D+00 , 0.000000000000000D+00 , & 0.000000000000000D+00 , 0.000000000000000D+00 , - 8.000000000000000D+01 , - 7.510000000000000D+00 , - 5.400000000000000D+00 , & - 6.960000000000000D-01 , - 3.920000000000000D-01 , 0.000000000000000D+00 , 0.000000000000000D+00 , 0.000000000000000D+00 , & 0.000000000000000D+00 , 0.000000000000000D+00 , 0.000000000000000D+00 , 0.000000000000000D+00 , 0.000000000000000D+00 , & 0.000000000000000D+00 , 0.000000000000000D+00 , 0.000000000000000D+00 , 0.000000000000000D+00 , 0.000000000000000D+00 , & - 9.200000000000000D+01 , - 9.000000000000000D+00 , - 6.680000000000000D+00 , - 8.800000000000000D-01 , - 4.370000000000000D-01 , & 0.000000000000000D+00 , 0.000000000000000D+00 , 0.000000000000000D+00 , 0.000000000000000D+00 , 0.000000000000000D+00 , & 0.000000000000000D+00 , 0.000000000000000D+00 , 0.000000000000000D+00 , 0.000000000000000D+00 , 0.000000000000000D+00 , & 0.000000000000000D+00 , 0.000000000000000D+00 , 0.000000000000000D+00 , - 1.040000000000000D+02 , - 1.060000000000000D+01 , & - 8.070000000000000D+00 , - 1.073000000000000D+00 , - 5.060000000000000D-01 , 0.000000000000000D+00 , 0.000000000000000D+00 , & 0.000000000000000D+00 , 0.000000000000000D+00 , 0.000000000000000D+00 , 0.000000000000000D+00 , 0.000000000000000D+00 , & 0.000000000000000D+00 , 0.000000000000000D+00 , 0.000000000000000D+00 , 0.000000000000000D+00 , 0.000000000000000D+00 , & 0.000000000000000D+00 , - 1.186000000000000D+02 , - 1.230000000000000D+01 , - 9.570000000000000D+00 , - 1.278000000000000D+00 , & - 5.910000000000000D-01 , 0.000000000000000D+00 , 0.000000000000000D+00 , 0.000000000000000D+00 , 0.000000000000000D+00 , & 0.000000000000000D+00 , 0.000000000000000D+00 , 0.000000000000000D+00 , 0.000000000000000D+00 , 0.000000000000000D+00 , & 0.000000000000000D+00 , 0.000000000000000D+00 , 0.000000000000000D+00 , 0.000000000000000D+00 , - 1.335000000000000D+02 , & - 1.450000000000000D+01 , - 1.150000000000000D+01 , - 1.750000000000000D+00 , - 9.500000000000000D-01 , - 1.470000000000000D-01 , & 0.000000000000000D+00 , 0.000000000000000D+00 , 0.000000000000000D+00 , 0.000000000000000D+00 , 0.000000000000000D+00 , & 0.000000000000000D+00 , 0.000000000000000D+00 , 0.000000000000000D+00 , 0.000000000000000D+00 , 0.000000000000000D+00 , & 0.000000000000000D+00 , 0.000000000000000D+00 , - 1.494000000000000D+02 , - 1.680000000000000D+01 , - 1.360000000000000D+01 , & - 2.240000000000000D+00 , - 1.340000000000000D+00 , - 1.960000000000000D-01 , 0.000000000000000D+00 , 0.000000000000000D+00 , & 0.000000000000000D+00 , 0.000000000000000D+00 , 0.000000000000000D+00 , 0.000000000000000D+00 , 0.000000000000000D+00 , & 0.000000000000000D+00 , 0.000000000000000D+00 , 0.000000000000000D+00 , 0.000000000000000D+00 , 0.000000000000000D+00 , & - 1.659000000000000D+02 , - 1.908000000000000D+01 , - 1.567000000000000D+01 , - 2.570000000000000D+00 , - 1.575000000000000D+00 , & - 3.430000000000000D-01 , - 2.100000000000000D-01 , 0.000000000000000D+00 , 0.000000000000000D+00 , 0.000000000000000D+00 , & 0.000000000000000D+00 , 0.000000000000000D+00 , 0.000000000000000D+00 , 0.000000000000000D+00 , 0.000000000000000D+00 , & 0.000000000000000D+00 , 0.000000000000000D+00 , 0.000000000000000D+00 , - 1.833000000000000D+02 , - 2.142000000000000D+01 , & - 1.779000000000000D+01 , - 2.874000000000000D+00 , - 1.795000000000000D+00 , - 4.410000000000000D-01 , - 2.200000000000000D-01 , & 0.000000000000000D+00 , 0.000000000000000D+00 , 0.000000000000000D+00 , 0.000000000000000D+00 , 0.000000000000000D+00 , & 0.000000000000000D+00 , 0.000000000000000D+00 , 0.000000000000000D+00 , 0.000000000000000D+00 , 0.000000000000000D+00 , & 0.000000000000000D+00 , - 2.013000000000000D+02 , - 2.370000000000000D+01 , - 1.980000000000000D+01 , - 2.990000000000000D+00 , & - 1.840000000000000D+00 , - 3.210000000000000D-01 , - 2.140000000000000D-01 , 0.000000000000000D+00 , 0.000000000000000D+00 , & 0.000000000000000D+00 , 0.000000000000000D+00 , 0.000000000000000D+00 , 0.000000000000000D+00 , 0.000000000000000D+00 , & 0.000000000000000D+00 , 0.000000000000000D+00 , 0.000000000000000D+00 , 0.000000000000000D+00 , - 2.204000000000000D+02 , & - 2.620000000000000D+01 , - 2.210000000000000D+01 , - 3.290000000000000D+00 , - 2.050000000000000D+00 , - 3.730000000000000D-01 , & - 2.220000000000000D-01 , 0.000000000000000D+00 , 0.000000000000000D+00 , 0.000000000000000D+00 , 0.000000000000000D+00 , & 0.000000000000000D+00 , 0.000000000000000D+00 , 0.000000000000000D+00 , 0.000000000000000D+00 , 0.000000000000000D+00 , & 0.000000000000000D+00 , 0.000000000000000D+00 , - 2.404000000000000D+02 , - 2.890000000000000D+01 , - 2.460000000000000D+01 , & - 3.620000000000000D+00 , - 2.300000000000000D+00 , - 3.830000000000000D-01 , - 2.270000000000000D-01 , 0.000000000000000D+00 , & 0.000000000000000D+00 , 0.000000000000000D+00 , 0.000000000000000D+00 , 0.000000000000000D+00 , 0.000000000000000D+00 , & 0.000000000000000D+00 , 0.000000000000000D+00 , 0.000000000000000D+00 , 0.000000000000000D+00 , 0.000000000000000D+00 , & - 2.612000000000000D+02 , - 3.170000000000000D+01 , - 2.720000000000000D+01 , - 3.960000000000000D+00 , - 2.550000000000000D+00 , & - 4.060000000000000D-01 , - 2.300000000000000D-01 , 0.000000000000000D+00 , 0.000000000000000D+00 , 0.000000000000000D+00 , & 0.000000000000000D+00 , 0.000000000000000D+00 , 0.000000000000000D+00 , 0.000000000000000D+00 , 0.000000000000000D+00 , & 0.000000000000000D+00 , 0.000000000000000D+00 , 0.000000000000000D+00 , - 2.829000000000000D+02 , - 3.460000000000000D+01 , & - 2.990000000000000D+01 , - 4.300000000000000D+00 , - 2.800000000000000D+00 , - 4.340000000000000D-01 , - 2.330000000000000D-01 , & 0.000000000000000D+00 , 0.000000000000000D+00 , 0.000000000000000D+00 , 0.000000000000000D+00 , 0.000000000000000D+00 , & 0.000000000000000D+00 , 0.000000000000000D+00 , 0.000000000000000D+00 , 0.000000000000000D+00 , 0.000000000000000D+00 , & 0.000000000000000D+00 , - 3.054000000000000D+02 , - 3.770000000000000D+01 , - 3.270000000000000D+01 , - 4.650000000000000D+00 , & - 3.060000000000000D+00 , - 4.570000000000000D-01 , - 2.360000000000000D-01 , 0.000000000000000D+00 , 0.000000000000000D+00 , & 0.000000000000000D+00 , 0.000000000000000D+00 , 0.000000000000000D+00 , 0.000000000000000D+00 , 0.000000000000000D+00 , & 0.000000000000000D+00 , 0.000000000000000D+00 , 0.000000000000000D+00 , 0.000000000000000D+00 , - 3.288000000000000D+02 , & - 4.080000000000000D+01 , - 3.560000000000000D+01 , - 5.010000000000000D+00 , - 3.320000000000000D+00 , - 4.910000000000000D-01 , & - 2.380000000000000D-01 , 0.000000000000000D+00 , 0.000000000000000D+00 , 0.000000000000000D+00 , 0.000000000000000D+00 , & 0.000000000000000D+00 , 0.000000000000000D+00 , 0.000000000000000D+00 , 0.000000000000000D+00 , 0.000000000000000D+00 , & 0.000000000000000D+00 , 0.000000000000000D+00 , - 3.533000000000000D+02 , - 4.440000000000000D+01 , - 3.890000000000000D+01 , & - 5.630000000000000D+00 , - 3.840000000000000D+00 , - 7.830000000000000D-01 , - 2.930000000000000D-01 , 0.000000000000000D+00 , & 0.000000000000000D+00 , 0.000000000000000D+00 , 0.000000000000000D+00 , 0.000000000000000D+00 , 0.000000000000000D+00 , & 0.000000000000000D+00 , 0.000000000000000D+00 , 0.000000000000000D+00 , 0.000000000000000D+00 , 0.000000000000000D+00 , & - 3.788000000000000D+02 , - 4.820000000000000D+01 , - 4.250000000000000D+01 , - 6.400000000000000D+00 , - 4.480000000000000D+00 , & - 1.193000000000000D+00 , - 4.240000000000000D-01 , - 2.080000000000000D-01 , 0.000000000000000D+00 , 0.000000000000000D+00 , & 0.000000000000000D+00 , 0.000000000000000D+00 , 0.000000000000000D+00 , 0.000000000000000D+00 , 0.000000000000000D+00 , & 0.000000000000000D+00 , 0.000000000000000D+00 , 0.000000000000000D+00 , - 4.052000000000000D+02 , - 5.210000000000000D+01 , & - 4.620000000000000D+01 , - 7.190000000000000D+00 , - 5.170000000000000D+00 , - 1.635000000000000D+00 , - 5.530000000000000D-01 , & - 2.870000000000000D-01 , 0.000000000000000D+00 , 0.000000000000000D+00 , 0.000000000000000D+00 , 0.000000000000000D+00 , & 0.000000000000000D+00 , 0.000000000000000D+00 , 0.000000000000000D+00 , 0.000000000000000D+00 , 0.000000000000000D+00 , & 0.000000000000000D+00 , - 4.326000000000000D+02 , - 5.630000000000000D+01 , - 5.020000000000000D+01 , - 8.029999999999999D+00 , & - 5.880000000000000D+00 , - 2.113000000000000D+00 , - 6.860000000000001D-01 , - 3.690000000000000D-01 , 0.000000000000000D+00 , & 0.000000000000000D+00 , 0.000000000000000D+00 , 0.000000000000000D+00 , 0.000000000000000D+00 , 0.000000000000000D+00 , & 0.000000000000000D+00 , 0.000000000000000D+00 , 0.000000000000000D+00 , 0.000000000000000D+00 , - 4.609000000000000D+02 , & - 6.070000000000000D+01 , - 5.430000000000000D+01 , - 8.930000000000000D+00 , - 6.660000000000000D+00 , - 2.650000000000000D+00 , & - 8.380000000000000D-01 , - 4.030000000000000D-01 , 0.000000000000000D+00 , 0.000000000000000D+00 , 0.000000000000000D+00 , & 0.000000000000000D+00 , 0.000000000000000D+00 , 0.000000000000000D+00 , 0.000000000000000D+00 , 0.000000000000000D+00 , & 0.000000000000000D+00 , 0.000000000000000D+00 , - 4.901000000000000D+02 , - 6.520000000000000D+01 , - 5.860000000000000D+01 , & - 9.869999999999999D+00 , - 7.480000000000000D+00 , - 3.220000000000000D+00 , - 9.930000000000000D-01 , - 4.570000000000000D-01 , & 0.000000000000000D+00 , 0.000000000000000D+00 , 0.000000000000000D+00 , 0.000000000000000D+00 , 0.000000000000000D+00 , & 0.000000000000000D+00 , 0.000000000000000D+00 , 0.000000000000000D+00 , 0.000000000000000D+00 , 0.000000000000000D+00 , & - 5.202000000000000D+02 , - 6.990000000000001D+01 , - 6.300000000000000D+01 , - 1.080000000000000D+01 , - 8.330000000000000D+00 , & - 3.825000000000000D+00 , - 1.153000000000000D+00 , - 5.240000000000000D-01 , 0.000000000000000D+00 , 0.000000000000000D+00 , & 0.000000000000000D+00 , 0.000000000000000D+00 , 0.000000000000000D+00 , 0.000000000000000D+00 , 0.000000000000000D+00 , & 0.000000000000000D+00 , 0.000000000000000D+00 , 0.000000000000000D+00 , - 5.510000000000000D+02 , - 7.500000000000000D+01 , & - 6.790000000000001D+01 , - 1.210000000000000D+01 , - 9.500000000000000D+00 , - 4.700000000000000D+00 , - 1.520000000000000D+00 , & - 8.100000000000001D-01 , - 1.380000000000000D-01 , 0.000000000000000D+00 , 0.000000000000000D+00 , 0.000000000000000D+00 , & 0.000000000000000D+00 , 0.000000000000000D+00 , 0.000000000000000D+00 , 0.000000000000000D+00 , 0.000000000000000D+00 , & 0.000000000000000D+00 , - 5.837000000000000D+02 , - 8.040000000000001D+01 , - 7.300000000000000D+01 , - 1.350000000000000D+01 , & - 1.070000000000000D+01 , - 5.700000000000000D+00 , - 1.900000000000000D+00 , - 1.100000000000000D+00 , - 1.780000000000000D-01 , & 0.000000000000000D+00 , 0.000000000000000D+00 , 0.000000000000000D+00 , 0.000000000000000D+00 , 0.000000000000000D+00 , & 0.000000000000000D+00 , 0.000000000000000D+00 , 0.000000000000000D+00 , 0.000000000000000D+00 , - 6.168000000000000D+02 , & - 8.581000000000000D+01 , - 7.816000000000000D+01 , - 1.476000000000000D+01 , - 1.185000000000000D+01 , - 6.599000000000000D+00 , & - 2.168000000000000D+00 , - 1.300000000000000D+00 , - 2.499000000000000D-01 , - 1.958000000000000D-01 , 0.000000000000000D+00 , & 0.000000000000000D+00 , 0.000000000000000D+00 , 0.000000000000000D+00 , 0.000000000000000D+00 , 0.000000000000000D+00 , & 0.000000000000000D+00 , 0.000000000000000D+00 , - 6.507000000000000D+02 , - 9.138000000000000D+01 , - 8.348000000000000D+01 , & - 1.606000000000000D+01 , - 1.302000000000000D+01 , - 7.515000000000000D+00 , - 2.418000000000000D+00 , - 1.487000000000000D+00 , & - 3.365000000000000D-01 , - 2.070000000000000D-01 , 0.000000000000000D+00 , 0.000000000000000D+00 , 0.000000000000000D+00 , & 0.000000000000000D+00 , 0.000000000000000D+00 , 0.000000000000000D+00 , 0.000000000000000D+00 , 0.000000000000000D+00 , & - 6.854000000000000D+02 , - 9.700000000000000D+01 , - 8.880000000000000D+01 , - 1.720000000000000D+01 , - 1.400000000000000D+01 , & - 8.300000000000001D+00 , - 2.530000000000000D+00 , - 1.550000000000000D+00 , - 2.990000000000000D-01 , - 2.140000000000000D-01 , & 0.000000000000000D+00 , 0.000000000000000D+00 , 0.000000000000000D+00 , 0.000000000000000D+00 , 0.000000000000000D+00 , & 0.000000000000000D+00 , 0.000000000000000D+00 , 0.000000000000000D+00 , - 7.212000000000000D+02 , - 1.029000000000000D+02 , & - 9.450000000000000D+01 , - 1.860000000000000D+01 , - 1.530000000000000D+01 , - 9.300000000000001D+00 , - 2.760000000000000D+00 , & - 1.720000000000000D+00 , - 3.570000000000000D-01 , - 2.220000000000000D-01 , 0.000000000000000D+00 , 0.000000000000000D+00 , & 0.000000000000000D+00 , 0.000000000000000D+00 , 0.000000000000000D+00 , 0.000000000000000D+00 , 0.000000000000000D+00 , & 0.000000000000000D+00 , - 7.579000000000000D+02 , - 1.089000000000000D+02 , - 1.002000000000000D+02 , - 2.000000000000000D+01 , & - 1.660000000000000D+01 , - 1.030000000000000D+01 , - 3.000000000000000D+00 , - 1.910000000000000D+00 , - 3.770000000000000D-01 , & - 2.220000000000000D-01 , 0.000000000000000D+00 , 0.000000000000000D+00 , 0.000000000000000D+00 , 0.000000000000000D+00 , & 0.000000000000000D+00 , 0.000000000000000D+00 , 0.000000000000000D+00 , 0.000000000000000D+00 , - 7.955000000000000D+02 , & - 1.152000000000000D+02 , - 1.062000000000000D+02 , - 2.140000000000000D+01 , - 1.780000000000000D+01 , - 1.130000000000000D+01 , & - 3.260000000000000D+00 , - 2.100000000000000D+00 , - 4.120000000000000D-01 , - 2.220000000000000D-01 , 0.000000000000000D+00 , & 0.000000000000000D+00 , 0.000000000000000D+00 , 0.000000000000000D+00 , 0.000000000000000D+00 , 0.000000000000000D+00 , & 0.000000000000000D+00 , 0.000000000000000D+00 , - 8.340000000000000D+02 , - 1.216000000000000D+02 , - 1.124000000000000D+02 , & - 2.290000000000000D+01 , - 1.920000000000000D+01 , - 1.240000000000000D+01 , - 3.500000000000000D+00 , - 2.290000000000000D+00 , & - 4.510000000000000D-01 , - 2.200000000000000D-01 , 0.000000000000000D+00 , 0.000000000000000D+00 , 0.000000000000000D+00 , & 0.000000000000000D+00 , 0.000000000000000D+00 , 0.000000000000000D+00 , 0.000000000000000D+00 , 0.000000000000000D+00 , & - 8.735000000000000D+02 , - 1.281000000000000D+02 , - 1.187000000000000D+02 , - 2.440000000000000D+01 , - 2.050000000000000D+01 , & - 1.350000000000000D+01 , - 3.750000000000000D+00 , - 2.480000000000000D+00 , - 4.880000000000000D-01 , - 2.200000000000000D-01 , & 0.000000000000000D+00 , 0.000000000000000D+00 , 0.000000000000000D+00 , 0.000000000000000D+00 , 0.000000000000000D+00 , & 0.000000000000000D+00 , 0.000000000000000D+00 , 0.000000000000000D+00 , - 9.138000000000000D+02 , - 1.349000000000000D+02 , & - 1.252000000000000D+02 , - 2.590000000000000D+01 , - 2.190000000000000D+01 , - 1.470000000000000D+01 , - 4.000000000000000D+00 , & - 2.680000000000000D+00 , - 5.370000000000000D-01 , - 2.200000000000000D-01 , 0.000000000000000D+00 , 0.000000000000000D+00 , & 0.000000000000000D+00 , 0.000000000000000D+00 , 0.000000000000000D+00 , 0.000000000000000D+00 , 0.000000000000000D+00 , & 0.000000000000000D+00 , - 9.554000000000000D+02 , - 1.421000000000000D+02 , - 1.321000000000000D+02 , - 2.770000000000000D+01 , & - 2.360000000000000D+01 , - 1.610000000000000D+01 , - 4.450000000000000D+00 , - 3.050000000000000D+00 , - 7.630000000000000D-01 , & - 2.650000000000000D-01 , 0.000000000000000D+00 , 0.000000000000000D+00 , 0.000000000000000D+00 , 0.000000000000000D+00 , & 0.000000000000000D+00 , 0.000000000000000D+00 , 0.000000000000000D+00 , 0.000000000000000D+00 , - 9.978000000000000D+02 , & - 1.494000000000000D+02 , - 1.392000000000000D+02 , - 2.960000000000000D+01 , - 2.540000000000000D+01 , - 1.760000000000000D+01 , & - 4.980000000000000D+00 , - 3.510000000000000D+00 , - 1.063000000000000D+00 , - 3.720000000000000D-01 , - 1.970000000000000D-01 , & 0.000000000000000D+00 , 0.000000000000000D+00 , 0.000000000000000D+00 , 0.000000000000000D+00 , 0.000000000000000D+00 , & 0.000000000000000D+00 , 0.000000000000000D+00 , - 1.041200000000000D+03 , - 1.570000000000000D+02 , - 1.465000000000000D+02 , & - 3.160000000000000D+01 , - 2.720000000000000D+01 , - 1.920000000000000D+01 , - 5.510000000000000D+00 , - 3.970000000000000D+00 , & - 1.369000000000000D+00 , - 4.760000000000000D-01 , - 2.650000000000000D-01 , 0.000000000000000D+00 , 0.000000000000000D+00 , & 0.000000000000000D+00 , 0.000000000000000D+00 , 0.000000000000000D+00 , 0.000000000000000D+00 , 0.000000000000000D+00 , & - 1.085600000000000D+03 , - 1.648000000000000D+02 , - 1.540000000000000D+02 , - 3.360000000000000D+01 , - 1.920000000000000D+01 , & - 2.080000000000000D+01 , - 6.060000000000000D+00 , - 4.450000000000000D+00 , - 1.688000000000000D+00 , - 5.820000000000000D-01 , & - 3.350000000000000D-01 , 0.000000000000000D+00 , 0.000000000000000D+00 , 0.000000000000000D+00 , 0.000000000000000D+00 , & 0.000000000000000D+00 , 0.000000000000000D+00 , 0.000000000000000D+00 , - 1.130900000000000D+03 , - 1.728000000000000D+02 , & - 1.617000000000000D+02 , - 3.580000000000000D+01 , - 3.110000000000000D+01 , - 2.250000000000000D+01 , - 6.650000000000000D+00 , & - 4.950000000000000D+00 , - 2.038000000000000D+00 , - 7.010000000000000D-01 , - 3.600000000000000D-01 , 0.000000000000000D+00 , & 0.000000000000000D+00 , 0.000000000000000D+00 , 0.000000000000000D+00 , 0.000000000000000D+00 , 0.000000000000000D+00 , & 0.000000000000000D+00 , - 1.177200000000000D+03 , - 1.809000000000000D+02 , - 1.697000000000000D+02 , - 3.790000000000000D+01 , & - 3.310000000000000D+01 , - 2.430000000000000D+01 , - 7.240000000000000D+00 , - 5.470000000000000D+00 , - 2.401000000000000D+00 , & - 8.210000000000000D-01 , - 4.030000000000000D-01 , 0.000000000000000D+00 , 0.000000000000000D+00 , 0.000000000000000D+00 , & 0.000000000000000D+00 , 0.000000000000000D+00 , 0.000000000000000D+00 , 0.000000000000000D+00 , - 1.224400000000000D+03 , & - 1.893000000000000D+02 , - 1.778000000000000D+02 , - 4.020000000000000D+01 , - 3.520000000000000D+01 , - 2.610000000000000D+01 , & - 7.860000000000000D+00 , - 6.010000000000000D+00 , - 2.778000000000000D+00 , - 9.440000000000000D-01 , - 4.570000000000000D-01 , & 0.000000000000000D+00 , 0.000000000000000D+00 , 0.000000000000000D+00 , 0.000000000000000D+00 , 0.000000000000000D+00 , & 0.000000000000000D+00 , 0.000000000000000D+00 , - 1.272750000000000D+03 , - 1.981500000000000D+02 , - 1.863000000000000D+02 , & - 4.269500000000000D+01 , - 3.759500000000000D+01 , - 2.822500000000000D+01 , - 8.695000000000000D+00 , - 6.770000000000000D+00 , & - 3.379500000000000D+00 , - 1.231500000000000D+00 , - 6.835000000000000D-01 , - 1.236500000000000D-01 , 0.000000000000000D+00 , & 0.000000000000000D+00 , 0.000000000000000D+00 , 0.000000000000000D+00 , 0.000000000000000D+00 , 0.000000000000000D+00 , & - 1.322100000000000D+03 , - 2.071500000000000D+02 , - 1.950500000000000D+02 , - 4.528000000000000D+01 , - 4.004000000000000D+01 , & - 3.040000000000000D+01 , - 9.555000000000000D+00 , - 7.550000000000000D+00 , - 4.001500000000000D+00 , - 1.512500000000000D+00 , & - 9.040000000000000D-01 , - 1.575000000000000D-01 , 0.000000000000000D+00 , 0.000000000000000D+00 , 0.000000000000000D+00 , & 0.000000000000000D+00 , 0.000000000000000D+00 , 0.000000000000000D+00 , - 1.372250000000000D+03 , - 2.163000000000000D+02 , & - 2.039000000000000D+02 , - 4.784500000000000D+01 , - 4.246000000000000D+01 , - 3.255500000000000D+01 , - 1.034500000000000D+01 , & - 8.260000000000000D+00 , - 4.553500000000000D+00 , - 1.704500000000000D+00 , - 1.049500000000000D+00 , - 3.590000000000000D-01 , & - 1.704000000000000D-01 , 0.000000000000000D+00 , 0.000000000000000D+00 , 0.000000000000000D+00 , 0.000000000000000D+00 , & 0.000000000000000D+00 , - 1.423100000000000D+03 , - 2.252500000000000D+02 , - 2.126000000000000D+02 , - 5.010000000000000D+01 , & - 4.455000000000000D+01 , - 3.438500000000000D+01 , - 1.081000000000000D+01 , - 8.654999999999999D+00 , - 4.818000000000000D+00 , & - 1.754000000000000D+00 , - 1.078000000000000D+00 , - 4.465000000000000D-01 , - 1.726250000000000D-01 , 0.000000000000000D+00 , & 0.000000000000000D+00 , 0.000000000000000D+00 , 0.000000000000000D+00 , 0.000000000000000D+00 , - 1.474550000000000D+03 , & - 2.341000000000000D+02 , - 2.212070500000000D+02 , - 5.200200000000000D+01 , - 4.633572500000000D+01 , - 3.591500000000000D+01 , & - 1.096500000000000D+01 , - 8.745835000000000D+00 , - 4.802136000000000D+00 , - 1.661810000000000D+00 , - 9.879720000000000D-01 , & - 4.755201500000000D-01 , - 1.641239500000000D-01 , 0.000000000000000D+00 , 0.000000000000000D+00 , 0.000000000000000D+00 , & 0.000000000000000D+00 , 0.000000000000000D+00 , - 1.527250000000000D+03 , - 2.434000000000000D+02 , - 2.302542500000000D+02 , & - 5.429510000000000D+01 , - 4.848643500000000D+01 , - 3.780400000000000D+01 , - 1.142100000000000D+01 , - 9.132999999999999D+00 , & - 5.058340000000000D+00 , - 1.705431500000000D+00 , - 1.011275500000000D+00 , - 5.138505000000000D-01 , - 1.660304500000000D-01 , & 0.000000000000000D+00 , 0.000000000000000D+00 , 0.000000000000000D+00 , 0.000000000000000D+00 , 0.000000000000000D+00 , & - 1.580800000000000D+03 , - 2.529000000000000D+02 , - 2.394713000000000D+02 , - 5.662060000000000D+01 , - 5.066910000000000D+01 , & - 3.972450000000000D+01 , - 1.187750000000000D+01 , - 9.519180000000000D+00 , - 5.313255000000000D+00 , - 1.747580000000000D+00 , & - 1.033350000000000D+00 , - 5.476000000000000D-01 , - 1.678628000000000D-01 , 0.000000000000000D+00 , 0.000000000000000D+00 , & 0.000000000000000D+00 , 0.000000000000000D+00 , 0.000000000000000D+00 , - 1.635300000000000D+03 , - 2.625500000000000D+02 , & - 2.488593500000000D+02 , - 5.898010000000000D+01 , - 5.288540000000000D+01 , - 4.167750000000000D+01 , - 1.233450000000000D+01 , & - 9.905625000000001D+00 , - 5.568005000000000D+00 , - 1.788646000000000D+00 , - 1.054555500000000D+00 , - 5.776575000000000D-01 , & - 1.696350500000000D-01 , 0.000000000000000D+00 , 0.000000000000000D+00 , 0.000000000000000D+00 , 0.000000000000000D+00 , & 0.000000000000000D+00 , - 1.690700000000000D+03 , - 2.723500000000000D+02 , - 2.584193500000000D+02 , - 6.137500000000000D+01 , & - 5.513660000000000D+01 , - 4.366450000000000D+01 , - 1.279350000000000D+01 , - 1.029300000000000D+01 , - 5.823335000000000D+00 , & - 1.828887500000000D+00 , - 1.075004000000000D+00 , - 6.045905000000000D-01 , - 1.713578000000000D-01 , 0.000000000000000D+00 , & 0.000000000000000D+00 , 0.000000000000000D+00 , 0.000000000000000D+00 , 0.000000000000000D+00 , - 1.747350000000000D+03 , & - 2.826862500000000D+02 , - 2.684620000000000D+02 , - 6.415745000000000D+01 , - 5.777250000000000D+01 , - 4.602950000000000D+01 , & - 1.357550000000000D+01 , - 1.099750000000000D+01 , - 6.375000000000000D+00 , - 2.022571500000000D+00 , - 1.224444000000000D+00 , & - 6.085000000000000D-01 , - 1.849697500000000D-01 , 0.000000000000000D+00 , 0.000000000000000D+00 , 0.000000000000000D+00 , & 0.000000000000000D+00 , 0.000000000000000D+00 , - 1.804650000000000D+03 , - 2.928600000000000D+02 , - 2.783719500000000D+02 , & - 6.662920000000000D+01 , - 6.009960000000000D+01 , - 4.809100000000000D+01 , - 1.404400000000000D+01 , - 1.139370000000000D+01 , & - 9.499795000000000D-01 , - 2.065125000000000D+00 , - 1.246807500000000D+00 , - 6.005000000000000D-01 , - 1.869579000000000D-01 , & 0.000000000000000D+00 , 0.000000000000000D+00 , 0.000000000000000D+00 , 0.000000000000000D+00 , 0.000000000000000D+00 , & - 1.862550000000000D+03 , - 3.029000000000000D+02 , - 2.881374000000000D+02 , - 6.878025000000000D+01 , - 6.210790000000000D+01 , & - 4.983900000000000D+01 , - 1.418550000000000D+01 , - 1.146950000000000D+01 , - 6.597815000000000D+00 , - 1.946328000000000D+00 , & - 1.133159000000000D+00 , - 6.705360000000000D-01 , - 1.762885000000000D-01 , 0.000000000000000D+00 , 0.000000000000000D+00 , & 0.000000000000000D+00 , 0.000000000000000D+00 , 0.000000000000000D+00 , - 1.921650000000000D+03 , - 3.134050000000000D+02 , & - 2.983908000000000D+02 , - 7.132425000000001D+01 , - 6.450624999999999D+01 , - 5.197000000000000D+01 , - 1.465650000000000D+01 , & - 1.186800000000000D+01 , - 6.859910000000000D+00 , - 1.984751000000000D+00 , - 1.151750500000000D+00 , - 6.884455000000000D-01 , & - 1.778706500000000D-01 , 0.000000000000000D+00 , 0.000000000000000D+00 , 0.000000000000000D+00 , 0.000000000000000D+00 , & 0.000000000000000D+00 , - 1.981700000000000D+03 , - 3.241000000000000D+02 , - 3.088183000000000D+02 , - 7.390680000000000D+01 , & - 6.694260000000000D+01 , - 5.415000000000000D+01 , - 1.515000000000000D+01 , - 1.226928500000000D+01 , - 7.124415000000000D+00 , & - 2.022928000000000D+00 , - 1.170028000000000D+00 , - 7.046280000000000D-01 , - 1.794227000000000D-01 , 0.000000000000000D+00 , & 0.000000000000000D+00 , 0.000000000000000D+00 , 0.000000000000000D+00 , 0.000000000000000D+00 , - 2.042700000000000D+03 , & - 3.349500000000000D+02 , - 3.194204000000000D+02 , - 7.652825000000000D+01 , - 6.941770000000000D+01 , - 5.630000000000000D+01 , & - 1.561000000000000D+01 , - 1.267451000000000D+01 , - 7.391510000000000D+00 , - 2.060927500000000D+00 , - 1.188046500000000D+00 , & - 7.192360000000000D-01 , - 1.809536000000000D-01 , 0.000000000000000D+00 , 0.000000000000000D+00 , 0.000000000000000D+00 , & 0.000000000000000D+00 , 0.000000000000000D+00 , - 2.104600000000000D+03 , - 3.460000000000000D+02 , - 3.301970000000000D+02 , & - 7.918885000000000D+01 , - 7.193105000000000D+01 , - 5.860000000000000D+01 , - 1.609500000000000D+01 , - 1.308362000000000D+01 , & - 7.661330000000000D+00 , - 2.098794000000000D+00 , - 1.205830500000000D+00 , - 7.323815000000000D-01 , - 1.824623000000000D-01 , & 0.000000000000000D+00 , 0.000000000000000D+00 , 0.000000000000000D+00 , 0.000000000000000D+00 , 0.000000000000000D+00 , & - 2.167700000000000D+03 , - 3.575500000000000D+02 , - 3.414895000000000D+02 , - 8.226815000000001D+01 , - 7.486015000000000D+01 , & - 6.125000000000000D+01 , - 1.694000000000000D+01 , - 1.384492500000000D+01 , - 8.264805000000001D+00 , - 2.317000000000000D+00 , & - 1.376000000000000D+00 , - 1.077000000000000D+00 , - 2.433500000000000D-01 , - 1.988500000000000D-01 , 0.000000000000000D+00 , & 0.000000000000000D+00 , 0.000000000000000D+00 , 0.000000000000000D+00 , - 2.231800000000000D+03 , - 3.693500000000000D+02 , & - 3.530000000000000D+02 , - 8.540000000000001D+01 , - 7.784999999999999D+01 , - 6.395000000000000D+01 , - 1.780500000000000D+01 , & - 1.463000000000000D+01 , - 8.885000000000000D+00 , - 1.436000000000000D+00 , - 2.525000000000000D+00 , - 1.537000000000000D+00 , & - 2.991500000000000D-01 , - 2.104000000000000D-01 , 0.000000000000000D+00 , 0.000000000000000D+00 , 0.000000000000000D+00 , & 0.000000000000000D+00 , - 2.296850000000000D+03 , - 3.813000000000000D+02 , - 3.647000000000000D+02 , - 8.865000000000001D+01 , & - 8.095000000000000D+01 , - 6.675000000000000D+01 , - 1.869500000000000D+01 , - 1.543500000000000D+01 , - 9.529999999999999D+00 , & - 1.815000000000000D+00 , - 2.729500000000000D+00 , - 1.696500000000000D+00 , - 3.516500000000000D-01 , - 2.197500000000000D-01 , & 0.000000000000000D+00 , 0.000000000000000D+00 , 0.000000000000000D+00 , 0.000000000000000D+00 , - 2.362800000000000D+03 , & - 3.934500000000000D+02 , - 3.765500000000000D+02 , - 9.195000000000000D+01 , - 8.405000000000000D+01 , - 6.959999999999999D+01 , & - 1.961000000000000D+01 , - 1.626500000000000D+01 , - 1.019500000000000D+01 , - 2.214500000000000D+00 , - 2.934000000000000D+00 , & - 1.856500000000000D+00 , - 4.029000000000000D-01 , - 2.277000000000000D-01 , 0.000000000000000D+00 , 0.000000000000000D+00 , & 0.000000000000000D+00 , 0.000000000000000D+00 , - 2.429750000000000D+03 , - 4.058500000000000D+02 , - 3.886500000000000D+02 , & - 9.530000000000000D+01 , - 8.730000000000000D+01 , - 7.255000000000000D+01 , - 2.055000000000000D+01 , - 1.712000000000000D+01 , & - 1.088500000000000D+01 , - 2.633500000000000D+00 , - 3.138500000000000D+00 , - 2.017000000000000D+00 , - 4.538000000000000D-01 , & - 2.346500000000000D-01 , 0.000000000000000D+00 , 0.000000000000000D+00 , 0.000000000000000D+00 , 0.000000000000000D+00 , & - 2.497650000000000D+03 , - 4.184000000000000D+02 , - 4.009500000000000D+02 , - 9.870000000000000D+01 , - 9.055000000000000D+01 , & - 7.550000000000000D+01 , - 2.151500000000000D+01 , - 1.799500000000000D+01 , - 1.159000000000000D+01 , - 3.071500000000000D+00 , & - 3.344000000000000D+00 , - 2.179500000000000D+00 , - 5.048000000000000D-01 , - 2.409150000000000D-01 , 0.000000000000000D+00 , & 0.000000000000000D+00 , 0.000000000000000D+00 , 0.000000000000000D+00 , - 2.566450000000000D+03 , - 4.312000000000000D+02 , & - 4.134500000000000D+02 , - 1.022500000000000D+02 , - 9.390000000000001D+01 , - 7.859999999999999D+01 , - 2.249500000000000D+01 , & - 1.889000000000000D+01 , - 1.231500000000000D+01 , - 3.529000000000000D+00 , - 3.551000000000000D+00 , - 2.344000000000000D+00 , & - 5.562000000000000D-01 , - 2.465850000000000D-01 , 0.000000000000000D+00 , 0.000000000000000D+00 , 0.000000000000000D+00 , & 0.000000000000000D+00 , - 2.636050000000000D+03 , - 4.440000000000000D+02 , - 4.260000000000000D+02 , - 1.056500000000000D+02 , & - 9.715000000000001D+01 , - 8.155000000000000D+01 , - 2.334000000000000D+01 , - 1.964500000000000D+01 , - 1.290000000000000D+01 , & - 3.843500000000000D+00 , - 3.606500000000000D+00 , - 2.373500000000000D+00 , - 4.764500000000000D-01 , - 2.179500000000000D-01 , & 0.000000000000000D+00 , 0.000000000000000D+00 , 0.000000000000000D+00 , 0.000000000000000D+00 , - 2.706800000000000D+03 , & - 4.572000000000000D+02 , - 4.389000000000000D+02 , - 1.092500000000000D+02 , - 1.006000000000000D+02 , - 8.470000000000000D+01 , & - 2.435500000000000D+01 , - 2.057000000000000D+01 , - 1.365500000000000D+01 , - 4.328500000000000D+00 , - 3.809000000000000D+00 , & - 2.534500000000000D+00 , - 5.210000000000000D-01 , - 2.207750000000000D-01 , 0.000000000000000D+00 , 0.000000000000000D+00 , & 0.000000000000000D+00 , 0.000000000000000D+00 , - 2.778650000000000D+03 , - 4.707500000000000D+02 , - 4.522000000000000D+02 , & - 1.131500000000000D+02 , - 1.043500000000000D+02 , - 8.815000000000001D+01 , - 2.557500000000000D+01 , - 2.170000000000000D+01 , & - 1.461000000000000D+01 , - 5.010000000000000D+00 , - 4.182000000000000D+00 , - 2.851000000000000D+00 , - 7.141999999999999D-01 , & - 2.610450000000000D-01 , 0.000000000000000D+00 , 0.000000000000000D+00 , 0.000000000000000D+00 , 0.000000000000000D+00 , & - 2.851500000000000D+03 , - 4.845500000000000D+02 , - 4.657500000000000D+02 , - 1.171500000000000D+02 , - 1.082000000000000D+02 , & - 9.170000000000000D+01 , - 2.688500000000000D+01 , - 2.292000000000000D+01 , - 1.565500000000000D+01 , - 5.785000000000000D+00 , & - 4.618500000000000D+00 , - 3.231500000000000D+00 , - 9.685000000000000D-01 , - 3.611000000000000D-01 , - 1.924000000000000D-01 , & 0.000000000000000D+00 , 0.000000000000000D+00 , 0.000000000000000D+00 , - 2.925350000000000D+03 , - 4.986000000000000D+02 , & - 4.795000000000000D+02 , - 1.212500000000000D+02 , - 1.121500000000000D+02 , - 9.534999999999999D+01 , - 2.822500000000000D+01 , & - 2.416500000000000D+01 , - 1.672500000000000D+01 , - 6.585000000000000D+00 , - 5.060000000000000D+00 , - 3.614500000000000D+00 , & - 1.224500000000000D+00 , - 4.588500000000000D-01 , - 2.398500000000000D-01 , 0.000000000000000D+00 , 0.000000000000000D+00 , & 0.000000000000000D+00 , - 3.000100000000000D+03 , - 5.128500000000000D+02 , - 4.934500000000000D+02 , - 1.254000000000000D+02 , & - 1.161500000000000D+02 , - 9.905000000000000D+01 , - 2.960000000000000D+01 , - 2.545000000000000D+01 , - 1.783000000000000D+01 , & - 7.420000000000000D+00 , - 5.510000000000000D+00 , - 4.005000000000000D+00 , - 1.487500000000000D+00 , - 5.580000000000001D-01 , & - 2.862000000000000D-01 , 0.000000000000000D+00 , 0.000000000000000D+00 , 0.000000000000000D+00 , - 3.075850000000000D+03 , & - 5.273000000000000D+02 , - 5.076500000000000D+02 , - 1.296500000000000D+02 , - 1.202500000000000D+02 , - 1.028500000000000D+02 , & - 3.100500000000000D+01 , - 2.676500000000000D+01 , - 1.896500000000000D+01 , - 8.285000000000000D+00 , - 5.965000000000000D+00 , & - 4.403000000000000D+00 , - 1.758500000000000D+00 , - 6.600000000000000D-01 , - 3.327000000000000D-01 , 0.000000000000000D+00 , & 0.000000000000000D+00 , 0.000000000000000D+00 , - 3.152600000000000D+03 , - 5.420000000000000D+02 , - 5.220500000000000D+02 , & - 1.340000000000000D+02 , - 1.244000000000000D+02 , - 1.067500000000000D+02 , - 3.244500000000000D+01 , - 2.811000000000000D+01 , & - 2.013000000000000D+01 , - 9.180000000000000D+00 , - 6.430000000000000D+00 , - 4.810000000000000D+00 , - 2.038000000000000D+00 , & - 7.655000000000000D-01 , - 3.798500000000000D-01 , 0.000000000000000D+00 , 0.000000000000000D+00 , 0.000000000000000D+00 , & - 3.230250000000000D+03 , - 5.569000000000000D+02 , - 5.367000000000000D+02 , - 1.384000000000000D+02 , - 1.286500000000000D+02 , & - 1.107000000000000D+02 , - 3.392000000000000D+01 , - 2.949000000000000D+01 , - 2.133000000000000D+01 , - 1.011000000000000D+01 , & - 6.905000000000000D+00 , - 5.225000000000000D+00 , - 2.326500000000000D+00 , - 8.740000000000000D-01 , - 4.280000000000000D-01 , & 0.000000000000000D+00 , 0.000000000000000D+00 , 0.000000000000000D+00 , - 3.309096000000000D+03 , - 5.722190000000001D+02 , & - 5.517005000000000D+02 , - 1.431061500000000D+02 , - 1.331948000000000D+02 , - 1.149253000000000D+02 , - 3.561489000000000D+01 , & - 3.109068000000000D+01 , - 2.274904500000000D+01 , - 1.125364000000000D+01 , - 7.575705000000000D+00 , - 5.834165000000000D+00 , & - 2.808217000000000D+00 , - 1.127288500000000D+00 , - 6.285185000000000D-01 , - 1.179112500000000D-01 , 0.000000000000000D+00 , & 0.000000000000000D+00 , - 3.388891500000000D+03 , - 5.877424999999999D+02 , - 5.669415000000000D+02 , - 1.478713000000000D+02 , & - 1.377983000000000D+02 , - 1.192284500000000D+02 , - 3.734144500000000D+01 , - 3.272189500000000D+01 , - 2.419771500000000D+01 , & - 1.243043500000000D+01 , - 8.253140000000000D+00 , - 6.449850000000000D+00 , - 3.296832500000000D+00 , - 1.370683000000000D+00 , & - 8.198205000000000D-01 , - 1.487698000000000D-01 , 0.000000000000000D+00 , 0.000000000000000D+00 , - 3.469575500000000D+03 , & - 6.034059999999999D+02 , - 5.823215000000000D+02 , - 1.526403000000000D+02 , - 1.424053000000000D+02 , - 1.235344500000000D+02 , & - 3.902373500000000D+01 , - 3.280876500000000D+01 , - 2.560197500000000D+01 , - 1.356252500000000D+01 , - 8.862335000000000D+00 , & - 6.998020000000000D+00 , - 3.718925500000000D+00 , - 1.535619000000000D+00 , - 9.459815000000000D-01 , - 2.514883500000000D-01 , & - 1.610120500000000D-01 , 0.000000000000000D+00 , - 3.551215500000000D+03 , - 6.192765000000001D+02 , - 5.979085000000000D+02 , & - 1.574807500000000D+02 , - 1.470832000000000D+02 , - 1.279105500000000D+02 , - 4.072949000000000D+01 , - 3.591872500000000D+01 , & - 2.702884000000000D+01 , - 1.471700500000000D+01 , - 9.471650000000000D+00 , - 7.546230000000000D+00 , - 4.141707000000000D+00 , & - 1.693139500000000D+00 , - 1.067586000000000D+00 , - 2.958349000000000D-01 , - 1.707745000000000D-01 , 0.000000000000000D+00 , & - 3.633411000000000D+03 , - 6.349250000000000D+02 , - 6.132790000000000D+02 , - 1.619376500000000D+02 , - 1.513789500000000D+02 , & - 1.319077500000000D+02 , - 4.201355500000000D+01 , - 3.710700500000000D+01 , - 2.803402000000000D+01 , - 1.545374000000000D+01 , & - 9.669230000000001D+00 , - 7.695750000000000D+00 , - 4.206934000000000D+00 , - 1.637660000000000D+00 , - 1.009006000000000D+00 , & - 5.709615000000000D-01 , - 2.629719500000000D-01 , - 1.649523000000000D-01 , - 3.716739000000000D+03 , - 6.509700000000000D+02 , & - 6.290425000000000D+02 , - 1.666656000000000D+02 , - 1.559444000000000D+02 , - 1.361721000000000D+02 , - 4.351891500000000D+01 , & - 3.851601500000000D+01 , - 2.925906500000000D+01 , - 1.640821500000000D+01 , - 1.005971500000000D+01 , - 8.032695000000000D+00 , & - 4.442156000000000D+00 , - 1.682367000000000D+00 , - 1.035767000000000D+00 , - 6.344360000000000D-01 , - 2.665380000000000D-01 , & - 1.667213500000000D-01 , - 3.801010000000000D+03 , - 6.672075000000000D+02 , - 6.449990000000000D+02 , - 1.714495000000000D+02 , & - 1.605654500000000D+02 , - 1.404912500000000D+02 , - 4.503445000000000D+01 , - 3.993483500000000D+01 , - 3.049333000000000D+01 , & - 1.887170000000000D+01 , - 1.044486000000000D+01 , - 8.364795000000001D+00 , - 4.674061500000000D+00 , - 1.724259500000000D+00 , & - 1.060418500000000D+00 , - 6.956165000000000D-01 , - 2.691370000000000D-01 , - 1.684111000000000D-01 , - 3.886017500000000D+03 , & - 6.834190000000000D+02 , - 6.609315000000000D+02 , - 1.760593500000000D+02 , - 1.650128500000000D+02 , - 1.446378000000000D+02 , & - 4.633307500000000D+01 , - 4.113658000000000D+01 , - 3.151031000000000D+01 , - 1.811924000000000D+01 , - 1.061008000000000D+01 , & - 8.482945000000001D+00 , - 4.710527500000000D+00 , - 1.644878000000000D+00 , - 9.823685000000000D-01 , - 5.804440000000000D-01 , & - 2.700000000000000D-01 , - 1.602257000000000D-01 , - 3.972170000000000D+03 , - 7.000380000000000D+02 , - 6.772695000000000D+02 , & - 1.809512000000000D+02 , - 1.697410000000000D+02 , - 1.490626000000000D+02 , - 4.786519500000000D+01 , - 4.257127500000000D+01 , & - 3.275928000000000D+01 , - 1.909677500000000D+01 , - 1.098172500000000D+01 , - 8.802395000000001D+00 , - 4.932177000000000D+00 , & - 1.679166500000000D+00 , - 1.000924000000000D+00 , - 6.312970000000000D-01 , - 2.700000000000000D-01 , - 1.616569000000000D-01 , & - 4.059491000000000D+03 , - 7.170880000000000D+02 , - 6.940365000000000D+02 , - 1.861490000000000D+02 , - 1.747739500000000D+02 , & - 1.537895500000000D+02 , - 4.965462500000000D+01 , - 4.426273000000000D+01 , - 3.426403500000000D+01 , - 2.032813000000000D+01 , & - 1.158099000000000D+01 , - 9.343985000000000D+00 , - 5.359210000000000D+00 , - 1.838098500000000D+00 , - 1.125436500000000D+00 , & - 8.699700000000000D-01 , - 2.728212500000000D-01 , - 1.731652500000000D-01 , - 4.147543500000000D+03 , - 7.341070000000000D+02 , & - 7.107740000000000D+02 , - 1.911672500000000D+02 , - 1.796278500000000D+02 , - 1.583385500000000D+02 , - 5.122190000000000D+01 , & - 4.573190000000000D+01 , - 3.554634500000000D+01 , - 2.133818000000000D+01 , - 1.195607500000000D+01 , - 9.667255000000001D+00 , & - 5.586055000000000D+00 , - 1.873169000000000D+00 , - 1.144933500000000D+00 , - 9.259645000000000D-01 , - 2.730382500000000D-01 , & - 1.746812000000000D-01 , - 4.236541500000000D+03 , - 7.513225000000000D+02 , - 7.277075000000000D+02 , - 1.962454500000000D+02 , & - 1.845412000000000D+02 , - 1.629462000000000D+02 , - 5.280365000000000D+01 , - 4.721517500000000D+01 , - 3.684212000000000D+01 , & - 2.236120000000000D+01 , - 1.233021000000000D+01 , - 9.989730000000000D+00 , - 5.812690000000000D+00 , - 1.907111500000000D+00 , & - 1.163564500000000D+00 , - 9.811210000000000D-01 , - 2.728426000000000D-01 , - 1.761598500000000D-01 , - 4.326487000000000D+03 , & - 7.687350000000000D+02 , - 7.448385000000000D+02 , - 2.013841500000000D+02 , - 1.895146000000000D+02 , - 1.676131000000000D+02 , & - 5.440035000000000D+01 , - 4.871309500000000D+01 , - 3.815194500000000D+01 , - 2.339772500000000D+01 , - 1.270389000000000D+01 , & - 1.031190000000000D+01 , - 6.039485000000000D+00 , - 1.940116500000000D+00 , - 1.181478000000000D+00 , - 1.035617000000000D+00 , & - 2.723073500000000D-01 , - 1.776200500000000D-01 , - 4.417379000000000D+03 , - 7.863450000000000D+02 , - 7.621665000000000D+02 , & - 2.065483500000000D+02 , - 1.945483500000000D+02 , - 1.723396000000000D+02 , - 5.622595000000000D+01 , - 5.022595000000000D+01 , & - 3.947612500000000D+01 , - 2.444804500000000D+01 , - 1.307745500000000D+01 , - 1.063404500000000D+01 , - 6.266655000000000D+00 , & - 1.972302000000000D+00 , - 1.198759000000000D+00 , - 1.089540500000000D+00 , - 2.714703500000000D-01 , - 1.790642000000000D-01 , & - 4.509218500000000D+03 , - 8.041525000000000D+02 , - 7.796920000000000D+02 , - 2.118439000000000D+02 , - 1.996425000000000D+02 , & - 1.771257500000000D+02 , - 5.763990000000000D+01 , - 5.175400000000000D+01 , - 4.081487500000000D+01 , - 2.551233000000000D+01 , & - 1.345114000000000D+01 , - 1.095638500000000D+01 , - 6.494330000000000D+00 , - 2.003742500000000D+00 , - 1.215461000000000D+00 , & - 1.142929000000000D+00 , - 2.703513000000000D-01 , - 1.804875500000000D-01 , - 4.602005500000000D+03 , - 8.221570000000000D+02 , & - 7.974145000000000D+02 , - 2.171653500000000D+02 , - 2.047974500000000D+02 , - 1.819719000000000D+02 , - 5.928325000000000D+01 , & - 5.329755000000000D+01 , - 4.216849000000000D+01 , - 2.659084500000000D+01 , - 1.382522000000000D+01 , - 1.127916000000000D+01 , & - 6.722700000000000D+00 , - 2.034538000000000D+00 , - 1.231657500000000D+00 , - 1.195878500000000D+00 , - 2.689847000000000D-01 , & - 1.818970000000000D-01 , - 4.695739500000000D+03 , - 8.403600000000000D+02 , - 8.153350000000000D+02 , - 2.225480000000000D+02 , & - 2.100132000000000D+02 , - 1.868781000000000D+02 , - 6.094255000000000D+01 , - 5.485670000000000D+01 , - 4.353713500000000D+01 , & - 2.768378000000000D+01 , - 1.419985500000000D+01 , - 1.160255000000000D+01 , - 6.951880000000000D+00 , - 2.064758500000000D+00 , & - 1.247399000000000D+00 , - 1.248348500000000D+00 , - 2.673954500000000D-01 , - 1.832944000000000D-01 & ], shape ( huckel_eneg )) integer , parameter :: huckel_ncore ( 103 ) = reshape ([ & 0 , 0 , 1 , 1 , 1 , 1 , 1 , 1 , 1 , 1 , 5 , 5 , 5 , 5 , 5 , & 5 , 5 , 5 , 9 , 9 , 9 , 9 , 9 , 9 , 9 , 9 , 9 , 9 , 9 , 9 , & 14 , 14 , 14 , 14 , 14 , 14 , 18 , 18 , 18 , 18 , 18 , 18 , 18 , 18 , 18 , & 18 , 18 , 18 , 23 , 23 , 23 , 23 , 23 , 23 , 27 , 27 , 27 , 27 , 27 , 27 , & 27 , 27 , 27 , 27 , 27 , 27 , 27 , 27 , 27 , 27 , 34 , 34 , 34 , 34 , 34 , & 34 , 34 , 34 , 34 , 34 , 39 , 39 , 39 , 39 , 39 , 39 , 43 , 43 , 43 , 43 , & 43 , 43 , 43 , 43 , 43 , 43 , 43 , 43 , 43 , 43 , 43 , 43 , 43 & ], shape ( huckel_ncore )) integer , parameter :: huckel_nval ( 103 ) = reshape ([ & 1 , 1 , 1 , 1 , 2 , 2 , 2 , 2 , 2 , 2 , 1 , 1 , 2 , 2 , 2 , & 2 , 2 , 2 , 1 , 1 , 2 , 2 , 2 , 2 , 2 , 2 , 2 , 2 , 2 , 2 , & 2 , 2 , 2 , 2 , 2 , 2 , 1 , 1 , 2 , 2 , 2 , 2 , 2 , 2 , 2 , & 2 , 2 , 2 , 2 , 2 , 2 , 2 , 2 , 2 , 1 , 1 , 2 , 2 , 2 , 2 , & 2 , 2 , 2 , 2 , 2 , 2 , 2 , 2 , 2 , 2 , 2 , 2 , 2 , 2 , 2 , & 2 , 2 , 2 , 2 , 2 , 2 , 2 , 2 , 2 , 2 , 2 , 1 , 1 , 3 , 3 , & 4 , 4 , 4 , 4 , 4 , 4 , 4 , 4 , 4 , 4 , 4 , 4 , 4 & ], shape ( huckel_nval )) integer , parameter :: huckel_ndval ( 4 , 103 ) = reshape ([ & 1 , 0 , 0 , 0 , 1 , 0 , 0 , 0 , 1 , 0 , 0 , 0 , 1 , 0 , 0 , & 0 , 1 , 3 , 0 , 0 , 1 , 3 , 0 , 0 , 1 , 3 , 0 , 0 , 1 , 3 , & 0 , 0 , 1 , 3 , 0 , 0 , 1 , 3 , 0 , 0 , 1 , 0 , 0 , 0 , 1 , & 0 , 0 , 0 , 1 , 3 , 0 , 0 , 1 , 3 , 0 , 0 , 1 , 3 , 0 , 0 , & 1 , 3 , 0 , 0 , 1 , 3 , 0 , 0 , 1 , 3 , 0 , 0 , 1 , 0 , 0 , & 0 , 1 , 0 , 0 , 0 , 5 , 1 , 0 , 0 , 5 , 1 , 0 , 0 , 5 , 1 , & 0 , 0 , 5 , 1 , 0 , 0 , 5 , 1 , 0 , 0 , 5 , 1 , 0 , 0 , 5 , & 1 , 0 , 0 , 5 , 1 , 0 , 0 , 5 , 1 , 0 , 0 , 5 , 1 , 0 , 0 , & 1 , 3 , 0 , 0 , 1 , 3 , 0 , 0 , 1 , 3 , 0 , 0 , 1 , 3 , 0 , & 0 , 1 , 3 , 0 , 0 , 1 , 3 , 0 , 0 , 1 , 0 , 0 , 0 , 1 , 0 , & 0 , 0 , 5 , 1 , 0 , 0 , 5 , 1 , 0 , 0 , 5 , 1 , 0 , 0 , 5 , & 1 , 0 , 0 , 5 , 1 , 0 , 0 , 5 , 1 , 0 , 0 , 5 , 1 , 0 , 0 , & 5 , 1 , 0 , 0 , 5 , 1 , 0 , 0 , 5 , 1 , 0 , 0 , 1 , 3 , 0 , & 0 , 1 , 3 , 0 , 0 , 1 , 3 , 0 , 0 , 1 , 3 , 0 , 0 , 1 , 3 , & 0 , 0 , 1 , 3 , 0 , 0 , 1 , 0 , 0 , 0 , 1 , 0 , 0 , 0 , 5 , & 1 , 0 , 0 , 7 , 1 , 0 , 0 , 7 , 1 , 0 , 0 , 7 , 1 , 0 , 0 , & 7 , 1 , 0 , 0 , 7 , 1 , 0 , 0 , 7 , 1 , 0 , 0 , 7 , 1 , 0 , & 0 , 7 , 1 , 0 , 0 , 7 , 1 , 0 , 0 , 7 , 1 , 0 , 0 , 7 , 1 , & 0 , 0 , 7 , 1 , 0 , 0 , 7 , 1 , 0 , 0 , 5 , 1 , 0 , 0 , 5 , & 1 , 0 , 0 , 5 , 1 , 0 , 0 , 5 , 1 , 0 , 0 , 5 , 1 , 0 , 0 , & 5 , 1 , 0 , 0 , 5 , 1 , 0 , 0 , 5 , 1 , 0 , 0 , 5 , 1 , 0 , & 0 , 5 , 1 , 0 , 0 , 1 , 3 , 0 , 0 , 1 , 3 , 0 , 0 , 1 , 3 , & 0 , 0 , 1 , 3 , 0 , 0 , 1 , 3 , 0 , 0 , 1 , 3 , 0 , 0 , 1 , & 0 , 0 , 0 , 1 , 0 , 0 , 0 , 3 , 5 , 1 , 0 , 3 , 5 , 1 , 0 , & 3 , 7 , 5 , 1 , 3 , 7 , 5 , 1 , 3 , 7 , 5 , 1 , 3 , 7 , 5 , & 1 , 3 , 7 , 5 , 1 , 3 , 7 , 5 , 1 , 3 , 7 , 5 , 1 , 3 , 7 , & 5 , 1 , 3 , 7 , 5 , 1 , 3 , 7 , 5 , 1 , 3 , 7 , 5 , 1 , 3 , & 7 , 5 , 1 , 3 , 7 , 5 , 1 & ], shape ( huckel_ndval )) !> @brief Order of MINI basis set for different element types. !> !> @details The MINI basis set must be in the following order for different element types: !> !> @order: !>     - For H-LA (atype 1): !>       1S, 2S, 2P, 3S, 3P, 3D, 4S, 4P, 4D, 5S, 5P, 5D, 6S, 6P !>     - For CE-YB (atype 2): !>       1S, 2S, 2P, 3S, 3P, 3D, 4S, 4P, 4D, 5S, 5P, 4F, 5D, 6S !>     - For LU-RN (atype 3): !>       1S, 2S, 2P, 3S, 3P, 3D, 4S, 4P, 4D, 4F, 5S, 5P, 5D, 6S, 6P !>     - For FR-RA (atype 4): !>       ... 4F, 5S, 5P, 5D, 6S, 6P, 7S !>     - For AC-TH (atype 5): !>       ... 4F, 5S, 5P, 5D, 6S, 6P, 6D, 7S !>     - For PA-LR (atype 6): !>       ... 4F, 5S, 5P, 5D, 6S, 6P, 5F, 6D, 7S integer , parameter :: huckel_lneg ( 56 , 6 ) = reshape ([ & 1 , 2 , 3 , 3 , 3 , 4 , 5 , 5 , 5 , 6 , 6 , 6 , 6 , 6 , 7 , & 8 , 8 , 8 , 9 , 9 , 9 , 9 , 9 , 10 , 11 , 11 , 11 , 12 , 12 , 12 , & 12 , 12 , 13 , 14 , 14 , 14 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , & 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , & 1 , 2 , 3 , 3 , 3 , 4 , 5 , 5 , 5 , 6 , 6 , 6 , 6 , 6 , 7 , & 8 , 8 , 8 , 9 , 9 , 9 , 9 , 9 , 10 , 11 , 11 , 11 , 12 , 12 , 12 , & 12 , 12 , 12 , 12 , 13 , 13 , 13 , 13 , 13 , 14 , 0 , 0 , 0 , 0 , 0 , & 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , & 1 , 2 , 3 , 3 , 3 , 4 , 5 , 5 , 5 , 6 , 6 , 6 , 6 , 6 , 7 , & 8 , 8 , 8 , 9 , 9 , 9 , 9 , 9 , 10 , 10 , 10 , 10 , 10 , 10 , 10 , & 11 , 12 , 12 , 12 , 13 , 13 , 13 , 13 , 13 , 14 , 15 , 15 , 15 , 0 , 0 , & 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , & 1 , 2 , 3 , 3 , 3 , 4 , 5 , 5 , 5 , 6 , 6 , 6 , 6 , 6 , 7 , & 8 , 8 , 8 , 9 , 9 , 9 , 9 , 9 , 10 , 10 , 10 , 10 , 10 , 10 , 10 , & 11 , 12 , 12 , 12 , 13 , 13 , 13 , 13 , 13 , 14 , 15 , 15 , 15 , 16 , 0 , & 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , & 1 , 2 , 3 , 3 , 3 , 4 , 5 , 5 , 5 , 6 , 6 , 6 , 6 , 6 , 7 , & 8 , 8 , 8 , 9 , 9 , 9 , 9 , 9 , 10 , 10 , 10 , 10 , 10 , 10 , 10 , & 11 , 12 , 12 , 12 , 13 , 13 , 13 , 13 , 13 , 14 , 15 , 15 , 15 , 16 , 16 , & 16 , 16 , 16 , 17 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , & 1 , 2 , 3 , 3 , 3 , 4 , 5 , 5 , 5 , 6 , 6 , 6 , 6 , 6 , 7 , & 8 , 8 , 8 , 9 , 9 , 9 , 9 , 9 , 10 , 10 , 10 , 10 , 10 , 10 , 10 , & 11 , 12 , 12 , 12 , 13 , 13 , 13 , 13 , 13 , 14 , 15 , 15 , 15 , 16 , 16 , & 16 , 16 , 16 , 16 , 16 , 17 , 17 , 17 , 17 , 17 , 18 & ], shape ( huckel_lneg )) end module","tags":"","url":"sourcefile/huckel_lut.f90.html"},{"title":"namd.F90 – OpenQP Fortran API","text":"Source Code !> @brief  Nonadiabatic molecular dynamics (NAMD) — Tully fewest-switches !>         surface hopping (FSSH) core kernels for MRSF-TDDFT. !> !> @details !>   Faithful port of the surface-hopping numerics from the GAMESS `namd.src` !>   module (S. Lee), restructured into clean, argument-based modern Fortran so !>   the kernels are unit-testable and free of COMMON-block / dynamic-memory !>   coupling.  The physics mirrors the original exactly: !> !>     - time-derivative couplings (TDC) from wavefunction overlaps !>       between consecutive nuclear steps        [GAMESS NACVFD] !>     - RK4 propagation of the electronic amplitudes !>       i*hbar*\\dot{c} = (E - i*sigma) c          [GAMESS PPTDECOE/NDDTCR/NDDTCC] !>     - cumulative Tully hopping probabilities    [GAMESS FSSHPRST/FSSHPR] !>     - fewest-switches hop decision + isotropic !>       velocity rescaling (energy conservation)  [GAMESS FSSH/FSSHT/RESCALV] !>     - kinetic energy                            [GAMESS MDQKIN] !> !>   Internal-conversion accuracy upgrades, added per a verified literature !>   survey (see session RESEARCH_ic_isc_methods.md) and absent from the GAMESS !>   reference: !>     - energy-based decoherence correction (EDC) — Granucci & Persico, !>       J. Chem. Phys. 126, 134114 (2007); the SHARC default decoherence scheme !>     - trivial / unavoided-crossing detection with diabatic state following, !>       in the spirit of SC-FSSH — Wang & Prezhdo, JPCL 5, 713 (2014) !> !>   Planned next (documented, not yet implemented here): !>     - norm-preserving interpolation (NPI) time-derivative couplings !>       (Meek & Levine, JPCL 5, 2351 (2014)): rigorous multistate form is the !>       real antisymmetric matrix logarithm of the Loewdin-orthonormalised !>       step overlap, T = logm(orth(S))/dt, which reduces to the exact 2-state !>       identity T*dt = arcsin(S_10).  Will replace namd_state_tdc when wired. !>     - intersystem crossing (ISC) via the SHARC spin-adiabatic representation: !>       diagonalise H = H_MCH + H_SOC, hop on the diagonal states, propagate !>       c_diag = U' . P_MCH . U . c_diag.  Requires MRSF Breit-Pauli SOC !>       matrix elements as input. !> !>   Deliberate, documented deviations from the original (\"the GAMESS code may !>   not be perfect\"): !>     * Everything is in consistent atomic units (energies in Hartree, !>       velocities in bohr/atomic-time, masses in electron masses).  The !>       original mixed Hartree (FSSH) and kcal/mol (FSSHT, QM/MM) paths; here a !>       single code path is used and the caller converts units once. !>     * The O(nstate&#94;2 * nsub) per-substep probability buffer of FSSHPR is !>       dropped: probabilities are accumulated on the fly, then clamped and !>       row-normalised once — numerically identical to the original sum. !> !> @author  Port: OpenQP NAMD; original algorithm: Seunghoon Lee (GAMESS) !> @date    2026-06 module namd_mod use precision , only : dp implicit none private character ( len =* ), parameter :: module_name = \"namd_mod\" public :: namd_state_tdc public :: namd_coeff_deriv public :: namd_propagate_coeff public :: namd_accumulate_hop_prob public :: namd_finalize_hop_prob public :: namd_kinetic_energy public :: namd_rescale_velocities public :: namd_fssh_decision public :: namd_decoherence_edc public :: namd_trivial_crossing !> Default empirical decoherence constant C in the energy-based correction !> (Granucci & Persico, J. Chem. Phys. 126, 134114 (2007)), in Hartree. real ( kind = dp ), parameter , public :: NAMD_EDC_C_DEFAULT = 0.1_dp contains !> @brief Time-derivative (nonadiabatic) coupling from state overlaps. !>        sigma(i,j) = ( S(i,j) - S(j,i) ) / (2 dt)          [GAMESS NACVFD] !> !> @param[in]  stas   nstate x nstate overlap <Phi_i(t-dt)|Phi_j(t)> between !>                     the previous and current nuclear geometries !> @param[in]  dt     nuclear time step (atomic time units) !> @param[out] tdc    nstate x nstate antisymmetric time-derivative coupling subroutine namd_state_tdc ( stas , dt , tdc ) real ( kind = dp ), intent ( in ) :: stas (:,:) real ( kind = dp ), intent ( in ) :: dt real ( kind = dp ), intent ( out ) :: tdc (:,:) integer :: i , j , n n = size ( stas , 1 ) do j = 1 , n do i = 1 , n tdc ( i , j ) = ( stas ( i , j ) - stas ( j , i )) / ( 2.0_dp * dt ) end do end do end subroutine namd_state_tdc !> @brief Right-hand side of the electronic equation of motion in the adiabatic !>        basis (amplitudes c = cr + i*ci): !>           \\dot{cr}_k = - sum_i sigma(k,i) cr_i + E_k ci_k !>           \\dot{ci}_k = - sum_i sigma(k,i) ci_i - E_k cr_k !>        i.e. \\dot{c} = -(i E + sigma) c.        [GAMESS NDDTCR/NDDTCC] !> !>   The returned increments are pre-multiplied by the integration step `h` !>   (matching the original convention where k1..k4 are h*f). subroutine namd_coeff_deriv ( cr , ci , tdc , eig , h , dcr , dci ) real ( kind = dp ), intent ( in ) :: cr (:), ci (:) real ( kind = dp ), intent ( in ) :: tdc (:,:) real ( kind = dp ), intent ( in ) :: eig (:) real ( kind = dp ), intent ( in ) :: h real ( kind = dp ), intent ( out ) :: dcr (:), dci (:) integer :: k , i , n real ( kind = dp ) :: sr , si n = size ( cr ) do k = 1 , n sr = 0.0_dp si = 0.0_dp do i = 1 , n sr = sr - tdc ( k , i ) * cr ( i ) si = si - tdc ( k , i ) * ci ( i ) end do dcr ( k ) = ( sr + eig ( k ) * ci ( k )) * h dci ( k ) = ( si - eig ( k ) * cr ( k )) * h end do end subroutine namd_coeff_deriv !> @brief One RK4 sub-step of the electronic amplitudes, followed by !>        renormalisation.                         [GAMESS PPTDECOE] !> !> @param[in,out] cr,ci  real/imaginary amplitudes (nstate) !> @param[in]     tdc    time-derivative coupling (nstate x nstate, constant !>                       over the nuclear step) !> @param[in]     eig    absolute adiabatic state energies (Hartree) !> @param[in]     h      electronic sub-step length (atomic time units) subroutine namd_propagate_coeff ( cr , ci , tdc , eig , h ) real ( kind = dp ), intent ( inout ) :: cr (:), ci (:) real ( kind = dp ), intent ( in ) :: tdc (:,:) real ( kind = dp ), intent ( in ) :: eig (:) real ( kind = dp ), intent ( in ) :: h integer :: n , k real ( kind = dp ), allocatable :: k1r (:), k1i (:), k2r (:), k2i (:) real ( kind = dp ), allocatable :: k3r (:), k3i (:), k4r (:), k4i (:) real ( kind = dp ), allocatable :: tr (:), ti (:) real ( kind = dp ) :: dnorm n = size ( cr ) allocate ( k1r ( n ), k1i ( n ), k2r ( n ), k2i ( n ), k3r ( n ), k3i ( n ), k4r ( n ), k4i ( n ), & tr ( n ), ti ( n )) call namd_coeff_deriv ( cr , ci , tdc , eig , h , k1r , k1i ) tr = cr + 0.5_dp * k1r ; ti = ci + 0.5_dp * k1i call namd_coeff_deriv ( tr , ti , tdc , eig , h , k2r , k2i ) tr = cr + 0.5_dp * k2r ; ti = ci + 0.5_dp * k2i call namd_coeff_deriv ( tr , ti , tdc , eig , h , k3r , k3i ) tr = cr + k3r ; ti = ci + k3i call namd_coeff_deriv ( tr , ti , tdc , eig , h , k4r , k4i ) do k = 1 , n cr ( k ) = cr ( k ) + ( k1r ( k ) + 2.0_dp * k2r ( k ) + 2.0_dp * k3r ( k ) + k4r ( k )) / 6.0_dp ci ( k ) = ci ( k ) + ( k1i ( k ) + 2.0_dp * k2i ( k ) + 2.0_dp * k3i ( k ) + k4i ( k )) / 6.0_dp end do dnorm = sqrt ( sum ( cr * cr ) + sum ( ci * ci )) if ( dnorm > 0.0_dp ) then cr = cr / dnorm ci = ci / dnorm end if deallocate ( k1r , k1i , k2r , k2i , k3r , k3i , k4r , k4i , tr , ti ) end subroutine namd_propagate_coeff !> @brief Accumulate the Tully transition probability over one electronic !>        sub-step into the running cumulative matrix.   [GAMESS FSSHPRST] !> !>        g(i,j) += 2 sigma(i,j) Re(c_i&#94;* c_j) h / |c_i|&#94;2 !> !>   Call once per sub-step (after propagating the amplitudes), then finalise !>   with namd_finalize_hop_prob. subroutine namd_accumulate_hop_prob ( cmhp , cr , ci , tdc , h ) real ( kind = dp ), intent ( inout ) :: cmhp (:,:) real ( kind = dp ), intent ( in ) :: cr (:), ci (:) real ( kind = dp ), intent ( in ) :: tdc (:,:) real ( kind = dp ), intent ( in ) :: h integer :: i , j , n real ( kind = dp ) :: pii n = size ( cr ) do i = 1 , n pii = cr ( i ) * cr ( i ) + ci ( i ) * ci ( i ) if ( pii <= 0.0_dp ) cycle do j = 1 , n cmhp ( i , j ) = cmhp ( i , j ) & + 2.0_dp * tdc ( i , j ) * ( cr ( i ) * cr ( j ) + ci ( i ) * ci ( j )) * h / pii end do end do end subroutine namd_accumulate_hop_prob !> @brief Finalise cumulative hopping probabilities: clamp negatives to zero !>        and renormalise any row whose total exceeds one.   [GAMESS FSSHPR] subroutine namd_finalize_hop_prob ( cmhp ) real ( kind = dp ), intent ( inout ) :: cmhp (:,:) integer :: i , j , n real ( kind = dp ) :: rowsum n = size ( cmhp , 1 ) do i = 1 , n do j = 1 , n if ( cmhp ( i , j ) < 0.0_dp ) cmhp ( i , j ) = 0.0_dp end do rowsum = sum ( cmhp ( i ,:)) if ( rowsum > 1.0_dp ) cmhp ( i ,:) = cmhp ( i ,:) / rowsum end do end subroutine namd_finalize_hop_prob !> @brief Classical kinetic energy  KE = 1/2 sum_a m_a |v_a|&#94;2  (atomic units). !>                                                          [GAMESS MDQKIN] !> @param[in] vel   3 x natom velocities (bohr / atomic-time) !> @param[in] mass  natom atomic masses (electron masses) pure function namd_kinetic_energy ( vel , mass ) result ( ke ) real ( kind = dp ), intent ( in ) :: vel (:,:) real ( kind = dp ), intent ( in ) :: mass (:) real ( kind = dp ) :: ke integer :: a , nat nat = size ( mass ) ke = 0.0_dp do a = 1 , nat ke = ke + mass ( a ) * ( vel ( 1 , a ) ** 2 + vel ( 2 , a ) ** 2 + vel ( 3 , a ) ** 2 ) end do ke = 0.5_dp * ke end function namd_kinetic_energy !> @brief Isotropic velocity rescaling after a hop to conserve total energy. !>        v <- v * sqrt(1 + dE/KE),  dE = E_old - E_new.    [GAMESS RESCALV] !> !>   Caller must already have verified the hop is energetically allowed !>   (KE >= |dE| when dE < 0); otherwise the argument of sqrt is negative. subroutine namd_rescale_velocities ( vel , ke , de ) real ( kind = dp ), intent ( inout ) :: vel (:,:) real ( kind = dp ), intent ( in ) :: ke !< kinetic energy on the old surface real ( kind = dp ), intent ( in ) :: de !< E_old - E_new (Hartree) real ( kind = dp ) :: scale if ( ke <= 0.0_dp ) return scale = sqrt ( max ( 0.0_dp , 1.0_dp + de / ke )) vel = scale * vel end subroutine namd_rescale_velocities !> @brief Fewest-switches hop decision and (on accept) isotropic velocity !>        rescaling.                                  [GAMESS FSSH/FSSHT] !> !>   All energies in Hartree, velocities/masses in atomic units. !> !> @param[in]     cmhp     finalised cumulative hop probabilities (nstate&#94;2); !>                         row `active` is used !> @param[in]     eabs     absolute adiabatic state energies (Hartree) !> @param[in]     rand     random number in [0,1) !> @param[in]     thrshe   energy-gap gate: hops with |dE| > thrshe are blocked !>                         (Hartree). Use a large value (e.g. huge) to disable. !> @param[in]     mass     atomic masses (natom) !> @param[in,out] vel      3 x natom velocities; rescaled in place on a hop !> @param[in,out] active   active state index (1..nstate); updated on a hop !> @param[out]    hopped   .true. if a hop occurred !> @param[out]    target   state hopped to (= active on no hop) !> @param[out]    blocked  .true. if a candidate hop was rejected (frustrated !>                         or gated) subroutine namd_fssh_decision ( cmhp , eabs , rand , thrshe , mass , vel , & active , hopped , target , blocked ) real ( kind = dp ), intent ( in ) :: cmhp (:,:) real ( kind = dp ), intent ( in ) :: eabs (:) real ( kind = dp ), intent ( in ) :: rand real ( kind = dp ), intent ( in ) :: thrshe real ( kind = dp ), intent ( in ) :: mass (:) real ( kind = dp ), intent ( inout ) :: vel (:,:) integer , intent ( inout ) :: active logical , intent ( out ) :: hopped integer , intent ( out ) :: target logical , intent ( out ) :: blocked integer :: i , ncrst , n real ( kind = dp ) :: lower , upper , de , ke n = size ( eabs ) ncrst = active hopped = . false . blocked = . false . target = active ! Walk the cumulative probability ladder over candidate target states. ! Self-transition probability is identically zero (sigma(i,i)=0), so the ! cumulative sum can include the diagonal without effect. lower = 0.0_dp do i = 1 , n if ( i == ncrst ) then lower = lower + cmhp ( ncrst , i ) ! adds 0; keeps ladder aligned cycle end if upper = lower + cmhp ( ncrst , i ) if ( rand > lower . and . rand < upper ) then de = eabs ( ncrst ) - eabs ( i ) ! E_old - E_new ke = namd_kinetic_energy ( vel , mass ) ! Frustrated hop: not enough kinetic energy to climb uphill. if ( de < 0.0_dp . and . ke < abs ( de )) then blocked = . true . lower = upper cycle end if ! Energy-gap gate. if ( abs ( de ) > thrshe ) then blocked = . true . lower = upper cycle end if ! Accept the hop. active = i target = i hopped = . true . call namd_rescale_velocities ( vel , ke , de ) return end if lower = upper end do end subroutine namd_fssh_decision !> @brief Energy-based decoherence correction (EDC). !>        Granucci & Persico, J. Chem. Phys. 126, 134114 (2007); the pragmatic !>        default in SHARC. Damps the non-active amplitudes toward zero on the !>        decoherence time scale and restores the total norm via the active !>        state: !>           tau_k = (1/|E_k - E_a|) (1 + C/E_kin)     (atomic units, hbar=1) !>           c_k  <- c_k exp(-dt/tau_k)        for k /= a !>           c_a  <- c_a sqrt( (1 - sum_{k/=a}|c_k|&#94;2) / |c_a|&#94;2 ) !> !>   Apply once per nuclear step, after the electronic propagation. !> !> @param[in,out] cr,ci  amplitudes (nstate) !> @param[in]     eabs   absolute adiabatic state energies (Hartree) !> @param[in]     active active state index !> @param[in]     ekin   nuclear kinetic energy (Hartree) !> @param[in]     dt     nuclear time step (atomic time units) !> @param[in]     cval   empirical constant C (Hartree); see NAMD_EDC_C_DEFAULT subroutine namd_decoherence_edc ( cr , ci , eabs , active , ekin , dt , cval ) real ( kind = dp ), intent ( inout ) :: cr (:), ci (:) real ( kind = dp ), intent ( in ) :: eabs (:) integer , intent ( in ) :: active real ( kind = dp ), intent ( in ) :: ekin real ( kind = dp ), intent ( in ) :: dt real ( kind = dp ), intent ( in ) :: cval integer :: k , n real ( kind = dp ) :: gap , tau , decay , pa , sum_others , scale real ( kind = dp ), parameter :: tiny = 1.0e-12_dp n = size ( cr ) if ( ekin <= 0.0_dp ) return ! no kinetic energy -> no decoherence sum_others = 0.0_dp do k = 1 , n if ( k == active ) cycle gap = abs ( eabs ( k ) - eabs ( active )) if ( gap < tiny ) then ! (near-)degenerate: skip damping sum_others = sum_others + cr ( k ) * cr ( k ) + ci ( k ) * ci ( k ) cycle end if tau = ( 1.0_dp / gap ) * ( 1.0_dp + cval / ekin ) decay = exp ( - dt / tau ) cr ( k ) = cr ( k ) * decay ci ( k ) = ci ( k ) * decay sum_others = sum_others + cr ( k ) * cr ( k ) + ci ( k ) * ci ( k ) end do pa = cr ( active ) * cr ( active ) + ci ( active ) * ci ( active ) if ( pa > tiny ) then scale = sqrt ( max ( 0.0_dp , 1.0_dp - sum_others ) / pa ) cr ( active ) = cr ( active ) * scale ci ( active ) = ci ( active ) * scale end if end subroutine namd_decoherence_edc !> @brief Trivial / unavoided-crossing detection and diabatic state following. !>        Practical local-diabatization fix in the spirit of SC-FSSH !>        (Wang & Prezhdo, J. Phys. Chem. Lett. 5, 713 (2014)). !> !>   At a trivial (non-interacting) crossing two adiabatic labels swap between !>   consecutive steps: the active state's self-overlap |S(a,a)| collapses while !>   |S(a,j)| ~ 1 for the partner j.  Following the diabatic character (relabel !>   active -> j) prevents the spurious \"hop far from the crossing\" that plain !>   FSSH suffers on dense PES.  No velocity rescaling is applied: at a trivial !>   crossing the energy is continuous along the diabatic state. !> !> @param[in]     stas      nstate x nstate state overlap S(i,j)=<i(t-dt)|j(t)> !> @param[in]     thresh    self-overlap threshold below which a crossing is !>                          flagged (e.g. 0.5) !> @param[in,out] active    active state index; relabelled on a trivial crossing !> @param[out]    swapped   .true. if a relabel occurred subroutine namd_trivial_crossing ( stas , thresh , active , swapped ) real ( kind = dp ), intent ( in ) :: stas (:,:) real ( kind = dp ), intent ( in ) :: thresh integer , intent ( inout ) :: active logical , intent ( out ) :: swapped integer :: j , n , jmax real ( kind = dp ) :: amax n = size ( stas , 1 ) swapped = . false . if ( abs ( stas ( active , active )) >= thresh ) return ! no trivial crossing ! Partner = state with the largest |overlap| to the (old) active state. jmax = active amax = abs ( stas ( active , active )) do j = 1 , n if ( j == active ) cycle if ( abs ( stas ( active , j )) > amax ) then amax = abs ( stas ( active , j )) jmax = j end if end do if ( jmax /= active . and . amax >= thresh ) then active = jmax swapped = . true . end if end subroutine namd_trivial_crossing !> @brief C-interoperable entry: one FSSH surface-hopping step for MRSF-TDDFT. !>        Driven from the Python NAMD trajectory loop after the per-step !>        electronic structure (energies, response vectors, phase-corrected !>        state overlap) has been computed. subroutine namd_hop_C ( c_handle ) bind ( C , name = \"mrsf_namd_hop\" ) use c_interop , only : oqp_handle_t , oqp_handle_get_info use types , only : information type ( oqp_handle_t ) :: c_handle type ( information ), pointer :: inf inf => oqp_handle_get_info ( c_handle ) call namd_hop ( inf ) end subroutine namd_hop_C !> @brief One Tully FSSH step: TDC from the state overlap, RK4 amplitude !>        propagation over sub-steps, optional EDC decoherence, trivial-crossing !>        following, hop decision and isotropic velocity rescaling. !> !>   Exchanges all NAMD state with the Python driver via flat tagarray records !>   (1-D, layout-unambiguous): !>     in : OQP_td_states_overlap (n x n), OQP_td_energies (n), !>          OQP_namd_coef (2n: re1,im1,re2,im2,...), OQP_namd_velocity (3*nat), !>          OQP_namd_params (>=12 packed scalars) !>     out: OQP_namd_coef, OQP_namd_velocity (rescaled), OQP_namd_params(active, !>          hopped, target), OQP_namd_results (n*n cumulative probs + flags) subroutine namd_hop ( infos ) use io_constants , only : iw use oqp_tagarray_driver use types , only : information use messages , only : show_message , with_abort implicit none type ( information ), target , intent ( inout ) :: infos integer :: n , nat , i , a , isub , nsub , active , target , decoherence , trivial_en real ( kind = dp ) :: dt_fs , dt_au , hsub , thrshe , rand , edc_c , triv_thr , ekin logical :: hopped , blocked , swapped real ( kind = dp ), allocatable :: tdc (:,:), cmhp (:,:), cr (:), ci (:), eabs (:), vel (:,:) real ( kind = dp ), allocatable :: mass_au (:) ! tagarray records real ( kind = dp ), contiguous , pointer :: stas_in (:), eabs_in (:), coef (:), velf (:), & params (:), results (:), tdc_in (:) real ( kind = dp ), contiguous , pointer :: mass (:) real ( kind = dp ), allocatable :: stas2 (:,:) ! 1 atomic mass unit (Dalton) in electron masses real ( kind = dp ), parameter :: AMU_TO_AU = 182 2.888486209_dp character ( len =* ), parameter :: subroutine_name = \"namd_hop\" ! NAMD state (energies/overlap/couplings) is supplied entirely through the ! namd_* tags, so the same kernel serves same-spin MRSF (n = tddft%nstate) ! and spin-adiabatic SOC NAMD (n = ns + 3*nt). character ( len =* ), parameter :: tags_req ( * ) = ( / character ( len = 80 ) :: & OQP_namd_coef , OQP_namd_velocity , OQP_namd_params , OQP_namd_tdc , & OQP_namd_eabs , OQP_namd_stas / ) character ( len =* ), parameter :: tags_out ( * ) = ( / character ( len = 80 ) :: & OQP_namd_results / ) real ( kind = dp ), parameter :: FS_TO_AU = 4 1.341374575751_dp open ( unit = iw , file = infos % log_filename , position = \"append\" ) mass => infos % atoms % mass nat = size ( mass ) call data_has_tags ( infos % dat , tags_req , module_name , subroutine_name , with_abort ) call tagarray_get_data ( infos % dat , OQP_namd_coef , coef ) call tagarray_get_data ( infos % dat , OQP_namd_velocity , velf ) call tagarray_get_data ( infos % dat , OQP_namd_params , params ) call tagarray_get_data ( infos % dat , OQP_namd_tdc , tdc_in ) call tagarray_get_data ( infos % dat , OQP_namd_eabs , eabs_in ) call tagarray_get_data ( infos % dat , OQP_namd_stas , stas_in ) ! number of states: from params (slot 13); fall back to tddft%nstate n = nint ( params ( 13 )) if ( n <= 0 ) n = int ( infos % tddft % nstate ) ! (re)allocate the results record. erase + alloc_or_die replaces the removed ! remove_records/reserve_data API (main's tagarray container refactor); erase ! drops any stale record so alloc_or_die always binds a fresh n*n+8 buffer. call infos % dat % erase ( tags_out ) call infos % dat % alloc_or_die ( OQP_namd_results , ( / n * n + 8 / ), results , & description = OQP_namd_results_comment ) ! unpack parameters dt_fs = params ( 1 ) nsub = max ( 1 , nint ( params ( 2 ))) thrshe = params ( 3 ) rand = params ( 4 ) active = nint ( params ( 5 )) decoherence = nint ( params ( 6 )) edc_c = params ( 7 ) ! params(8) = tdc scheme (0 finite-diff, 1 NPI), handled in the Python driver trivial_en = nint ( params ( 9 )) triv_thr = params ( 10 ) dt_au = dt_fs * FS_TO_AU hsub = dt_au / real ( nsub , dp ) allocate ( tdc ( n , n ), cmhp ( n , n ), cr ( n ), ci ( n ), eabs ( n ), vel ( 3 , nat ), mass_au ( nat ), & stas2 ( n , n )) mass_au = mass * AMU_TO_AU ! infos%atoms%mass is in amu; integrate in a.u. do i = 1 , n cr ( i ) = coef ( 2 * i - 1 ) ci ( i ) = coef ( 2 * i ) end do eabs = eabs_in ( 1 : n ) ! absolute state energies (Hartree) do a = 1 , nat vel ( 1 , a ) = velf ( 3 * a - 2 ) vel ( 2 , a ) = velf ( 3 * a - 1 ) vel ( 3 , a ) = velf ( 3 * a ) end do do i = 1 , n do a = 1 , n stas2 ( i , a ) = stas_in (( i - 1 ) * n + a ) ! state overlap, flat row-major end do end do cmhp = 0.0_dp ! 1) follow diabatic character across trivial/unavoided crossings swapped = . false . if ( trivial_en == 1 ) call namd_trivial_crossing ( stas2 , triv_thr , active , swapped ) ! 2) time-derivative couplings: supplied by the Python driver as a flat !    row-major (n x n) matrix (finite difference or norm-preserving !    interpolation). tdc(i,j) = tdc_in((i-1)*n + j). Fall back to the !    in-Fortran finite difference if a degenerate (all-zero) matrix is passed. do i = 1 , n do a = 1 , n tdc ( i , a ) = tdc_in (( i - 1 ) * n + a ) end do end do if ( all ( abs ( tdc ) < 1.0e-30_dp )) call namd_state_tdc ( stas2 , dt_au , tdc ) ! 3) propagate amplitudes over electronic sub-steps; accumulate hop flux do isub = 1 , nsub call namd_propagate_coeff ( cr , ci , tdc , eabs , hsub ) call namd_accumulate_hop_prob ( cmhp , cr , ci , tdc , hsub ) end do call namd_finalize_hop_prob ( cmhp ) ! 4) decoherence (energy-based correction) ekin = namd_kinetic_energy ( vel , mass_au ) if ( decoherence == 1 ) & call namd_decoherence_edc ( cr , ci , eabs , active , ekin , dt_au , edc_c ) ! 5) fewest-switches hop + isotropic velocity rescaling call namd_fssh_decision ( cmhp , eabs , rand , thrshe , mass_au , vel , & active , hopped , target , blocked ) ! pack results back do i = 1 , n coef ( 2 * i - 1 ) = cr ( i ) coef ( 2 * i ) = ci ( i ) end do do a = 1 , nat velf ( 3 * a - 2 ) = vel ( 1 , a ) velf ( 3 * a - 1 ) = vel ( 2 , a ) velf ( 3 * a ) = vel ( 3 , a ) end do params ( 5 ) = real ( active , dp ) params ( 11 ) = merge ( 1.0_dp , 0.0_dp , hopped ) params ( 12 ) = real ( target , dp ) results = 0.0_dp results ( 1 : n * n ) = reshape ( cmhp , ( / n * n / )) results ( n * n + 1 ) = merge ( 1.0_dp , 0.0_dp , hopped ) results ( n * n + 2 ) = real ( target , dp ) results ( n * n + 3 ) = merge ( 1.0_dp , 0.0_dp , blocked ) results ( n * n + 4 ) = ekin results ( n * n + 5 ) = merge ( 1.0_dp , 0.0_dp , swapped ) deallocate ( tdc , cmhp , cr , ci , eabs , vel , mass_au , stas2 ) close ( iw ) end subroutine namd_hop end module namd_mod","tags":"","url":"sourcefile/namd.f90.html"},{"title":"qmat_cache.F90 – OpenQP Fortran API","text":"Source Code !> @brief Cached canonical orthogonalizer Q = S&#94;(-1/2) ! !> @details Q is needed by every initial guess and by the SCF setup; !>          without caching it is computed (an O(nbf&#94;3) eigendecomposition) !>          at least twice per run. The cache lives in the tagarray under !>          OQP_QMAT and is invalidated by int1e whenever the overlap !>          matrix is recomputed (new geometry or basis set). module qmat_cache use precision , only : dp implicit none private public get_qmat_cached contains !> @brief Return Q = S&#94;(-1/2), reusing the cached copy if available ! !> @param[in]  infos  OQP run information (holds the tagarray) !> @param[in]  smat   packed overlap matrix !> @param[out] qmat   canonical orthogonalizer, (nbf x nbf); !>                    columns beyond the rank are zero !> @param[in]  nbf    number of basis functions !> @param[out] qrnk   optional, rank of Q (number of linearly !>                    independent basis functions) subroutine get_qmat_cached ( infos , smat , qmat , nbf , qrnk ) use types , only : information use oqp_tagarray_driver use mathlib , only : matrix_invsqrt use , intrinsic :: iso_c_binding , only : c_int32_t implicit none type ( information ), intent ( inout ) :: infos real ( kind = dp ), intent ( in ) :: smat ( * ) real ( kind = dp ), intent ( out ) :: qmat ( nbf , * ) integer , intent ( in ) :: nbf integer , intent ( out ), optional :: qrnk character ( len =* ), parameter :: tags_qmat ( 1 ) = ( / character ( len = 80 ) :: OQP_QMAT / ) real ( kind = dp ), contiguous , pointer :: q_st (:,:) integer ( c_int32_t ) :: tag_id integer :: j if ( infos % dat % contains ( tags_qmat , tag_id )) then call tagarray_get_data ( infos % dat , OQP_QMAT , q_st ) if ( size ( q_st , 1 ) == nbf . and . size ( q_st , 2 ) == nbf ) then qmat (:, 1 : nbf ) = q_st if ( present ( qrnk )) then !         matrix_invsqrt zeroes the columns beyond the rank do j = nbf , 1 , - 1 if ( any ( qmat (:, j ) /= 0.0_dp )) exit end do qrnk = j end if return end if !     dimension mismatch (e.g. stale record): recompute below end if call matrix_invsqrt ( smat , qmat , nbf , qrnk = qrnk ) call infos % dat % alloc_or_die ( OQP_QMAT , ( / nbf , nbf / ), q_st , description = OQP_QMAT_comment ) q_st = qmat (:, 1 : nbf ) end subroutine get_qmat_cached end module qmat_cache","tags":"","url":"sourcefile/qmat_cache.f90.html"},{"title":"tdhf_lib.F90 – OpenQP Fortran API","text":"Source Code module tdhf_lib use , intrinsic :: ieee_arithmetic use precision , only : dp use int2_compute , only : int2_fock_data_t , int2_storage_t use basis_tools , only : basis_set use oqp_linalg real ( kind = dp ), parameter :: DAVIDSON_DENOMINATOR_FLOOR = 1.0e-8_dp type , extends ( int2_fock_data_t ) :: int2_td_data_t real ( kind = dp ), allocatable :: apb (:,:,:,:) real ( kind = dp ), allocatable :: amb (:,:,:,:) real ( kind = dp ), pointer :: d2 (:,:,:) => null () logical :: int_apb = . true . !< do A+B part logical :: int_amb = . false . !< do A-B part, needed for hybrid functionals logical :: tamm_dancoff = . false . !< Tamm-Dancoff approximation logical :: tamm_dancoff_coulomb = . false . !< Whetehr to includ Coulomb terms with TDA, not needed in SFDFT contains procedure :: parallel_start => int2_td_data_t_parallel_start procedure :: parallel_stop => int2_td_data_t_parallel_stop procedure :: init_screen => int2_td_data_t_init_screen procedure :: update => int2_td_data_t_update procedure :: clean => int2_td_data_t_clean end type type , extends ( int2_td_data_t ) :: int2_tdgrd_data_t contains procedure :: update => int2_tdgrd_data_t_update end type type , extends ( int2_fock_data_t ) :: int2_rpagrd_data_t real ( kind = dp ), allocatable :: hpp (:,:,:,:,:) ! H+[X+Y] real ( kind = dp ), allocatable :: hpt (:,:,:,:,:) ! H+[T] real ( kind = dp ), allocatable :: hmm (:,:,:,:,:) ! H-[X-Y] real ( kind = dp ), pointer :: xpy (:,:,:,:) => null () ! X+Y real ( kind = dp ), pointer :: xmy (:,:,:,:) => null () ! X-Y real ( kind = dp ), pointer :: t (:,:,:,:) => null () ! T integer :: np = 0 integer :: nm = 0 integer :: nt = 0 integer :: nspin = 0 integer :: nbf = 0 logical :: tamm_dancoff = . false . !< Tamm-Dancoff approximation contains procedure :: parallel_start => int2_rpagrd_data_t_parallel_start procedure :: parallel_stop => int2_rpagrd_data_t_parallel_stop procedure :: init_screen => int2_rpagrd_data_t_init_screen procedure :: update => int2_rpagrd_data_t_update procedure :: clean => int2_rpagrd_data_t_clean procedure , non_overridable :: hplus => int2_rpagrd_data_t_update_hplus procedure , non_overridable :: hminus => int2_rpagrd_data_t_update_hminus end type contains !############################################################################### subroutine int2_td_data_t_parallel_start ( this , basis , nthreads ) implicit none class ( int2_td_data_t ), target , intent ( inout ) :: this type ( basis_set ), intent ( in ) :: basis integer , intent ( in ) :: nthreads integer :: nbf , nsh nbf = basis % nbf this % fockdim = nbf * ( nbf + 1 ) / 2 this % nfocks = ubound ( this % d2 , size ( shape ( this % d2 ))) this % nthreads = nthreads nsh = basis % nshell if ( this % cur_pass == 1 ) then if ( allocated ( this % apb )) deallocate ( this % apb ) if ( allocated ( this % amb )) deallocate ( this % amb ) if ( allocated ( this % dsh )) deallocate ( this % dsh ) allocate ( this % apb ( nbf , nbf , this % nfocks , nthreads ), & this % amb ( nbf , nbf , this % nfocks , nthreads ), & this % dsh ( nsh , nsh ), & source = 0.0d0 ) end if call this % init_screen ( basis ) end subroutine !############################################################################### subroutine int2_td_data_t_parallel_stop ( this ) use mathlib , only : symmetrize_matrix implicit none integer :: flast , amblast , nbf , i class ( int2_td_data_t ), intent ( inout ) :: this if ( this % cur_pass /= this % num_passes ) return flast = size ( shape ( this % apb )) amblast = size ( shape ( this % amb )) nbf = ubound ( this % amb , 1 ) if ( this % nthreads /= 1 ) then this % apb (:,:,:, lbound ( this % apb , flast )) = sum ( this % apb , dim = flast ) this % amb (:,:,:, lbound ( this % amb , amblast )) = sum ( this % amb , dim = amblast ) end if call this % pe % allreduce ( this % apb (:,:,:, 1 ), & size ( this % apb (:,:,:, 1 ))) call this % pe % allreduce ( this % amb (:,:,:, 1 ), & size ( this % amb (:,:,:, 1 ))) do i = lbound ( this % apb , 3 ), ubound ( this % apb , 3 ) call symmetrize_matrix ( this % apb (:,:, i , 1 ), nbf ) end do this % nthreads = 1 end subroutine !############################################################################### subroutine int2_td_data_t_clean ( this ) implicit none class ( int2_td_data_t ), intent ( inout ) :: this deallocate ( this % apb ) deallocate ( this % amb ) deallocate ( this % dsh ) nullify ( this % d ) nullify ( this % d2 ) end subroutine !############################################################################### subroutine int2_td_data_t_init_screen ( this , basis ) implicit none class ( int2_td_data_t ), target , intent ( inout ) :: this type ( basis_set ), intent ( in ) :: basis !   Form shell density call shltd ( this % dsh , this % d2 , basis ) this % max_den = maxval ( abs ( this % dsh )) end subroutine !############################################################################### subroutine int2_td_data_t_update ( this , buf ) implicit none class ( int2_td_data_t ), intent ( inout ) :: this type ( int2_storage_t ), intent ( inout ) :: buf integer :: i , j , k , l , n real ( kind = dp ) :: xval1 , cval2 , val2c , cval4 , & val , val1 , val4c integer :: ifock , mythread xval1 = this % scale_exchange cval2 = 2 * this % scale_coulomb cval4 = 4 * this % scale_coulomb mythread = buf % thread_id associate (& apb => this % apb (:,:,:, mythread ), & amb => this % amb (:,:,:, mythread ), & d2 => this % d2 & ) do ifock = 1 , this % nfocks do n = 1 , buf % ncur i = buf % ids ( 1 , n ) j = buf % ids ( 2 , n ) k = buf % ids ( 3 , n ) l = buf % ids ( 4 , n ) val = buf % ints ( n ) if ( this % tamm_dancoff ) then val1 = val * xval1 val2c = val * cval2 !A amb ( i , k , ifock ) = amb ( i , k , ifock ) - val1 * d2 ( j , l , ifock ) amb ( k , i , ifock ) = amb ( k , i , ifock ) - val1 * d2 ( l , j , ifock ) amb ( i , l , ifock ) = amb ( i , l , ifock ) - val1 * d2 ( j , k , ifock ) amb ( l , i , ifock ) = amb ( l , i , ifock ) - val1 * d2 ( k , j , ifock ) amb ( j , k , ifock ) = amb ( j , k , ifock ) - val1 * d2 ( i , l , ifock ) amb ( k , j , ifock ) = amb ( k , j , ifock ) - val1 * d2 ( l , i , ifock ) amb ( j , l , ifock ) = amb ( j , l , ifock ) - val1 * d2 ( i , k , ifock ) amb ( l , j , ifock ) = amb ( l , j , ifock ) - val1 * d2 ( k , i , ifock ) if ( this % tamm_dancoff_coulomb ) then amb ( i , j , ifock ) = amb ( i , j , ifock ) + val2c * ( d2 ( k , l , ifock ) + d2 ( l , k , ifock )) amb ( j , i , ifock ) = amb ( j , i , ifock ) + val2c * ( d2 ( k , l , ifock ) + d2 ( l , k , ifock )) amb ( k , l , ifock ) = amb ( k , l , ifock ) + val2c * ( d2 ( i , j , ifock ) + d2 ( j , i , ifock )) amb ( l , k , ifock ) = amb ( l , k , ifock ) + val2c * ( d2 ( i , j , ifock ) + d2 ( j , i , ifock )) end if else val1 = val * xval1 val4c = val * cval4 if ( this % int_apb ) then ! A+B ! Coulomb apb ( i , j , ifock ) = apb ( i , j , ifock ) + val4c * ( d2 ( k , l , ifock ) + d2 ( l , k , ifock )) apb ( k , l , ifock ) = apb ( k , l , ifock ) + val4c * ( d2 ( i , j , ifock ) + d2 ( j , i , ifock )) ! Exchange apb ( i , k , ifock ) = apb ( i , k , ifock ) - val1 * ( d2 ( j , l , ifock ) + d2 ( l , j , ifock )) apb ( i , l , ifock ) = apb ( i , l , ifock ) - val1 * ( d2 ( j , k , ifock ) + d2 ( k , j , ifock )) apb ( j , k , ifock ) = apb ( j , k , ifock ) - val1 * ( d2 ( i , l , ifock ) + d2 ( l , i , ifock )) apb ( j , l , ifock ) = apb ( j , l , ifock ) - val1 * ( d2 ( i , k , ifock ) + d2 ( k , i , ifock )) end if if ( this % int_amb ) then ! A-B amb ( i , k , ifock ) = amb ( i , k , ifock ) + val1 * ( d2 ( l , j , ifock ) - d2 ( j , l , ifock )) amb ( i , l , ifock ) = amb ( i , l , ifock ) + val1 * ( d2 ( k , j , ifock ) - d2 ( j , k , ifock )) amb ( j , k , ifock ) = amb ( j , k , ifock ) + val1 * ( d2 ( l , i , ifock ) - d2 ( i , l , ifock )) amb ( j , l , ifock ) = amb ( j , l , ifock ) + val1 * ( d2 ( k , i , ifock ) - d2 ( i , k , ifock )) amb ( k , i , ifock ) = amb ( k , i , ifock ) - val1 * ( d2 ( l , j , ifock ) - d2 ( j , l , ifock )) amb ( l , i , ifock ) = amb ( l , i , ifock ) - val1 * ( d2 ( k , j , ifock ) - d2 ( j , k , ifock )) amb ( k , j , ifock ) = amb ( k , j , ifock ) - val1 * ( d2 ( l , i , ifock ) - d2 ( i , l , ifock )) amb ( l , j , ifock ) = amb ( l , j , ifock ) - val1 * ( d2 ( k , i , ifock ) - d2 ( i , k , ifock )) end if end if end do end do end associate buf % ncur = 0 end subroutine !############################################################################### subroutine int2_tdgrd_data_t_update ( this , buf ) implicit none class ( int2_tdgrd_data_t ), intent ( inout ) :: this type ( int2_storage_t ), intent ( inout ) :: buf integer :: i , j , k , l , n real ( kind = dp ) :: xval1 , xval2 , & val , val1 , val2 integer :: mythread xval1 = 1 * this % scale_exchange xval2 = 2 * this % scale_coulomb mythread = buf % thread_id associate (& apb => this % apb (:,:,:, mythread ), & amb => this % amb (:,:,:, mythread ), & d2 => this % d2 & ) do n = 1 , buf % ncur i = buf % ids ( 1 , n ) j = buf % ids ( 2 , n ) k = buf % ids ( 3 , n ) l = buf % ids ( 4 , n ) val = buf % ints ( n ) val1 = val * xval1 val2 = val * xval2 if ( this % int_apb ) then ! A+B ! Coulomb apb ( i , j , 1 ) = apb ( i , j , 1 ) + val2 * ( d2 ( k , l , 1 ) + d2 ( l , k , 1 ) + d2 ( k , l , 2 ) + d2 ( l , k , 2 )) apb ( k , l , 1 ) = apb ( k , l , 1 ) + val2 * ( d2 ( i , j , 1 ) + d2 ( j , i , 1 ) + d2 ( i , j , 2 ) + d2 ( j , i , 2 )) apb ( i , j , 2 ) = apb ( i , j , 2 ) + val2 * ( d2 ( k , l , 1 ) + d2 ( l , k , 1 ) + d2 ( k , l , 2 ) + d2 ( l , k , 2 )) apb ( k , l , 2 ) = apb ( k , l , 2 ) + val2 * ( d2 ( i , j , 1 ) + d2 ( j , i , 1 ) + d2 ( i , j , 2 ) + d2 ( j , i , 2 )) !         ! Exchange apb ( i , k , 1 ) = apb ( i , k , 1 ) - val1 * ( d2 ( j , l , 1 ) + d2 ( l , j , 1 )) apb ( i , l , 1 ) = apb ( i , l , 1 ) - val1 * ( d2 ( j , k , 1 ) + d2 ( k , j , 1 )) apb ( j , k , 1 ) = apb ( j , k , 1 ) - val1 * ( d2 ( i , l , 1 ) + d2 ( l , i , 1 )) apb ( j , l , 1 ) = apb ( j , l , 1 ) - val1 * ( d2 ( i , k , 1 ) + d2 ( k , i , 1 )) ! apb ( i , k , 2 ) = apb ( i , k , 2 ) - val1 * ( d2 ( j , l , 2 ) + d2 ( l , j , 2 )) apb ( i , l , 2 ) = apb ( i , l , 2 ) - val1 * ( d2 ( j , k , 2 ) + d2 ( k , j , 2 )) apb ( j , k , 2 ) = apb ( j , k , 2 ) - val1 * ( d2 ( i , l , 2 ) + d2 ( l , i , 2 )) apb ( j , l , 2 ) = apb ( j , l , 2 ) - val1 * ( d2 ( i , k , 2 ) + d2 ( k , i , 2 )) end if if ( this % int_amb ) then ! A-B amb ( i , k , 1 ) = amb ( i , k , 1 ) + val1 * ( d2 ( l , j , 1 ) - d2 ( j , l , 1 )) amb ( i , l , 1 ) = amb ( i , l , 1 ) + val1 * ( d2 ( k , j , 1 ) - d2 ( j , k , 1 )) amb ( j , k , 1 ) = amb ( j , k , 1 ) + val1 * ( d2 ( l , i , 1 ) - d2 ( i , l , 1 )) amb ( j , l , 1 ) = amb ( j , l , 1 ) + val1 * ( d2 ( k , i , 1 ) - d2 ( i , k , 1 )) amb ( k , i , 1 ) = amb ( k , i , 1 ) - val1 * ( d2 ( l , j , 1 ) - d2 ( j , l , 1 )) amb ( l , i , 1 ) = amb ( l , i , 1 ) - val1 * ( d2 ( k , j , 1 ) - d2 ( j , k , 1 )) amb ( k , j , 1 ) = amb ( k , j , 1 ) - val1 * ( d2 ( l , i , 1 ) - d2 ( i , l , 1 )) amb ( l , j , 1 ) = amb ( l , j , 1 ) - val1 * ( d2 ( k , i , 1 ) - d2 ( i , k , 1 )) end if end do end associate buf % ncur = 0 end subroutine !############################################################################### !############################################################################### subroutine shltd ( dsh , da , basis ) use precision , only : dp use types , only : information use basis_tools , only : basis_set implicit none type ( basis_set ), intent ( in ) :: basis real ( kind = dp ), intent ( out ) :: dsh (:,:) real ( kind = dp ), intent ( in ), dimension (:,:,:) :: da integer :: ish , jsh , maxi , maxj , mini , & minj !   RHF do ish = 1 , basis % nshell mini = basis % ao_offset ( ish ) maxi = mini + basis % naos ( ish ) - 1 do jsh = 1 , ish minj = basis % ao_offset ( jsh ) maxj = minj + basis % naos ( jsh ) - 1 dsh ( ish , jsh ) = maxval ( abs ( da ( minj : maxj , mini : maxi ,:))) dsh ( jsh , ish ) = dsh ( ish , jsh ) end do end do end subroutine shltd subroutine inivec ( eiga , eigb , bvec_mo , xm , & nocca , noccb , nvec ) use precision , only : dp implicit none real ( kind = dp ), intent ( in ), dimension (:) :: eiga , eigb real ( kind = dp ), intent ( out ), dimension (:,:) :: bvec_mo real ( kind = dp ), intent ( out ), dimension (:) :: xm integer , intent ( in ) :: nocca , noccb integer , intent ( in ) :: nvec integer :: i , ij , j , k , nbf , mxvec integer :: itmp ( nvec ) real ( kind = dp ) :: xtmp ( nvec ) nbf = ubound ( eiga , 1 ) mxvec = ubound ( bvec_mo , 2 ) ! -- Set xm(xvec_dim) do j = noccb + 1 , nbf do i = 1 , nocca ij = ( j - noccb - 1 ) * nocca + i xm ( ij ) = eigb ( j ) - eiga ( i ) end do end do !   Find indices of the first `nvec` smallest values in the `xm` array itmp = 0 ! indices xtmp = huge ( 1.0d0 ) ! values do i = 1 , ubound ( xm , 1 ) do j = 1 , nvec if ( xtmp ( j ) > xm ( i )) exit end do if ( j <= nvec ) then ! new small value found, insert it into temporary arrays xtmp ( j + 1 : nvec ) = xtmp ( j : nvec - 1 ) itmp ( j + 1 : nvec ) = itmp ( j : nvec - 1 ) xtmp ( j ) = xm ( i ) itmp ( j ) = i end if end do ! -- Get initial vectors: bvec(xvec_dim,nvec) bvec_mo = 0.0_dp do k = 1 , nvec bvec_mo ( itmp ( k ), k ) = 1.0_dp end do end subroutine inivec subroutine iatogen ( pv , av , nocca , noccb ) use precision , only : dp implicit none real ( kind = dp ), intent ( in ), contiguous , target :: pv (:) real ( kind = dp ), intent ( out ) :: av (:,:) integer , intent ( in ) :: nocca , noccb real ( kind = dp ), pointer :: ppv (:,:) integer :: nbf nbf = ubound ( av , 1 ) ppv ( 1 : nocca , noccb + 1 : nbf ) => pv (:) av = 0.0_dp av ( 1 : nocca , noccb + 1 : nbf ) = ppv ( 1 : nocca , noccb + 1 : nbf ) end subroutine iatogen subroutine mntoia ( pao , pmo , va , vb , nocca , noccb ) use precision , only : dp implicit none real ( kind = dp ), intent ( in ), dimension (:,:) :: pao real ( kind = dp ), intent ( out ), dimension ( * ) :: pmo real ( kind = dp ), intent ( in ), target , dimension (:,:) :: va , vb integer , intent ( in ) :: nocca , noccb integer :: nbf real ( kind = dp ), allocatable :: scr (:,:) real ( kind = dp ), pointer :: vap (:,:), vbp (:,:) nbf = ubound ( pao , 1 ) allocate ( scr ( nocca , nbf )) vap => va (:, 1 : nocca ) vbp => vb (:, noccb + 1 :) call dgemm ( 't' , 'n' , nocca , nbf , nbf , & 1.0_dp , vap , nbf , pao , nbf , & 0.0_dp , scr , nocca ) call dgemm ( 'n' , 'n' , nocca , nbf - noccb , nbf , & 1.0_dp , scr , nocca , vbp , nbf , & 0.0_dp , pmo , nocca ) deallocate ( scr ) end subroutine mntoia subroutine rparedms ( b , ap_b , am_b , xm_p , xm_m , nvec , tamm_dancoff ) use precision , only : dp implicit none real ( kind = dp ), intent ( in ), dimension (:,:) :: b real ( kind = dp ), intent ( in ), dimension (:,:) :: am_b , ap_b real ( kind = dp ), intent ( out ), dimension (:,:) :: xm_m , xm_p integer , intent ( in ) :: nvec logical :: tamm_dancoff integer :: xvec_dim xvec_dim = ubound ( b , 1 ) if ( tamm_dancoff ) then call dgemm ( 't' , 'n' , nvec , nvec , xvec_dim , & 1.0_dp , b , xvec_dim , ap_b , xvec_dim , & 0.0_dp , xm_p , nvec ) else call dgemm ( 't' , 'n' , nvec , nvec , xvec_dim , & 1.0_dp , b , xvec_dim , ap_b , xvec_dim , & 0.0_dp , xm_p , nvec ) call dgemm ( 't' , 'n' , nvec , nvec , xvec_dim , & 1.0_dp , b , xvec_dim , am_b , xvec_dim , & 0.0_dp , xm_m , nvec ) end if end subroutine rparedms !> @brief Diagonalize small reduced RPA matrix subroutine rpaeig ( ee , vl , vr , apb , amb , scr , tamm_dancoff ) use precision , only : dp use eigen , only : diag_symm_packed implicit none real ( kind = dp ), intent ( out ), dimension (:) :: ee real ( kind = dp ), intent ( out ), dimension (:,:) :: vl , vr real ( kind = dp ), intent ( in ), dimension (:,:) :: apb real ( kind = dp ), intent ( inout ), dimension (:,:) :: amb real ( kind = dp ), intent ( inout ), dimension (:) :: scr logical , intent ( in ) :: tamm_dancoff integer :: ierr , j , nvec nvec = ubound ( vl , 2 ) if ( tamm_dancoff ) then !   Diagonailze A: VR if ( nvec == 1 ) then ee ( 1 ) = vr ( 1 , 1 ) vr ( 1 , 1 ) = 1.0_dp else call dtrttp ( 'u' , nvec , apb , nvec , scr , ierr ) call diag_symm_packed ( 1 , nvec , nvec , nvec , scr , ee , vr , ierr ) end if return end if !   sqrt(A-B) if ( nvec == 1 ) then amb ( 1 , 1 ) = sqrt ( amb ( 1 , 1 )) else call dtrttp ( 'u' , nvec , amb , nvec , scr , ierr ) call diag_symm_packed ( 1 , nvec , nvec , nvec , scr , ee , vr , ierr ) ee ( 1 : nvec ) = sign ( sqrt ( abs ( ee ( 1 : nvec ))), ee ( 1 : nvec )) do j = 1 , nvec vl (:, j ) = vr (:, j ) * ee ( j ) end do call dgemm ( 'n' , 't' , nvec , nvec , nvec , & 1.0_dp , vr , nvec , vl , nvec , & 0.0_dp , amb , nvec ) end if !   Form sqrt(A-B)*(A+B)*sqrt(A-B) !   (A+B)*sqrt(A-B) : VL call dgemm ( 'n' , 'n' , nvec , nvec , nvec , & 1.0_dp , apb , nvec , amb , nvec , & 0.0_dp , vl , nvec ) !   sqrt(A-B)*(A+B)*sqrt(A-B) : VR call dgemm ( 'n' , 'n' , nvec , nvec , nvec , & 1.0_dp , amb , nvec , vl , nvec , & 0.0_dp , vr , nvec ) !   Diagonailze sqrt(A-B)*(A+B)*sqrt(A-B) : VR if ( nvec == 1 ) then ee ( 1 ) = vr ( 1 , 1 ) vl ( 1 , 1 ) = 1.0_dp else call dtrttp ( 'u' , nvec , vr , nvec , scr , ierr ) call diag_symm_packed ( 1 , nvec , nvec , nvec , scr , ee , vl , ierr ) end if !   Current vector VL is sqrt(1/(A-B)))|X+Y>. !   VL into right eigenvector  VR = |X+Y> call dgemm ( 'n' , 'n' , nvec , nvec , nvec , & 1.0_dp , amb , nvec , vl , nvec , & 0.0_dp , vr , nvec ) !   Left eigenvector   VL = = 1/E (A+B)|X+Y> call dgemm ( 'n' , 'n' , nvec , nvec , nvec , & 1.0_dp , apb , nvec , vr , nvec , & 0.0_dp , vl , nvec ) do j = 1 , nvec vl ( 1 : nvec , j ) = vl ( 1 : nvec , j ) / sign ( sqrt ( abs ( ee ( j ))), ee ( j )) end do end subroutine rpaeig !> @brief Normalize `V1` and `V2` by biorthogonality condition subroutine rpavnorm ( vr , vl , tamm_dancoff ) use precision , only : dp implicit none real ( kind = dp ), intent ( out ), dimension (:,:) :: vr , vl logical , intent ( in ) :: tamm_dancoff real ( kind = dp ) :: scal , vrl , vrr integer :: ivec , nvec nvec = ubound ( vl , 2 ) if ( tamm_dancoff ) then do ivec = 1 , nvec vrr = dot_product ( vr (:, ivec ), vr (:, ivec )) scal = sqrt ( 1.0_dp / vrr ) vr (:, ivec ) = vr (:, ivec ) * scal end do else do ivec = 1 , nvec vrl = dot_product ( vr (:, ivec ), vl ( 1 : nvec , ivec )) scal = sqrt ( 1.0D+00 / vrl ) vr (:, ivec ) = vr (:, ivec ) * scal vl (:, ivec ) = vl (:, ivec ) * scal end do end if end subroutine rpavnorm !> @brief Remove negative eigenvalues subroutine rpaechk ( ee , nvec , ndsr , imax , tamm_dancoff ) use precision , only : dp implicit none real ( kind = dp ), intent ( inout ), dimension (:) :: ee integer , intent ( in ) :: nvec , ndsr integer , intent ( inout ) :: imax logical , intent ( in ) :: tamm_dancoff ! Number of negative eigenvalues : imax imax = count ( ee ( 1 : nvec ) < 0.0_dp ) if (. not . tamm_dancoff ) ee ( 1 : ndsr ) = sqrt ( abs ( ee ( 1 : ndsr ))) end subroutine rpaechk !> @brief Print current excitation energies and errors subroutine rpaprint ( ee , err , cnvtol , iter , imax , ndsr , do_neg ) use precision , only : dp use physical_constants , only : UNITS_EV use io_constants , only : iw implicit none real ( kind = dp ), intent ( in ) :: ee (:) real ( kind = dp ), intent ( in ) :: cnvtol real ( kind = dp ), intent ( in ) :: err (:) integer , intent ( in ) :: iter integer , intent ( in ) :: imax integer , intent ( in ) :: ndsr logical , optional :: do_neg integer :: istat logical :: neg integer :: first neg = . false . if ( present ( do_neg )) neg = do_neg write ( * , fmt = '(/,4X,\"Davidson iteration #\",I4)' ) iter if ( imax /= 0. and .. not . neg ) write ( * , '(4X,\"Number of negative eigenvalues =\",I4)' ) imax first = imax + 1 if ( neg ) first = 1 do istat = 1 , ndsr write ( * , fmt = '(4X,\"State \",I4, & &3x,\"E =\",F12.6,\" eV\",& &4x,\"err. =\",F10.6)' ) & istat , ee ( istat ) / UNITS_EV , err ( istat ) end do write ( * , '(10X,\"Max error =\",1X,1P,E10.3,1X,\"/\",1P,E10.3)' ) maxval ( err ( first : ndsr )), cnvtol call flush ( iw ) end subroutine rpaprint !> @brief Expand reduced vectors to real size space subroutine rpaexpndv ( vr , vl , vro , vlo , br , bl , ndsr , tamm_dancoff ) use precision , only : dp implicit none real ( kind = dp ), intent ( in ) :: vr (:,:), vl (:,:) real ( kind = dp ), intent ( out ) :: vro (:,:), vlo (:,:) real ( kind = dp ), intent ( in ) :: br (:,:), bl (:,:) integer , intent ( in ) :: ndsr logical , intent ( in ) :: tamm_dancoff integer :: xvec_dim integer :: nvec nvec = ubound ( vr , 2 ) xvec_dim = ubound ( vro , 1 ) call dgemm ( 'n' , 'n' , xvec_dim , ndsr , nvec , & 1.0_dp , br , xvec_dim , vr , nvec , & 0.0_dp , vro , xvec_dim ) if ( tamm_dancoff ) then vlo (:, 1 : ndsr ) = vro (:, 1 : ndsr ) else call dgemm ( 'n' , 'n' , xvec_dim , ndsr , nvec , & 1.0_dp , bl , xvec_dim , vl , nvec , & 0.0_dp , vlo , xvec_dim ) end if end subroutine rpaexpndv !> @brief Construct residual vectors and check convergence subroutine rparesvec ( q , w_l , w_r , v_l , v_r , ee , abd , & ndsr , errors , tol , imax , tamm_dancoff ) use precision , only : dp implicit none real ( kind = dp ), intent ( inout ), dimension (:,:) :: w_l , w_r , v_l , v_r real ( kind = dp ), intent ( out ), & dimension ( ubound ( w_l , 1 ), ndsr , * ) :: q real ( kind = dp ), intent ( in ), dimension (:) :: ee real ( kind = dp ), intent ( in ), dimension (:) :: abd integer , intent ( in ) :: ndsr real ( kind = dp ), intent ( inout ) :: errors (:) real ( kind = dp ), intent ( in ) :: tol integer , intent ( in ) :: imax logical :: tamm_dancoff real ( kind = dp ) :: er_l , er_r integer :: ivec , xvec_dim xvec_dim = ubound ( w_l , 1 ) !   Residual vector W_l and W_r do ivec = 1 , ndsr w_r ( 1 : xvec_dim , ivec ) = w_r ( 1 : xvec_dim , ivec ) - ee ( ivec ) * v_r ( 1 : xvec_dim , ivec ) end do if (. not . tamm_dancoff ) then do ivec = 1 , ndsr w_l ( 1 : xvec_dim , ivec ) = w_l ( 1 : xvec_dim , ivec ) - ee ( ivec ) * v_l ( 1 : xvec_dim , ivec ) end do end if !   Norms of W errors = 0.0_dp if ( tamm_dancoff ) then do ivec = imax + 1 , ndsr errors ( ivec ) = dot_product ( w_r (:, ivec ), w_r (:, ivec )) if (. not . ieee_is_finite ( errors ( ivec ))) then write ( * , '(4X,\"Non-finite Davidson residual detected\")' ) write ( * , '(4X,\"State#=\",I4)' ) ivec q (:, ivec , 1 ) = 0.0_dp cycle end if if ( errors ( ivec ) > 1.0_dp ) then write ( * , '(4X,\"Large error detected\")' ) write ( * , '(4X,\"State#=\",I4)' ) ivec write ( * , '(4X,\"Error right =\",1X,1P,E10.3)' ) errors ( ivec ) errors ( ivec ) = 0.0_dp end if !       Get new vectors Q if ( errors ( ivec ) > tol ) then call apply_davidson_preconditioner ( q (:, ivec , 1 ), w_r (:, ivec ), ee ( ivec ), abd ) if ( any (. not . ieee_is_finite ( q (:, ivec , 1 )))) q (:, ivec , 1 ) = 0.0_dp else q (:, ivec , 1 ) = 0.0_dp end if end do else do ivec = imax + 1 , ndsr er_l = dot_product ( w_l (:, ivec ), w_l (:, ivec )) er_r = dot_product ( w_r (:, ivec ), w_r (:, ivec )) errors ( ivec ) = max ( er_l , er_r ) if (. not . ieee_is_finite ( errors ( ivec ))) then write ( * , '(4X,\"Non-finite Davidson residual detected\")' ) write ( * , '(4X,\"State#=\",I4)' ) ivec q (:, ivec , 1 : 2 ) = 0.0_dp cycle end if if ( errors ( ivec ) > 1.0_dp ) then write ( * , '(4X,\"Large error detected\")' ) write ( * , '(4X,\"State#=\",I4)' ) ivec write ( * , '(4X,\"Error left/right =\",1X,1P,E10.3,\"/\",1X,1P,E10.3)' ) er_l , er_r errors ( ivec ) = 0.0_dp end if !       Get new vectors Q if ( errors ( ivec ) > tol ) then call apply_davidson_preconditioner ( q (:, ivec , 1 ), w_l (:, ivec ), ee ( ivec ), abd ) call apply_davidson_preconditioner ( q (:, ivec , 2 ), w_r (:, ivec ), ee ( ivec ), abd ) if ( any (. not . ieee_is_finite ( q (:, ivec , 1 )))) q (:, ivec , 1 ) = 0.0_dp if ( any (. not . ieee_is_finite ( q (:, ivec , 2 )))) q (:, ivec , 2 ) = 0.0_dp else q (:, ivec , 1 : 2 ) = 0.0_dp end if end do end if end subroutine rparesvec subroutine apply_davidson_preconditioner ( qout , residual , energy , abd ) use precision , only : dp implicit none real ( kind = dp ), intent ( out ) :: qout (:) real ( kind = dp ), intent ( in ) :: residual (:) real ( kind = dp ), intent ( in ) :: energy real ( kind = dp ), intent ( in ) :: abd (:) integer :: ii real ( kind = dp ) :: denom do ii = 1 , ubound ( qout , 1 ) denom = energy - abd ( ii ) if (. not . davidson_safe_denominator ( denom )) then if (. not . ieee_is_finite ( denom )) then qout ( ii ) = 0.0_dp cycle end if if ( abs ( denom ) < DAVIDSON_DENOMINATOR_FLOOR ) then denom = merge ( DAVIDSON_DENOMINATOR_FLOOR , - DAVIDSON_DENOMINATOR_FLOOR , denom >= 0.0_dp ) end if end if qout ( ii ) = residual ( ii ) / denom if (. not . ieee_is_finite ( qout ( ii ))) qout ( ii ) = 0.0_dp end do end subroutine apply_davidson_preconditioner logical function davidson_safe_denominator ( denom ) use precision , only : dp implicit none real ( kind = dp ), intent ( in ) :: denom davidson_safe_denominator = ieee_is_finite ( denom ) . and . abs ( denom ) >= DAVIDSON_DENOMINATOR_FLOOR end function davidson_safe_denominator !> @brief Orthonormalize q(xvec_dim,ndsr*2) and append to bvec subroutine rpanewb ( ndsr , bvec , q , novec , nvec , ick , tamm_dancoff ) use precision , only : dp implicit none integer , intent ( in ) :: ndsr real ( kind = dp ), intent ( out ), dimension (:,:) :: bvec real ( kind = dp ), intent ( inout ), dimension (:,:) :: q integer , intent ( inout ) :: novec , nvec integer , intent ( out ) :: ick logical , intent ( in ) :: tamm_dancoff real ( kind = dp ) :: bq , fnorm , max_abs_overlap integer :: istat , k , ms , ndsrt , mxvec logical :: bad_vector real ( kind = dp ), parameter :: norm_threshold = 1.0D-09 real ( kind = dp ), parameter :: reorth_threshold = 1.0D-08 mxvec = ubound ( bvec , 2 ) !   Save nvec as novec novec = nvec ick = 0 !   Modified Gram-Schmidt orthonormalization ndsrt = ndsr * 2 if ( tamm_dancoff ) ndsrt = ndsr do k = 1 , ndsrt if ( any (. not . ieee_is_finite ( q (:, k )))) cycle max_abs_overlap = 0.0_dp bad_vector = . false . !     MGS: orthonormalize next vector w.r.t. all !     previous vectors do istat = 1 , nvec bq = dot_product ( bvec (:, istat ), q (:, k )) if (. not . ieee_is_finite ( bq )) then bad_vector = . true . exit end if max_abs_overlap = max ( max_abs_overlap , abs ( bq )) q (:, k ) = q (:, k ) - bq * bvec (:, istat ) end do if ( bad_vector ) cycle if ( max_abs_overlap > reorth_threshold ) then ! Davidson MGS reorthogonalization pass do istat = 1 , nvec bq = dot_product ( bvec (:, istat ), q (:, k )) if (. not . ieee_is_finite ( bq )) then bad_vector = . true . exit end if q (:, k ) = q (:, k ) - bq * bvec (:, istat ) end do if ( bad_vector ) cycle end if fnorm = norm2 ( q (:, k )) !     Possible linear dependency, skip this vector if (. not . ieee_is_finite ( fnorm )) cycle if ( fnorm < norm_threshold ) cycle if ( nvec == mxvec ) then !       Error termination, no space left for new vectors ick = 2 return end if !     Append new b vector nvec = nvec + 1 bvec (:, nvec ) = q (:, k ) / fnorm end do !   Error termination, no vectors added ms = nvec - novec if ( ms == 0 ) ick = 3 end subroutine rpanewb !> @breif Add (E_a-E_i)*Z_ai to Pmo subroutine esum ( e , pmo , z , nocc , ivec ) use precision , only : dp implicit none real ( kind = dp ), intent ( in ) :: e (:) real ( kind = dp ), intent ( inout ) :: pmo (:,:) real ( kind = dp ), intent ( in ) :: z (:,:) integer , intent ( in ) :: nocc , ivec integer :: i , ij , j , nbf nbf = ubound ( e , 1 ) do j = nocc + 1 , nbf do i = 1 , nocc ij = ( j - nocc - 1 ) * nocc + i pmo ( ij , ivec ) = pmo ( ij , ivec ) + ( e ( j ) - e ( i )) * z ( ij , ivec ) end do end do end subroutine esum !> @brief Compute unrelaxed difference density matrix for R-TDDFT subroutine tdhf_unrelaxed_density ( xmy , xpy , mo , t , nocc , tda ) use precision , only : dp use mathlib , only : orthogonal_transform use mathlib , only : pack_matrix implicit none real ( kind = dp ), intent ( in ) :: xpy ( * ), xmy ( * ) real ( kind = dp ), intent ( in ) :: mo (:,:) real ( kind = dp ), intent ( out ) :: t ( * ) logical , intent ( in ) :: tda integer , intent ( in ) :: nocc integer :: nbf , nvir real ( kind = dp ), allocatable :: t_mo (:,:), t_ao (:,:), scr (:,:) nbf = ubound ( mo , 1 ) allocate ( t_mo ( nbf , nbf ), t_ao ( nbf , nbf ), scr ( nbf , nbf ), source = 0.0_dp ) nvir = nbf - nocc if ( tda ) then ! vir->vib block call dgemm ( 't' , 'n' , nvir , nvir , nocc , & 1.0d0 , xpy , nocc , & xpy , nocc , & 0.0d0 , t_mo ( nocc + 1 :, nocc + 1 ), nbf ) ! occ->occ block call dgemm ( 'n' , 't' , nocc , nocc , nvir , & - 1.0d0 , xpy , nocc , & xpy , nocc , & 0.0d0 , t_mo , nbf ) else ! vir->vib block call dgemm ( 't' , 'n' , nvir , nvir , nocc , & 0.5d0 , xpy , nocc , & xpy , nocc , & 0.0d0 , t_mo ( nocc + 1 :, nocc + 1 ), nbf ) call dgemm ( 't' , 'n' , nvir , nvir , nocc , & 0.5d0 , xmy , nocc , & xmy , nocc , & 1.0d0 , t_mo ( nocc + 1 :, nocc + 1 ), nbf ) ! occ->occ block call dgemm ( 'n' , 't' , nocc , nocc , nvir , & - 0.5d0 , xpy , nocc , & xpy , nocc , & 0.0d0 , t_mo , nbf ) call dgemm ( 'n' , 't' , nocc , nocc , nvir , & - 0.5d0 , xmy , nocc , & xmy , nocc , & 1.0d0 , t_mo , nbf ) endif ! MO->AO call orthogonal_transform ( 't' , nbf , mo , t_mo , t_ao , scr ) call pack_matrix ( t_ao , t ( 1 :( nbf + 1 ) * nbf / 2 ) ) end subroutine !############################################################################### subroutine int2_rpagrd_data_t_parallel_start ( this , basis , nthreads ) implicit none class ( int2_rpagrd_data_t ), target , intent ( inout ) :: this type ( basis_set ), intent ( in ) :: basis integer , intent ( in ) :: nthreads integer :: nbf , nsh this % nbf = basis % nbf nbf = this % nbf this % np = 0 this % nm = 0 this % nt = 0 if ( associated ( this % xpy )) this % np = ubound ( this % xpy , size ( shape ( this % xpy ))) if ( associated ( this % xmy )) this % nm = ubound ( this % xmy , size ( shape ( this % xmy ))) if ( associated ( this % t )) this % nt = ubound ( this % t , size ( shape ( this % t ))) this % nthreads = nthreads nsh = basis % nshell if ( this % cur_pass == 1 ) then if ( allocated ( this % hpp )) deallocate ( this % hpp ) if ( allocated ( this % hpt )) deallocate ( this % hpt ) if ( allocated ( this % hmm )) deallocate ( this % hmm ) if ( allocated ( this % dsh )) deallocate ( this % dsh ) if ( this % np > 0 ) & allocate ( this % hpp ( nbf , nbf , this % nspin , this % np , nthreads ), & source = 0.0d0 ) if ( this % nt > 0 ) & allocate ( this % hpt ( nbf , nbf , this % nspin , this % nt , nthreads ), & source = 0.0d0 ) if ( this % nm > 0 ) & allocate ( this % hmm ( nbf , nbf , this % nspin , this % nm , nthreads ), & source = 0.0d0 ) allocate ( this % dsh ( nsh , nsh ), source = 0.0d0 ) end if call this % init_screen ( basis ) end subroutine !############################################################################### subroutine int2_rpagrd_data_t_parallel_stop ( this ) implicit none integer :: plast , tlast , mlast , nbf class ( int2_rpagrd_data_t ), intent ( inout ) :: this if ( this % cur_pass /= this % num_passes ) return plast = size ( shape ( this % hpp )) tlast = size ( shape ( this % hpt )) mlast = size ( shape ( this % hmm )) nbf = this % nbf if ( this % nthreads /= 1 ) then if ( this % np > 0 ) this % hpp (:,:,:,:, lbound ( this % hpp , plast )) = sum ( this % hpp , dim = plast ) if ( this % nt > 0 ) this % hpt (:,:,:,:, lbound ( this % hpt , tlast )) = sum ( this % hpt , dim = tlast ) if ( this % nm > 0 ) this % hmm (:,:,:,:, lbound ( this % hmm , mlast )) = sum ( this % hmm , dim = mlast ) this % nthreads = 1 end if if ( this % np > 0 ) call this % pe % allreduce ( this % hpp (:,:,:,:, 1 ),& size ( this % hpp (:,:,:,:, 1 ))) if ( this % nt > 0 ) call this % pe % allreduce ( this % hpt (:,:,:,:, 1 ),& size ( this % hpt (:,:,:,:, 1 ))) if ( this % nm > 0 ) call this % pe % allreduce ( this % hmm (:,:,:,:, 1 ),& size ( this % hmm (:,:,:,:, 1 ))) if ( this % cur_pass == this % num_passes ) then if ( this % np > 0 ) call symmetrize_matrices ( this % hpp , nbf , this % np * this % nspin ) if ( this % nt > 0 ) call symmetrize_matrices ( this % hpt , nbf , this % nt * this % nspin ) end if end subroutine !############################################################################### subroutine int2_rpagrd_data_t_clean ( this ) implicit none class ( int2_rpagrd_data_t ), intent ( inout ) :: this if ( allocated ( this % hpp )) deallocate ( this % hpp ) if ( allocated ( this % hpt )) deallocate ( this % hpt ) if ( allocated ( this % hmm )) deallocate ( this % hmm ) if ( allocated ( this % dsh )) deallocate ( this % dsh ) nullify ( this % xpy ) nullify ( this % xmy ) nullify ( this % t ) end subroutine !############################################################################### subroutine int2_rpagrd_data_t_init_screen ( this , basis ) implicit none class ( int2_rpagrd_data_t ), target , intent ( inout ) :: this type ( basis_set ), intent ( in ) :: basis !   Form shell density this % dsh = 0 if ( this % np > 0 ) call shlrpagrd ( this % dsh , this % xpy , basis ) if ( this % np > 0 ) call shlrpagrd ( this % dsh , this % xmy , basis ) if ( this % nt > 0 ) call shlrpagrd ( this % dsh , this % t , basis ) this % max_den = maxval ( abs ( this % dsh )) end subroutine !############################################################################### subroutine int2_rpagrd_data_t_update ( this , buf ) implicit none class ( int2_rpagrd_data_t ), intent ( inout ) :: this type ( int2_storage_t ), intent ( inout ) :: buf integer :: mythread integer :: i mythread = buf % thread_id ! H+[X+Y] do i = 1 , this % np call this % hplus ( buf , this % hpp (:,:,:, i , mythread ), this % xpy (:,:,:, i )) end do ! H+[T] do i = 1 , this % nt call this % hplus ( buf , this % hpt (:,:,:, i , mythread ), this % t (:,:,:, i )) end do ! H-[X-Y] do i = 1 , this % nm call this % hminus ( buf , this % hmm (:,:,:, i , mythread ), this % xmy (:,:,:, i )) end do buf % ncur = 0 end subroutine !############################################################################### !> @brief Compute H&#94;+[V] over a set of integrals subroutine int2_rpagrd_data_t_update_hplus ( this , buf , hp , v ) implicit none class ( int2_rpagrd_data_t ), intent ( inout ) :: this type ( int2_storage_t ), intent ( inout ) :: buf real ( kind = dp ), intent ( inout ) :: hp (:,:,:) real ( kind = dp ), intent ( in ) :: v (:,:,:) integer :: i , j , k , l , n real ( kind = dp ) :: xfact , cfact , & val , xval , cval integer :: mythread mythread = buf % thread_id if ( this % nspin == 1 ) then xfact = 2 * this % scale_exchange cfact = 8 * this % scale_coulomb do n = 1 , buf % ncur i = buf % ids ( 1 , n ) j = buf % ids ( 2 , n ) k = buf % ids ( 3 , n ) l = buf % ids ( 4 , n ) val = buf % ints ( n ) xval = val * xfact cval = val * cfact ! Coulomb hp ( i , j , 1 ) = hp ( i , j , 1 ) + cval * v ( l , k , 1 ) hp ( k , l , 1 ) = hp ( k , l , 1 ) + cval * v ( j , i , 1 ) !       Exhange hp ( i , k , 1 ) = hp ( i , k , 1 ) - xval * v ( l , j , 1 ) hp ( i , l , 1 ) = hp ( i , l , 1 ) - xval * v ( k , j , 1 ) hp ( j , k , 1 ) = hp ( j , k , 1 ) - xval * v ( l , i , 1 ) hp ( j , l , 1 ) = hp ( j , l , 1 ) - xval * v ( k , i , 1 ) end do else if ( this % nspin == 2 ) then xfact = 1 * this % scale_exchange cfact = 2 * this % scale_coulomb do n = 1 , buf % ncur i = buf % ids ( 1 , n ) j = buf % ids ( 2 , n ) k = buf % ids ( 3 , n ) l = buf % ids ( 4 , n ) val = buf % ints ( n ) xval = val * xfact cval = val * cfact ! Coulomb hp ( i , j , 1 ) = hp ( i , j , 1 ) + cval * ( v ( k , l , 1 ) + v ( l , k , 1 ) + v ( k , l , 2 ) + v ( l , k , 2 )) hp ( k , l , 1 ) = hp ( k , l , 1 ) + cval * ( v ( i , j , 1 ) + v ( j , i , 1 ) + v ( i , j , 2 ) + v ( j , i , 2 )) hp ( i , j , 2 ) = hp ( i , j , 2 ) + cval * ( v ( k , l , 1 ) + v ( l , k , 1 ) + v ( k , l , 2 ) + v ( l , k , 2 )) hp ( k , l , 2 ) = hp ( k , l , 2 ) + cval * ( v ( i , j , 1 ) + v ( j , i , 1 ) + v ( i , j , 2 ) + v ( j , i , 2 )) !       Exhange hp ( i , k , 1 ) = hp ( i , k , 1 ) - xval * ( v ( j , l , 1 ) + v ( l , j , 1 )) hp ( i , l , 1 ) = hp ( i , l , 1 ) - xval * ( v ( j , k , 1 ) + v ( k , j , 1 )) hp ( j , k , 1 ) = hp ( j , k , 1 ) - xval * ( v ( i , l , 1 ) + v ( l , i , 1 )) hp ( j , l , 1 ) = hp ( j , l , 1 ) - xval * ( v ( i , k , 1 ) + v ( k , i , 1 )) ! hp ( i , k , 2 ) = hp ( i , k , 2 ) - xval * ( v ( j , l , 2 ) + v ( l , j , 2 )) hp ( i , l , 2 ) = hp ( i , l , 2 ) - xval * ( v ( j , k , 2 ) + v ( k , j , 2 )) hp ( j , k , 2 ) = hp ( j , k , 2 ) - xval * ( v ( i , l , 2 ) + v ( l , i , 2 )) hp ( j , l , 2 ) = hp ( j , l , 2 ) - xval * ( v ( i , k , 2 ) + v ( k , i , 2 )) end do end if end subroutine !############################################################################### !> @brief Compute H&#94;-[V] over a set of integrals subroutine int2_rpagrd_data_t_update_hminus ( this , buf , hm , v ) implicit none class ( int2_rpagrd_data_t ), intent ( inout ) :: this type ( int2_storage_t ), intent ( inout ) :: buf real ( kind = dp ), intent ( inout ) :: hm (:,:,:) real ( kind = dp ), intent ( in ) :: v (:,:,:) integer :: i , j , k , l , n real ( kind = dp ) :: xfact , val , xval integer :: mythread xfact = this % scale_exchange mythread = buf % thread_id do n = 1 , buf % ncur i = buf % ids ( 1 , n ) j = buf % ids ( 2 , n ) k = buf % ids ( 3 , n ) l = buf % ids ( 4 , n ) val = buf % ints ( n ) xval = val * xfact !     Exhange hm ( i , k , 1 ) = hm ( i , k , 1 ) + xval * ( v ( l , j , 1 ) - v ( j , l , 1 )) hm ( i , l , 1 ) = hm ( i , l , 1 ) + xval * ( v ( k , j , 1 ) - v ( j , k , 1 )) hm ( j , k , 1 ) = hm ( j , k , 1 ) + xval * ( v ( l , i , 1 ) - v ( i , l , 1 )) hm ( j , l , 1 ) = hm ( j , l , 1 ) + xval * ( v ( k , i , 1 ) - v ( i , k , 1 )) !     Exhange hm ( k , i , 1 ) = hm ( k , i , 1 ) - xval * ( v ( l , j , 1 ) - v ( j , l , 1 )) hm ( l , i , 1 ) = hm ( l , i , 1 ) - xval * ( v ( k , j , 1 ) - v ( j , k , 1 )) hm ( k , j , 1 ) = hm ( k , j , 1 ) - xval * ( v ( l , i , 1 ) - v ( i , l , 1 )) hm ( l , j , 1 ) = hm ( l , j , 1 ) - xval * ( v ( k , i , 1 ) - v ( i , k , 1 )) end do end subroutine !############################################################################### subroutine shlrpagrd ( dsh , d , basis ) use precision , only : dp use types , only : information use basis_tools , only : basis_set implicit none type ( basis_set ), intent ( in ) :: basis real ( kind = dp ), intent ( out ) :: dsh (:,:) real ( kind = dp ), intent ( in ), dimension (:,:,:,:) :: d integer :: ish , jsh , maxi , maxj , mini , minj real ( kind = dp ) :: mxv !   RHF do ish = 1 , basis % nshell mini = basis % ao_offset ( ish ) maxi = mini + basis % naos ( ish ) - 1 do jsh = 1 , ish minj = basis % ao_offset ( jsh ) maxj = minj + basis % naos ( jsh ) - 1 mxv = maxval ( abs ( d ( minj : maxj , mini : maxi ,:,:))) dsh ( ish , jsh ) = max ( dsh ( ish , jsh ), mxv ) dsh ( jsh , ish ) = dsh ( ish , jsh ) end do end do end subroutine shlrpagrd !############################################################################### subroutine symmetrize_matrices ( a , lda , nmtx ) use mathlib , only : symmetrize_matrix implicit none real ( kind = dp ), intent ( inout ) :: a ( lda , lda , * ) integer , intent ( in ) :: lda , nmtx integer :: i do i = 1 , nmtx call symmetrize_matrix ( a (:,:, i ), lda ) end do end subroutine !############################################################################### !------------------------------------------------------------------------------- !> @brief Project Davidson expansion vectors onto each root's dominant irrep. !> @detail Response-space symmetry blocking (Phase IV): for a totally !>   symmetric reference the response matrix is block-diagonal over the !>   irreps of the excitation pairs, so each root's residual can be !>   confined to the dominant irrep of its current Ritz vector. No-op !>   unless pyoqp staged OQP::sym_pair_irrep (use_response_symmetry). subroutine sym_response_project ( infos , ritz_full , qvec , nstates ) use precision , only : dp use types , only : information use oqp_tagarray_driver use tagarray , only : TA_OK implicit none type ( information ), target , intent ( inout ) :: infos real ( kind = dp ), intent ( in ) :: ritz_full (:,:) real ( kind = dp ), intent ( inout ) :: qvec (:,:) integer , intent ( in ) :: nstates integer ( 8 ), contiguous , pointer :: pair_irrep (:) integer ( 4 ) :: status integer :: istate , ipair , best , nirr , xvec_dim real ( kind = dp ), allocatable :: weight (:) call tagarray_get_data ( infos % dat , OQP_sym_pair_irrep , pair_irrep , status = status ) if ( status /= TA_OK ) return xvec_dim = ubound ( qvec , 1 ) if ( size ( pair_irrep ) /= xvec_dim ) return nirr = int ( maxval ( pair_irrep )) if ( nirr < 1 ) return allocate ( weight ( nirr )) do istate = 1 , nstates weight = 0.0_dp do ipair = 1 , xvec_dim weight ( int ( pair_irrep ( ipair ))) = & weight ( int ( pair_irrep ( ipair ))) + ritz_full ( ipair , istate ) ** 2 end do best = maxloc ( weight , 1 ) do ipair = 1 , xvec_dim if ( int ( pair_irrep ( ipair )) /= best ) qvec ( ipair , istate ) = 0.0_dp end do end do end subroutine sym_response_project end module tdhf_lib","tags":"","url":"sourcefile/tdhf_lib.f90.html"},{"title":"tdhf_sf_energy.F90 – OpenQP Fortran API","text":"Source Code module tdhf_sf_energy_mod implicit none character ( len =* ), parameter :: module_name = \"tdhf_sf_energy_mod\" contains subroutine tdhf_sf_energy_C ( c_handle ) bind ( C , name = \"tdhf_sf_energy\" ) use c_interop , only : oqp_handle_t , oqp_handle_get_info use types , only : information type ( oqp_handle_t ) :: c_handle type ( information ), pointer :: inf inf => oqp_handle_get_info ( c_handle ) call tdhf_sf_energy_with_restart ( inf ) end subroutine tdhf_sf_energy_C ! Run the SF Davidson and auto-restart with a larger subspace (maxvec) and ! more iterations (maxit_dav) if it fails to converge.  Re-invoking the driver ! reallocates a fresh, larger subspace; user settings are restored afterwards. subroutine tdhf_sf_energy_with_restart ( infos ) use types , only : information use io_constants , only : iw type ( information ), intent ( inout ) :: infos integer , parameter :: max_restarts = 2 integer :: attempt , maxvec0 , maxit0 maxvec0 = infos % tddft % maxvec maxit0 = infos % control % maxit_dav do attempt = 0 , max_restarts call tdhf_sf_energy ( infos ) if ( infos % mol_energy % Davidson_converged ) exit if ( attempt < max_restarts ) then infos % tddft % maxvec = 2 * infos % tddft % maxvec infos % control % maxit_dav = 2 * infos % control % maxit_dav open ( unit = iw , file = infos % log_filename , position = \"append\" ) write ( iw , '(/,2X,\"SF Davidson not converged; auto-restart #\",I0, & &\" with larger subspace (maxvec=\",I0,\", maxit_dav=\",I0,\")\"/)' ) & attempt + 1 , infos % tddft % maxvec , infos % control % maxit_dav close ( iw ) end if end do infos % tddft % maxvec = maxvec0 infos % control % maxit_dav = maxit0 end subroutine tdhf_sf_energy_with_restart subroutine tdhf_sf_energy ( infos ) use io_constants , only : iw use oqp_tagarray_driver use types , only : information use strings , only : Cstring , fstring use basis_tools , only : basis_set use messages , only : show_message , with_abort use util , only : measure_time use precision , only : dp use int2_compute , only : int2_compute_t use tdhf_lib , only : sym_response_project , & int2_td_data_t use tdhf_lib , only : & inivec , iatogen , mntoia , rparedms , rpaeig , rpavnorm , & rpaechk , rpaprint , rpanewb use tdhf_sf_lib , only : & sfroesum , sfresvec , sfqvec , sfesum , sfdmat , trfrmb , & print_results , get_spin_square , get_transition_density , & get_transitions , get_transition_dipole use mathlib , only : orthogonal_transform_sym use mathlib , only : unpack_matrix use oqp_linalg use printing , only : print_module_info implicit none character ( len =* ), parameter :: subroutine_name = \"tdhf_sf_energy\" type ( basis_set ), pointer :: basis type ( information ), target , intent ( inout ) :: infos integer :: s_size , ok real ( kind = dp ), allocatable :: scr2 (:) real ( kind = dp ), allocatable :: ab2_mo (:,:), scr3 (:,:) real ( kind = dp ), allocatable :: sym_ritz (:,:) real ( kind = dp ), allocatable :: eex (:), spin_square (:) real ( kind = dp ), allocatable :: amb (:,:), & apb (:,:) real ( kind = dp ), allocatable , target :: vl (:), vr (:) real ( kind = dp ), pointer :: vl_p (:,:), vr_p (:,:) real ( kind = dp ), allocatable :: xm (:) real ( kind = dp ), allocatable :: bvec_mo (:,:), for_trnsf_b_vec (:,:) real ( kind = dp ), allocatable , target :: bvec (:,:,:) real ( kind = dp ), allocatable , target :: scr1 (:,:) real ( kind = dp ), pointer :: ab2 (:,:,:) real ( kind = dp ), allocatable , dimension (:,:) :: fa , fb real ( kind = dp ), allocatable , dimension (:) :: rnorm real ( kind = dp ), allocatable , dimension (:,:,:,:) :: trden integer , allocatable , dimension (:,:) :: trans real ( kind = dp ), pointer :: scr1t (:) real ( kind = dp ), allocatable :: dip (:,:,:), abxc (:,:) integer :: nocca , nvira , noccb , nvirb integer :: nbf , nbf2 , xvec_dim integer :: nstates , mxvec , nmax , ist , iend , nvec , novec integer :: iter , istart , nv , iv , ivec integer :: mxiter integer :: imax logical :: converged integer :: ierr real ( kind = dp ) :: mxerr , cnvtol , scale_exch integer :: maxvec , target_state logical :: roref = . false . type ( int2_compute_t ) :: int2_driver type ( int2_td_data_t ), target :: int2_data logical :: dft integer :: scf_type , mol_mult ! tagarray real ( kind = dp ), contiguous , pointer :: & fock_a (:), dmat_a (:), mo_a (:,:), mo_energy_a (:), & fock_b (:), dmat_b (:), mo_b (:,:), mo_energy_b (:), & smat (:), ta (:), tb (:), bvec_mo_out (:,:), td_t (:,:), & sf_energies (:) character ( len =* ), parameter :: tags_alloc ( 3 ) = ( / character ( len = 80 ) :: & OQP_td_bvec_mo , OQP_td_t , OQP_td_energies / ) character ( len =* ), parameter :: tags_required ( 9 ) = ( / character ( len = 80 ) :: & OQP_FOCK_A , OQP_DM_A , OQP_E_MO_A , OQP_VEC_MO_A , OQP_FOCK_B , OQP_DM_B , OQP_E_MO_B , OQP_VEC_MO_B , OQP_SM / ) mol_mult = infos % mol_prop % mult !    if (.not. (mol_mult == 3 .or. mol_mult == 4)) then !      call show_message( & !        'SF-TDDFT only supports mult=3 (triplet) or mult=4 (quartet) references', & !        with_abort) !    end if scf_type = infos % control % scftype if ( scf_type == 3 ) roref = . true . dft = infos % control % hamilton == 20 ! Files open ! 3. LOG: Write: Main output file open ( unit = IW , file = infos % log_filename , position = \"append\" ) ! call print_module_info ( 'SF_TDHF_Energy' , 'Computing Energy of SF-TDDFT' ) ! Readings ! Load basis set basis => infos % basis basis % atoms => infos % atoms ! Allocate H, S ,T and D matrices nbf = basis % nbf nbf2 = nbf * ( nbf + 1 ) / 2 s_size = ( basis % nshell ** 2 + basis % nshell ) / 2 ! Allocate temporary matrices for diagonalization allocate ( FA ( nbf , nbf ), & FB ( nbf , nbf ), & stat = ok ) if ( ok /= 0 ) call show_message ( 'Cannot allocate memory' , with_abort ) nstates = infos % tddft % nstate target_state = infos % tddft % target_state maxvec = infos % tddft % maxvec cnvtol = infos % tddft % cnvtol nocca = infos % mol_prop % nelec_A nvira = nbf - noccA noccb = infos % mol_prop % nelec_B nvirb = nbf - noccB xvec_dim = nocca * nvirb mxvec = min ( maxvec * nstates , xvec_dim ) nstates = min ( nstates , mxvec ) nvec = nstates nvec = min ( max ( 2 * nstates , 5 ), mxvec ) nmax = nvec call infos % dat % alloc_or_die ( OQP_td_bvec_mo , ( / xvec_dim , nstates / ), bvec_mo_out , description = OQP_td_bvec_mo_comment ) call infos % dat % alloc_or_die ( OQP_td_t , ( / nbf2 , 2 / ), td_t , description = OQP_td_t_comment ) call infos % dat % alloc_or_die ( OQP_td_energies , ( / nstates / ), sf_energies , description = OQP_td_energies_comment ) call data_has_tags ( infos % dat , tags_required , module_name , subroutine_name , WITH_ABORT ) call tagarray_get_data ( infos % dat , OQP_SM , smat ) call tagarray_get_data ( infos % dat , OQP_FOCK_A , fock_a ) call tagarray_get_data ( infos % dat , OQP_FOCK_B , fock_b ) call tagarray_get_data ( infos % dat , OQP_DM_A , dmat_a ) call tagarray_get_data ( infos % dat , OQP_DM_B , dmat_b ) call tagarray_get_data ( infos % dat , OQP_E_MO_A , mo_energy_a ) call tagarray_get_data ( infos % dat , OQP_E_MO_B , mo_energy_b ) call tagarray_get_data ( infos % dat , OQP_VEC_MO_A , mo_a ) call tagarray_get_data ( infos % dat , OQP_VEC_MO_B , mo_b ) allocate ( xm ( xvec_dim ), & trden ( nbf , nbf , nstates , nstates ), & bvec_mo ( xvec_dim , mxvec ), & abxc ( nbf , nbf ), & ab2_mo ( xvec_dim , mxvec ), & bvec ( nbf , nbf , nmax ), & eex ( mxvec ), & spin_square ( nstates ), & apb ( mxvec , mxvec ), & amb ( mxvec , mxvec ), & for_trnsf_b_vec ( mxvec , mxvec ), & ! dip ( 3 , nstates , nstates ), & vr ( mxvec * mxvec ), & vl ( mxvec * mxvec ), & scr1 ( nbf , nbf ), & scr2 ( mxvec * mxvec ), & scr3 ( xvec_dim , nstates ), & rnorm ( nstates ), & source = 0.0_dp , stat = ok ) if ( ok /= 0 ) call show_message ( 'Cannot allocate memory' , WITH_ABORT ) allocate ( trans ( xvec_dim , 2 ), & source = 0 , stat = ok ) if ( ok /= 0 ) call show_message ( 'Cannot allocate memory' , WITH_ABORT ) scale_exch = 1.0_dp if ( infos % tddft % HFscale == - 1.0_dp ) & infos % tddft % HFscale = infos % dft % HFscale if ( infos % dft % cam_flag ) then if ( infos % tddft % cam_alpha == - 1.0_dp ) & infos % tddft % cam_alpha = infos % dft % cam_alpha infos % tddft % HFscale = infos % tddft % cam_alpha if ( infos % tddft % cam_beta == - 1.0_dp ) & infos % tddft % cam_beta = infos % dft % cam_beta if ( infos % tddft % cam_mu == - 1.0_dp ) & infos % tddft % cam_mu = infos % dft % cam_mu end if if ( dft ) scale_exch = infos % tddft % HFscale if (. true .) then write ( * , '(/,5x,\"Input parameters:\")' ) write ( * , '(5x,\"Number of states:                 \",1x,I0)' ) nstates write ( * , '(5x,\"Number of single excitations:     \",1x,I0)' ) xvec_dim write ( * , '(5x,\"Number of atomic orbitals:        \",1x,I0)' ) nbf write ( * , '(5x,\"Number of electrons:              \",1x,I0)' ) nocca + noccb write ( * , '(5x,\"Number of occupied alpha orbitals:\",1x,I0)' ) nocca write ( * , '(5x,\"Number of occupied beta orbitals: \",1x,I0)' ) noccb write ( * , '(5x,\"Number of virtual alpha orbitals: \",1x,I0)' ) nvira write ( * , '(5x,\"Number of virtual beta orbitals:  \",1x,I0)' ) nvirb write ( * , '(5x,\"Maximum vectors:                  \",1x,I0)' ) mxvec write ( * , '(5x,\"Initial vectors:                  \",1x,I0)' ) nvec write ( * , '(/7x,\"Fitting parameters for SF-TDDFT\")' ) if (. not . infos % dft % cam_flag ) then write ( * , '(10x,\"Exact HF exchange:\")' ) write ( * , '(5x,\"Reference: |\", t20, f6.3, t29, \"|\")' ) infos % dft % HFscale write ( * , '(5x,\"Response:  |\", t20, f6.3, t29, \"|\")' ) infos % tddft % HFscale else write ( * , '(10x,\"CAM parametres:\")' ) write ( * , '(16x,\"|   alpha   |    beta   |     mu    |\")' ) write ( * , '(5x,\"Reference: |\", t20, f6.3, t29, \"|\", t32, f6.3, t41, \"|\", t44, f6.3, t53, \"|\")' ) & infos % dft % cam_alpha , infos % dft % cam_beta , infos % dft % cam_mu write ( * , '(5x,\"Response:  |\", t20, f6.3, t29, \"|\", t32, f6.3, t41, \"|\", t44, f6.3, t53, \"|\")' ) & infos % tddft % cam_alpha , infos % tddft % cam_beta , infos % tddft % cam_mu end if end if write ( * , '(/,5x,46(\"=\"))' ) write ( * , '(5X,\"Davidson algorithm for Spin-flip TDDFT\")' ) write ( * , '(5x,46(\"=\"))' ) ta => td_t (:, 1 ) tb => td_t (:, 2 ) ! Initialize ERI calculations call int2_driver % init ( basis , infos ) call int2_driver % set_screening () ! Prepare for ROHF if ( roref ) then scr1t ( 1 : nbf * nbf ) => scr1 (:,:) !   Alpha call orthogonal_transform_sym ( nbf , nbf , fock_a , mo_a , nbf , scr1 ) call unpack_matrix ( scr1t , fa ) !   Beta call orthogonal_transform_sym ( nbf , nbf , fock_b , mo_b , nbf , scr1 ) call unpack_matrix ( scr1t , fb ) end if ! Construct TD trial vector call inivec ( mo_energy_a , mo_energy_b , bvec_mo , xm , & nocca , noccb , nvec ) ist = 1 istart = 1 iend = nvec iter = 0 mxiter = infos % control % maxit_dav ierr = 0 do iter = 1 , mxiter nv = iend - ist + 1 do ivec = ist , iend iv = ivec - ist + 1 call iatogen ( bvec_mo (:, ivec ), abxc , nocca , noccb ) call dgemm ( 'n' , 'n' , nbf , nbf , nbf , & 1.0_dp , mo_a , nbf , abxc , nbf , & 0.0_dp , scr1 , nbf ) call dgemm ( 'n' , 't' , nbf , nbf , nbf , & 1.0_dp , scr1 , nbf , mo_b , nbf , & 0.0_dp , bvec ( 1 , 1 , iv ), nbf ) end do int2_data = int2_td_data_t ( d2 = bvec (:,:,: nv ), & int_apb = . false ., int_amb = . false ., tamm_dancoff = . true ., & scale_exchange = scale_exch ) call int2_driver % run ( int2_data , & cam = dft . and . infos % dft % cam_flag , & alpha = infos % tddft % cam_alpha , & beta = infos % tddft % cam_beta ,& mu = infos % tddft % cam_mu ) ab2 => int2_data % amb (:,:,:, 1 ) do ivec = ist , iend iv = ivec - ist + 1 !     Product (A-B)*X call mntoia ( ab2 (:,:, iv ), ab2_mo (:, ivec ), mo_a , mo_b , nocca , noccb ) if ( roref ) then call iatogen ( bvec_mo (:, ivec ), abxc , nocca , noccb ) ! faz call dgemm ( 'n' , 'n' , nocca , nbf , nocca , & 1.0_dp , fa , nbf , abxc , nbf , & 0.0_dp , scr1 , nbf ) ! zfb - faz call dgemm ( 'n' , 'n' , nocca , nbf , nbf , & 1.0_dp , abxc , nbf , fb , nbf , & - 1.0_dp , scr1 , nbf ) call sfroesum ( scr1 , ab2_mo , nocca , noccb , ivec ) else call sfesum ( mo_energy_a , mo_energy_b , ab2_mo , bvec_mo , nocca , noccb , ivec ) endif end do vl_p ( 1 : nvec , 1 : nvec ) => vl ( 1 : nvec * nvec ) vr_p ( 1 : nvec , 1 : nvec ) => vr ( 1 : nvec * nvec ) call rparedms ( bvec_mo , ab2_mo , ab2_mo , apb , amb , nvec , tamm_dancoff = . true .) call rpaeig ( eex , vl_p , vr_p , apb , amb , scr2 , tamm_dancoff = . true .) call rpavnorm ( vr_p , vl_p , tamm_dancoff = . true .) call rpaechk ( eex , nvec , nstates , imax , tamm_dancoff = . true .) for_trnsf_b_vec = vr_p call sfresvec ( scr3 , bvec_mo , ab2_mo , vr_p , eex , nvec , rnorm , nstates ) call sfqvec ( scr3 , xm , eex , nstates ) !     Response-space symmetry blocking (no-op unless staged by pyoqp). sym_ritz = matmul ( bvec_mo (:, 1 : nvec ), vr_p ( 1 : nvec , 1 : nstates )) call sym_response_project ( infos , sym_ritz , scr3 , nstates ) call rpaprint ( eex , rnorm , cnvtol , iter , imax , nstates , do_neg = . true .) mxerr = maxval ( rnorm ) !     Check convergence converged = mxerr <= cnvtol if ( converged ) exit !     No space left for new vectors, exit if ( nvec == mxvec ) ierr = 1 if ( ierr /= 0 ) exit call rpanewb ( nstates , bvec_mo , scr3 , novec , nvec , ierr , tamm_dancoff = . true .) !   ierr=1 nvec over mxvec: not converged case if ( ierr /= 0 ) exit ist = novec + 1 iend = nvec end do if ( iter >= mxiter . and . . not . converged ) ierr = - 1 select case ( ierr ) case ( - 1 ) write ( * , '(/,2X,\"SF-TD-DFT energies NOT CONVERGED after \",I4,\" iterations\"/)' ) mxiter !      call show_message(\"Aborting. Try to increase maxit or check your system.\", WITH_ABORT) infos % mol_energy % Davidson_converged = . false . case ( 0 ) write ( * , '(/,2X,\"SF-TD-DFT energies converged in \",I4,\" iterations\"/)' ) iter infos % mol_energy % Davidson_converged = . true . case ( 1 ) write ( * , '(/,2X,\"..something is wrong.. nvec = mxvec\")' ) infos % mol_energy % Davidson_converged = . false . case ( 2 ) write ( * , '(/,2x,\"..something is wrong..  nvec > mxvec\")' ) write ( * , '(3x,\"nvec/mxvec =\",I4,\"/\",I4)' ) nvec , mxvec infos % mol_energy % Davidson_converged = . false . case ( 3 ) write ( * , '(/,2x,\"..something is wrong.. No vectors were added\")' ) infos % mol_energy % Davidson_converged = . false . end select call flush ( iw ) call trfrmb ( bvec_mo , for_trnsf_b_vec , nvec , nstates ) call get_transition_density ( trden , bvec_mo , nbf , noccb , nocca , nstates ) call get_transition_dipole ( basis , dip , mo_a , trden , nstates ) do ist = 1 , nstates call sfdmat ( bvec_mo (:, ist ), abxc , mo_a , ta , tb , nocca , noccb ) spin_square ( ist ) = get_spin_square ( dmat_a , dmat_b , ta , tb , abxc , Smat , noccb , nocca ) end do call get_transitions ( trans , nocca , noccb , nbf ) write ( * , '(2x,35(\"=\"),/,2x,\"Alpha -> Beta spin-flip excitations\",/,2x,35(\"=\"))' ) sf_energies = eex (: nstates ) bvec_mo_out = bvec_mo (:,: nstates ) infos % mol_energy % excited_energy = sf_energies ( infos % tddft % target_state ) call print_results ( infos , bvec_mo , eex , trans , dip , spin_square , nstates ) call flush ( iw ) call int2_driver % clean () call measure_time ( print_total = 1 , log_unit = iw ) close ( iw ) end subroutine tdhf_sf_energy end module tdhf_sf_energy_mod","tags":"","url":"sourcefile/tdhf_sf_energy.f90.html"},{"title":"blas_wrap.F90 – OpenQP Fortran API","text":"Source Code module blas_wrap use precision , only : dp use mathlib_types , only : BLAS_INT , HUGE_BLAS_INT use messages , only : show_message , WITH_ABORT implicit none logical , parameter :: ARG_CHECK = . false . character ( len =* ), parameter :: BITNESS ( 2 ) = [ \"32\" , \"64\" ] character ( len =* ), parameter :: ERRMSG = & \"Integer is too big for \" // BITNESS ( BLAS_INT / 4 ) // \"bit BLAS/LAPACK\" private public oqp_caxpy_i64 public oqp_ccopy_i64 public oqp_cdotc_i64 public oqp_cdotu_i64 public oqp_cgbmv_i64 public oqp_cgemm_i64 public oqp_cgemv_i64 public oqp_cgerc_i64 public oqp_cgeru_i64 public oqp_chbmv_i64 public oqp_chemm_i64 public oqp_chemv_i64 public oqp_cher_i64 public oqp_cher2_i64 public oqp_cher2k_i64 public oqp_cherk_i64 public oqp_chpmv_i64 public oqp_chpr_i64 public oqp_chpr2_i64 public oqp_cscal_i64 public oqp_csrot_i64 public oqp_csscal_i64 public oqp_cswap_i64 public oqp_csymm_i64 public oqp_csyr2k_i64 public oqp_csyrk_i64 public oqp_ctbmv_i64 public oqp_ctbsv_i64 public oqp_ctpmv_i64 public oqp_ctpsv_i64 public oqp_ctrmm_i64 public oqp_ctrmv_i64 public oqp_ctrsm_i64 public oqp_ctrsv_i64 public oqp_dasum_i64 public oqp_daxpy_i64 public oqp_dcopy_i64 public oqp_ddot_i64 public oqp_dgbmv_i64 public oqp_dgemm_i64 public oqp_dgemv_i64 public oqp_dger_i64 public oqp_drot_i64 public oqp_drotm_i64 public oqp_dsbmv_i64 public oqp_dscal_i64 public oqp_dsdot_i64 public oqp_dspmv_i64 public oqp_dspr_i64 public oqp_dspr2_i64 public oqp_dswap_i64 public oqp_dsymm_i64 public oqp_dsymv_i64 public oqp_dsyr_i64 public oqp_dsyr2_i64 public oqp_dsyr2k_i64 public oqp_dsyrk_i64 public oqp_dtbmv_i64 public oqp_dtbsv_i64 public oqp_dtpmv_i64 public oqp_dtpsv_i64 public oqp_dtrmm_i64 public oqp_dtrmv_i64 public oqp_dtrsm_i64 public oqp_dtrsv_i64 public oqp_dzasum_i64 public oqp_icamax_i64 public oqp_idamax_i64 public oqp_isamax_i64 public oqp_izamax_i64 public oqp_sasum_i64 public oqp_saxpy_i64 public oqp_scasum_i64 public oqp_scopy_i64 public oqp_sdot_i64 public oqp_sdsdot_i64 public oqp_sgbmv_i64 public oqp_sgemm_i64 public oqp_sgemv_i64 public oqp_sger_i64 public oqp_srot_i64 public oqp_srotm_i64 public oqp_ssbmv_i64 public oqp_sscal_i64 public oqp_sspmv_i64 public oqp_sspr_i64 public oqp_sspr2_i64 public oqp_sswap_i64 public oqp_ssymm_i64 public oqp_ssymv_i64 public oqp_ssyr_i64 public oqp_ssyr2_i64 public oqp_ssyr2k_i64 public oqp_ssyrk_i64 public oqp_stbmv_i64 public oqp_stbsv_i64 public oqp_stpmv_i64 public oqp_stpsv_i64 public oqp_strmm_i64 public oqp_strmv_i64 public oqp_strsm_i64 public oqp_strsv_i64 public oqp_xerbla_i64 !  public oqp_xerbla_array_i64 public oqp_zaxpy_i64 public oqp_zcopy_i64 public oqp_zdotc_i64 public oqp_zdotu_i64 public oqp_zdrot_i64 public oqp_zdscal_i64 public oqp_zgbmv_i64 public oqp_zgemm_i64 public oqp_zgemv_i64 public oqp_zgerc_i64 public oqp_zgeru_i64 public oqp_zhbmv_i64 public oqp_zhemm_i64 public oqp_zhemv_i64 public oqp_zher_i64 public oqp_zher2_i64 public oqp_zher2k_i64 public oqp_zherk_i64 public oqp_zhpmv_i64 public oqp_zhpr_i64 public oqp_zhpr2_i64 public oqp_zscal_i64 public oqp_zswap_i64 public oqp_zsymm_i64 public oqp_zsyr2k_i64 public oqp_zsyrk_i64 public oqp_ztbmv_i64 public oqp_ztbsv_i64 public oqp_ztpmv_i64 public oqp_ztpsv_i64 public oqp_ztrmm_i64 public oqp_ztrmv_i64 public oqp_ztrsm_i64 public oqp_ztrsv_i64 public oqp_dnrm2_i64 public oqp_dznrm2_i64 public oqp_scnrm2_i64 public oqp_snrm2_i64 contains subroutine oqp_caxpy_i64 ( n , ca , cx , incx , cy , incy ) complex :: ca integer :: incx integer :: incy integer :: n complex :: cx ( * ) complex :: cy ( * ) integer ( blas_int ) :: n_ , incx_ , incy_ logical :: ok if ( ARG_CHECK ) then ok = . true . ok = ok . and . abs ( n ) <= HUGE_BLAS_INT - 1 ok = ok . and . abs ( incx ) <= HUGE_BLAS_INT - 1 ok = ok . and . abs ( incy ) <= HUGE_BLAS_INT - 1 if (. not . ok ) call show_message ( ERRMSG , WITH_ABORT ) end if n_ = int ( n , blas_int ) incx_ = int ( incx , blas_int ) incy_ = int ( incy , blas_int ) call caxpy ( n_ , ca , cx , incx_ , cy , incy_ ) end subroutine oqp_caxpy_i64 subroutine oqp_ccopy_i64 ( n , cx , incx , cy , incy ) integer :: incx integer :: incy integer :: n complex :: cx ( * ) complex :: cy ( * ) integer ( blas_int ) :: n_ , incx_ , incy_ logical :: ok if ( ARG_CHECK ) then ok = . true . ok = ok . and . abs ( n ) <= HUGE_BLAS_INT - 1 ok = ok . and . abs ( incx ) <= HUGE_BLAS_INT - 1 ok = ok . and . abs ( incy ) <= HUGE_BLAS_INT - 1 if (. not . ok ) call show_message ( ERRMSG , WITH_ABORT ) end if n_ = int ( n , blas_int ) incx_ = int ( incx , blas_int ) incy_ = int ( incy , blas_int ) call ccopy ( n_ , cx , incx_ , cy , incy_ ) end subroutine oqp_ccopy_i64 function oqp_cdotc_i64 ( n , cx , incx , cy , incy ) complex , external :: cdotc complex :: oqp_cdotc_i64 integer :: incx integer :: incy integer :: n complex :: cx ( * ) complex :: cy ( * ) integer ( blas_int ) :: n_ , incx_ , incy_ logical :: ok if ( ARG_CHECK ) then ok = . true . ok = ok . and . abs ( n ) <= HUGE_BLAS_INT - 1 ok = ok . and . abs ( incx ) <= HUGE_BLAS_INT - 1 ok = ok . and . abs ( incy ) <= HUGE_BLAS_INT - 1 if (. not . ok ) call show_message ( ERRMSG , WITH_ABORT ) end if n_ = int ( n , blas_int ) incx_ = int ( incx , blas_int ) incy_ = int ( incy , blas_int ) oqp_cdotc_i64 = cdotc ( n_ , cx , incx_ , cy , incy_ ) end function oqp_cdotc_i64 function oqp_cdotu_i64 ( n , cx , incx , cy , incy ) complex , external :: cdotu complex :: oqp_cdotu_i64 integer :: incx integer :: incy integer :: n complex :: cx ( * ) complex :: cy ( * ) integer ( blas_int ) :: n_ , incx_ , incy_ logical :: ok if ( ARG_CHECK ) then ok = . true . ok = ok . and . abs ( n ) <= HUGE_BLAS_INT - 1 ok = ok . and . abs ( incx ) <= HUGE_BLAS_INT - 1 ok = ok . and . abs ( incy ) <= HUGE_BLAS_INT - 1 if (. not . ok ) call show_message ( ERRMSG , WITH_ABORT ) end if n_ = int ( n , blas_int ) incx_ = int ( incx , blas_int ) incy_ = int ( incy , blas_int ) oqp_cdotu_i64 = cdotu ( n_ , cx , incx_ , cy , incy_ ) end function oqp_cdotu_i64 subroutine oqp_cgbmv_i64 ( trans , m , n , kl , ku , alpha , a , lda , x , incx , beta , y , incy ) complex :: alpha complex :: beta integer :: incx integer :: incy integer :: kl integer :: ku integer :: lda integer :: m integer :: n character :: trans complex :: a ( lda , * ) complex :: x ( * ) complex :: y ( * ) integer ( blas_int ) :: m_ , n_ , kl_ , ku_ , lda_ , incx_ , incy_ logical :: ok if ( ARG_CHECK ) then ok = . true . ok = ok . and . abs ( m ) <= HUGE_BLAS_INT - 1 ok = ok . and . abs ( n ) <= HUGE_BLAS_INT - 1 ok = ok . and . abs ( kl ) <= HUGE_BLAS_INT - 1 ok = ok . and . abs ( ku ) <= HUGE_BLAS_INT - 1 ok = ok . and . abs ( lda ) <= HUGE_BLAS_INT - 1 ok = ok . and . abs ( incx ) <= HUGE_BLAS_INT - 1 ok = ok . and . abs ( incy ) <= HUGE_BLAS_INT - 1 if (. not . ok ) call show_message ( ERRMSG , WITH_ABORT ) end if m_ = int ( m , blas_int ) n_ = int ( n , blas_int ) kl_ = int ( kl , blas_int ) ku_ = int ( ku , blas_int ) lda_ = int ( lda , blas_int ) incx_ = int ( incx , blas_int ) incy_ = int ( incy , blas_int ) call cgbmv ( trans , m_ , n_ , kl_ , ku_ , alpha , a , lda_ , x , incx_ , beta , y , incy_ ) end subroutine oqp_cgbmv_i64 subroutine oqp_cgemm_i64 ( transa , transb , m , n , k , alpha , a , lda , b , ldb , beta , c , ldc ) complex :: alpha complex :: beta integer :: k integer :: lda integer :: ldb integer :: ldc integer :: m integer :: n character :: transa character :: transb complex :: a ( lda , * ) complex :: b ( ldb , * ) complex :: c ( ldc , * ) integer ( blas_int ) :: m_ , n_ , k_ , lda_ , ldb_ , ldc_ logical :: ok if ( ARG_CHECK ) then ok = . true . ok = ok . and . abs ( m ) <= HUGE_BLAS_INT - 1 ok = ok . and . abs ( n ) <= HUGE_BLAS_INT - 1 ok = ok . and . abs ( k ) <= HUGE_BLAS_INT - 1 ok = ok . and . abs ( lda ) <= HUGE_BLAS_INT - 1 ok = ok . and . abs ( ldb ) <= HUGE_BLAS_INT - 1 ok = ok . and . abs ( ldc ) <= HUGE_BLAS_INT - 1 if (. not . ok ) call show_message ( ERRMSG , WITH_ABORT ) end if m_ = int ( m , blas_int ) n_ = int ( n , blas_int ) k_ = int ( k , blas_int ) lda_ = int ( lda , blas_int ) ldb_ = int ( ldb , blas_int ) ldc_ = int ( ldc , blas_int ) call cgemm ( transa , transb , m_ , n_ , k_ , alpha , a , lda_ , b , ldb_ , beta , c , ldc_ ) end subroutine oqp_cgemm_i64 subroutine oqp_cgemv_i64 ( trans , m , n , alpha , a , lda , x , incx , beta , y , incy ) complex :: alpha complex :: beta integer :: incx integer :: incy integer :: lda integer :: m integer :: n character :: trans complex :: a ( lda , * ) complex :: x ( * ) complex :: y ( * ) integer ( blas_int ) :: m_ , n_ , lda_ , incx_ , incy_ logical :: ok if ( ARG_CHECK ) then ok = . true . ok = ok . and . abs ( m ) <= HUGE_BLAS_INT - 1 ok = ok . and . abs ( n ) <= HUGE_BLAS_INT - 1 ok = ok . and . abs ( lda ) <= HUGE_BLAS_INT - 1 ok = ok . and . abs ( incx ) <= HUGE_BLAS_INT - 1 ok = ok . and . abs ( incy ) <= HUGE_BLAS_INT - 1 if (. not . ok ) call show_message ( ERRMSG , WITH_ABORT ) end if m_ = int ( m , blas_int ) n_ = int ( n , blas_int ) lda_ = int ( lda , blas_int ) incx_ = int ( incx , blas_int ) incy_ = int ( incy , blas_int ) call cgemv ( trans , m_ , n_ , alpha , a , lda_ , x , incx_ , beta , y , incy_ ) end subroutine oqp_cgemv_i64 subroutine oqp_cgerc_i64 ( m , n , alpha , x , incx , y , incy , a , lda ) complex :: alpha integer :: incx integer :: incy integer :: lda integer :: m integer :: n complex :: a ( lda , * ) complex :: x ( * ) complex :: y ( * ) integer ( blas_int ) :: m_ , n_ , incx_ , incy_ , lda_ logical :: ok if ( ARG_CHECK ) then ok = . true . ok = ok . and . abs ( m ) <= HUGE_BLAS_INT - 1 ok = ok . and . abs ( n ) <= HUGE_BLAS_INT - 1 ok = ok . and . abs ( incx ) <= HUGE_BLAS_INT - 1 ok = ok . and . abs ( incy ) <= HUGE_BLAS_INT - 1 ok = ok . and . abs ( lda ) <= HUGE_BLAS_INT - 1 if (. not . ok ) call show_message ( ERRMSG , WITH_ABORT ) end if m_ = int ( m , blas_int ) n_ = int ( n , blas_int ) incx_ = int ( incx , blas_int ) incy_ = int ( incy , blas_int ) lda_ = int ( lda , blas_int ) call cgerc ( m_ , n_ , alpha , x , incx_ , y , incy_ , a , lda_ ) end subroutine oqp_cgerc_i64 subroutine oqp_cgeru_i64 ( m , n , alpha , x , incx , y , incy , a , lda ) complex :: alpha integer :: incx integer :: incy integer :: lda integer :: m integer :: n complex :: a ( lda , * ) complex :: x ( * ) complex :: y ( * ) integer ( blas_int ) :: m_ , n_ , incx_ , incy_ , lda_ logical :: ok if ( ARG_CHECK ) then ok = . true . ok = ok . and . abs ( m ) <= HUGE_BLAS_INT - 1 ok = ok . and . abs ( n ) <= HUGE_BLAS_INT - 1 ok = ok . and . abs ( incx ) <= HUGE_BLAS_INT - 1 ok = ok . and . abs ( incy ) <= HUGE_BLAS_INT - 1 ok = ok . and . abs ( lda ) <= HUGE_BLAS_INT - 1 if (. not . ok ) call show_message ( ERRMSG , WITH_ABORT ) end if m_ = int ( m , blas_int ) n_ = int ( n , blas_int ) incx_ = int ( incx , blas_int ) incy_ = int ( incy , blas_int ) lda_ = int ( lda , blas_int ) call cgeru ( m_ , n_ , alpha , x , incx_ , y , incy_ , a , lda_ ) end subroutine oqp_cgeru_i64 subroutine oqp_chbmv_i64 ( uplo , n , k , alpha , a , lda , x , incx , beta , y , incy ) complex :: alpha complex :: beta integer :: incx integer :: incy integer :: k integer :: lda integer :: n character :: uplo complex :: a ( lda , * ) complex :: x ( * ) complex :: y ( * ) integer ( blas_int ) :: n_ , k_ , lda_ , incx_ , incy_ logical :: ok if ( ARG_CHECK ) then ok = . true . ok = ok . and . abs ( n ) <= HUGE_BLAS_INT - 1 ok = ok . and . abs ( k ) <= HUGE_BLAS_INT - 1 ok = ok . and . abs ( lda ) <= HUGE_BLAS_INT - 1 ok = ok . and . abs ( incx ) <= HUGE_BLAS_INT - 1 ok = ok . and . abs ( incy ) <= HUGE_BLAS_INT - 1 if (. not . ok ) call show_message ( ERRMSG , WITH_ABORT ) end if n_ = int ( n , blas_int ) k_ = int ( k , blas_int ) lda_ = int ( lda , blas_int ) incx_ = int ( incx , blas_int ) incy_ = int ( incy , blas_int ) call chbmv ( uplo , n_ , k_ , alpha , a , lda_ , x , incx_ , beta , y , incy_ ) end subroutine oqp_chbmv_i64 subroutine oqp_chemm_i64 ( side , uplo , m , n , alpha , a , lda , b , ldb , beta , c , ldc ) complex :: alpha complex :: beta integer :: lda integer :: ldb integer :: ldc integer :: m integer :: n character :: side character :: uplo complex :: a ( lda , * ) complex :: b ( ldb , * ) complex :: c ( ldc , * ) integer ( blas_int ) :: m_ , n_ , lda_ , ldb_ , ldc_ logical :: ok if ( ARG_CHECK ) then ok = . true . ok = ok . and . abs ( m ) <= HUGE_BLAS_INT - 1 ok = ok . and . abs ( n ) <= HUGE_BLAS_INT - 1 ok = ok . and . abs ( lda ) <= HUGE_BLAS_INT - 1 ok = ok . and . abs ( ldb ) <= HUGE_BLAS_INT - 1 ok = ok . and . abs ( ldc ) <= HUGE_BLAS_INT - 1 if (. not . ok ) call show_message ( ERRMSG , WITH_ABORT ) end if m_ = int ( m , blas_int ) n_ = int ( n , blas_int ) lda_ = int ( lda , blas_int ) ldb_ = int ( ldb , blas_int ) ldc_ = int ( ldc , blas_int ) call chemm ( side , uplo , m_ , n_ , alpha , a , lda_ , b , ldb_ , beta , c , ldc_ ) end subroutine oqp_chemm_i64 subroutine oqp_chemv_i64 ( uplo , n , alpha , a , lda , x , incx , beta , y , incy ) complex :: alpha complex :: beta integer :: incx integer :: incy integer :: lda integer :: n character :: uplo complex :: a ( lda , * ) complex :: x ( * ) complex :: y ( * ) integer ( blas_int ) :: n_ , lda_ , incx_ , incy_ logical :: ok if ( ARG_CHECK ) then ok = . true . ok = ok . and . abs ( n ) <= HUGE_BLAS_INT - 1 ok = ok . and . abs ( lda ) <= HUGE_BLAS_INT - 1 ok = ok . and . abs ( incx ) <= HUGE_BLAS_INT - 1 ok = ok . and . abs ( incy ) <= HUGE_BLAS_INT - 1 if (. not . ok ) call show_message ( ERRMSG , WITH_ABORT ) end if n_ = int ( n , blas_int ) lda_ = int ( lda , blas_int ) incx_ = int ( incx , blas_int ) incy_ = int ( incy , blas_int ) call chemv ( uplo , n_ , alpha , a , lda_ , x , incx_ , beta , y , incy_ ) end subroutine oqp_chemv_i64 subroutine oqp_cher_i64 ( uplo , n , alpha , x , incx , a , lda ) real :: alpha integer :: incx integer :: lda integer :: n character :: uplo complex :: a ( lda , * ) complex :: x ( * ) integer ( blas_int ) :: n_ , incx_ , lda_ logical :: ok if ( ARG_CHECK ) then ok = . true . ok = ok . and . abs ( n ) <= HUGE_BLAS_INT - 1 ok = ok . and . abs ( incx ) <= HUGE_BLAS_INT - 1 ok = ok . and . abs ( lda ) <= HUGE_BLAS_INT - 1 if (. not . ok ) call show_message ( ERRMSG , WITH_ABORT ) end if n_ = int ( n , blas_int ) incx_ = int ( incx , blas_int ) lda_ = int ( lda , blas_int ) call cher ( uplo , n_ , alpha , x , incx_ , a , lda_ ) end subroutine oqp_cher_i64 subroutine oqp_cher2_i64 ( uplo , n , alpha , x , incx , y , incy , a , lda ) complex :: alpha integer :: incx integer :: incy integer :: lda integer :: n character :: uplo complex :: a ( lda , * ) complex :: x ( * ) complex :: y ( * ) integer ( blas_int ) :: n_ , incx_ , incy_ , lda_ logical :: ok if ( ARG_CHECK ) then ok = . true . ok = ok . and . abs ( n ) <= HUGE_BLAS_INT - 1 ok = ok . and . abs ( incx ) <= HUGE_BLAS_INT - 1 ok = ok . and . abs ( incy ) <= HUGE_BLAS_INT - 1 ok = ok . and . abs ( lda ) <= HUGE_BLAS_INT - 1 if (. not . ok ) call show_message ( ERRMSG , WITH_ABORT ) end if n_ = int ( n , blas_int ) incx_ = int ( incx , blas_int ) incy_ = int ( incy , blas_int ) lda_ = int ( lda , blas_int ) call cher2 ( uplo , n_ , alpha , x , incx_ , y , incy_ , a , lda_ ) end subroutine oqp_cher2_i64 subroutine oqp_cher2k_i64 ( uplo , trans , n , k , alpha , a , lda , b , ldb , beta , c , ldc ) complex :: alpha real :: beta integer :: k integer :: lda integer :: ldb integer :: ldc integer :: n character :: trans character :: uplo complex :: a ( lda , * ) complex :: b ( ldb , * ) complex :: c ( ldc , * ) integer ( blas_int ) :: n_ , k_ , lda_ , ldb_ , ldc_ logical :: ok if ( ARG_CHECK ) then ok = . true . ok = ok . and . abs ( n ) <= HUGE_BLAS_INT - 1 ok = ok . and . abs ( k ) <= HUGE_BLAS_INT - 1 ok = ok . and . abs ( lda ) <= HUGE_BLAS_INT - 1 ok = ok . and . abs ( ldb ) <= HUGE_BLAS_INT - 1 ok = ok . and . abs ( ldc ) <= HUGE_BLAS_INT - 1 if (. not . ok ) call show_message ( ERRMSG , WITH_ABORT ) end if n_ = int ( n , blas_int ) k_ = int ( k , blas_int ) lda_ = int ( lda , blas_int ) ldb_ = int ( ldb , blas_int ) ldc_ = int ( ldc , blas_int ) call cher2k ( uplo , trans , n_ , k_ , alpha , a , lda_ , b , ldb_ , beta , c , ldc_ ) end subroutine oqp_cher2k_i64 subroutine oqp_cherk_i64 ( uplo , trans , n , k , alpha , a , lda , beta , c , ldc ) real :: alpha real :: beta integer :: k integer :: lda integer :: ldc integer :: n character :: trans character :: uplo complex :: a ( lda , * ) complex :: c ( ldc , * ) integer ( blas_int ) :: n_ , k_ , lda_ , ldc_ logical :: ok if ( ARG_CHECK ) then ok = . true . ok = ok . and . abs ( n ) <= HUGE_BLAS_INT - 1 ok = ok . and . abs ( k ) <= HUGE_BLAS_INT - 1 ok = ok . and . abs ( lda ) <= HUGE_BLAS_INT - 1 ok = ok . and . abs ( ldc ) <= HUGE_BLAS_INT - 1 if (. not . ok ) call show_message ( ERRMSG , WITH_ABORT ) end if n_ = int ( n , blas_int ) k_ = int ( k , blas_int ) lda_ = int ( lda , blas_int ) ldc_ = int ( ldc , blas_int ) call cherk ( uplo , trans , n_ , k_ , alpha , a , lda_ , beta , c , ldc_ ) end subroutine oqp_cherk_i64 subroutine oqp_chpmv_i64 ( uplo , n , alpha , ap , x , incx , beta , y , incy ) complex :: alpha complex :: beta integer :: incx integer :: incy integer :: n character :: uplo complex :: ap ( * ) complex :: x ( * ) complex :: y ( * ) integer ( blas_int ) :: n_ , incx_ , incy_ logical :: ok if ( ARG_CHECK ) then ok = . true . ok = ok . and . abs ( n ) <= HUGE_BLAS_INT - 1 ok = ok . and . abs ( incx ) <= HUGE_BLAS_INT - 1 ok = ok . and . abs ( incy ) <= HUGE_BLAS_INT - 1 if (. not . ok ) call show_message ( ERRMSG , WITH_ABORT ) end if n_ = int ( n , blas_int ) incx_ = int ( incx , blas_int ) incy_ = int ( incy , blas_int ) call chpmv ( uplo , n_ , alpha , ap , x , incx_ , beta , y , incy_ ) end subroutine oqp_chpmv_i64 subroutine oqp_chpr_i64 ( uplo , n , alpha , x , incx , ap ) real :: alpha integer :: incx integer :: n character :: uplo complex :: ap ( * ) complex :: x ( * ) integer ( blas_int ) :: n_ , incx_ logical :: ok if ( ARG_CHECK ) then ok = . true . ok = ok . and . abs ( n ) <= HUGE_BLAS_INT - 1 ok = ok . and . abs ( incx ) <= HUGE_BLAS_INT - 1 if (. not . ok ) call show_message ( ERRMSG , WITH_ABORT ) end if n_ = int ( n , blas_int ) incx_ = int ( incx , blas_int ) call chpr ( uplo , n_ , alpha , x , incx_ , ap ) end subroutine oqp_chpr_i64 subroutine oqp_chpr2_i64 ( uplo , n , alpha , x , incx , y , incy , ap ) complex :: alpha integer :: incx integer :: incy integer :: n character :: uplo complex :: ap ( * ) complex :: x ( * ) complex :: y ( * ) integer ( blas_int ) :: n_ , incx_ , incy_ logical :: ok if ( ARG_CHECK ) then ok = . true . ok = ok . and . abs ( n ) <= HUGE_BLAS_INT - 1 ok = ok . and . abs ( incx ) <= HUGE_BLAS_INT - 1 ok = ok . and . abs ( incy ) <= HUGE_BLAS_INT - 1 if (. not . ok ) call show_message ( ERRMSG , WITH_ABORT ) end if n_ = int ( n , blas_int ) incx_ = int ( incx , blas_int ) incy_ = int ( incy , blas_int ) call chpr2 ( uplo , n_ , alpha , x , incx_ , y , incy_ , ap ) end subroutine oqp_chpr2_i64 subroutine oqp_cscal_i64 ( n , ca , cx , incx ) complex :: ca integer :: incx integer :: n complex :: cx ( * ) integer ( blas_int ) :: n_ , incx_ logical :: ok if ( ARG_CHECK ) then ok = . true . ok = ok . and . abs ( n ) <= HUGE_BLAS_INT - 1 ok = ok . and . abs ( incx ) <= HUGE_BLAS_INT - 1 if (. not . ok ) call show_message ( ERRMSG , WITH_ABORT ) end if n_ = int ( n , blas_int ) incx_ = int ( incx , blas_int ) call cscal ( n_ , ca , cx , incx_ ) end subroutine oqp_cscal_i64 subroutine oqp_csrot_i64 ( n , cx , incx , cy , incy , c , s ) integer :: incx integer :: incy integer :: n real :: c real :: s complex :: cx ( * ) complex :: cy ( * ) integer ( blas_int ) :: n_ , incx_ , incy_ logical :: ok if ( ARG_CHECK ) then ok = . true . ok = ok . and . abs ( n ) <= HUGE_BLAS_INT - 1 ok = ok . and . abs ( incx ) <= HUGE_BLAS_INT - 1 ok = ok . and . abs ( incy ) <= HUGE_BLAS_INT - 1 if (. not . ok ) call show_message ( ERRMSG , WITH_ABORT ) end if n_ = int ( n , blas_int ) incx_ = int ( incx , blas_int ) incy_ = int ( incy , blas_int ) call csrot ( n_ , cx , incx_ , cy , incy_ , c , s ) end subroutine oqp_csrot_i64 subroutine oqp_csscal_i64 ( n , sa , cx , incx ) real :: sa integer :: incx integer :: n complex :: cx ( * ) integer ( blas_int ) :: n_ , incx_ logical :: ok if ( ARG_CHECK ) then ok = . true . ok = ok . and . abs ( n ) <= HUGE_BLAS_INT - 1 ok = ok . and . abs ( incx ) <= HUGE_BLAS_INT - 1 if (. not . ok ) call show_message ( ERRMSG , WITH_ABORT ) end if n_ = int ( n , blas_int ) incx_ = int ( incx , blas_int ) call csscal ( n_ , sa , cx , incx_ ) end subroutine oqp_csscal_i64 subroutine oqp_cswap_i64 ( n , cx , incx , cy , incy ) integer :: incx integer :: incy integer :: n complex :: cx ( * ) complex :: cy ( * ) integer ( blas_int ) :: n_ , incx_ , incy_ logical :: ok if ( ARG_CHECK ) then ok = . true . ok = ok . and . abs ( n ) <= HUGE_BLAS_INT - 1 ok = ok . and . abs ( incx ) <= HUGE_BLAS_INT - 1 ok = ok . and . abs ( incy ) <= HUGE_BLAS_INT - 1 if (. not . ok ) call show_message ( ERRMSG , WITH_ABORT ) end if n_ = int ( n , blas_int ) incx_ = int ( incx , blas_int ) incy_ = int ( incy , blas_int ) call cswap ( n_ , cx , incx_ , cy , incy_ ) end subroutine oqp_cswap_i64 subroutine oqp_csymm_i64 ( side , uplo , m , n , alpha , a , lda , b , ldb , beta , c , ldc ) complex :: alpha complex :: beta integer :: lda integer :: ldb integer :: ldc integer :: m integer :: n character :: side character :: uplo complex :: a ( lda , * ) complex :: b ( ldb , * ) complex :: c ( ldc , * ) integer ( blas_int ) :: m_ , n_ , lda_ , ldb_ , ldc_ logical :: ok if ( ARG_CHECK ) then ok = . true . ok = ok . and . abs ( m ) <= HUGE_BLAS_INT - 1 ok = ok . and . abs ( n ) <= HUGE_BLAS_INT - 1 ok = ok . and . abs ( lda ) <= HUGE_BLAS_INT - 1 ok = ok . and . abs ( ldb ) <= HUGE_BLAS_INT - 1 ok = ok . and . abs ( ldc ) <= HUGE_BLAS_INT - 1 if (. not . ok ) call show_message ( ERRMSG , WITH_ABORT ) end if m_ = int ( m , blas_int ) n_ = int ( n , blas_int ) lda_ = int ( lda , blas_int ) ldb_ = int ( ldb , blas_int ) ldc_ = int ( ldc , blas_int ) call csymm ( side , uplo , m_ , n_ , alpha , a , lda_ , b , ldb_ , beta , c , ldc_ ) end subroutine oqp_csymm_i64 subroutine oqp_csyr2k_i64 ( uplo , trans , n , k , alpha , a , lda , b , ldb , beta , c , ldc ) complex :: alpha complex :: beta integer :: k integer :: lda integer :: ldb integer :: ldc integer :: n character :: trans character :: uplo complex :: a ( lda , * ) complex :: b ( ldb , * ) complex :: c ( ldc , * ) integer ( blas_int ) :: n_ , k_ , lda_ , ldb_ , ldc_ logical :: ok if ( ARG_CHECK ) then ok = . true . ok = ok . and . abs ( n ) <= HUGE_BLAS_INT - 1 ok = ok . and . abs ( k ) <= HUGE_BLAS_INT - 1 ok = ok . and . abs ( lda ) <= HUGE_BLAS_INT - 1 ok = ok . and . abs ( ldb ) <= HUGE_BLAS_INT - 1 ok = ok . and . abs ( ldc ) <= HUGE_BLAS_INT - 1 if (. not . ok ) call show_message ( ERRMSG , WITH_ABORT ) end if n_ = int ( n , blas_int ) k_ = int ( k , blas_int ) lda_ = int ( lda , blas_int ) ldb_ = int ( ldb , blas_int ) ldc_ = int ( ldc , blas_int ) call csyr2k ( uplo , trans , n_ , k_ , alpha , a , lda_ , b , ldb_ , beta , c , ldc_ ) end subroutine oqp_csyr2k_i64 subroutine oqp_csyrk_i64 ( uplo , trans , n , k , alpha , a , lda , beta , c , ldc ) complex :: alpha complex :: beta integer :: k integer :: lda integer :: ldc integer :: n character :: trans character :: uplo complex :: a ( lda , * ) complex :: c ( ldc , * ) integer ( blas_int ) :: n_ , k_ , lda_ , ldc_ logical :: ok if ( ARG_CHECK ) then ok = . true . ok = ok . and . abs ( n ) <= HUGE_BLAS_INT - 1 ok = ok . and . abs ( k ) <= HUGE_BLAS_INT - 1 ok = ok . and . abs ( lda ) <= HUGE_BLAS_INT - 1 ok = ok . and . abs ( ldc ) <= HUGE_BLAS_INT - 1 if (. not . ok ) call show_message ( ERRMSG , WITH_ABORT ) end if n_ = int ( n , blas_int ) k_ = int ( k , blas_int ) lda_ = int ( lda , blas_int ) ldc_ = int ( ldc , blas_int ) call csyrk ( uplo , trans , n_ , k_ , alpha , a , lda_ , beta , c , ldc_ ) end subroutine oqp_csyrk_i64 subroutine oqp_ctbmv_i64 ( uplo , trans , diag , n , k , a , lda , x , incx ) integer :: incx integer :: k integer :: lda integer :: n character :: diag character :: trans character :: uplo complex :: a ( lda , * ) complex :: x ( * ) integer ( blas_int ) :: n_ , k_ , lda_ , incx_ logical :: ok if ( ARG_CHECK ) then ok = . true . ok = ok . and . abs ( n ) <= HUGE_BLAS_INT - 1 ok = ok . and . abs ( k ) <= HUGE_BLAS_INT - 1 ok = ok . and . abs ( lda ) <= HUGE_BLAS_INT - 1 ok = ok . and . abs ( incx ) <= HUGE_BLAS_INT - 1 if (. not . ok ) call show_message ( ERRMSG , WITH_ABORT ) end if n_ = int ( n , blas_int ) k_ = int ( k , blas_int ) lda_ = int ( lda , blas_int ) incx_ = int ( incx , blas_int ) call ctbmv ( uplo , trans , diag , n_ , k_ , a , lda_ , x , incx_ ) end subroutine oqp_ctbmv_i64 subroutine oqp_ctbsv_i64 ( uplo , trans , diag , n , k , a , lda , x , incx ) integer :: incx integer :: k integer :: lda integer :: n character :: diag character :: trans character :: uplo complex :: a ( lda , * ) complex :: x ( * ) integer ( blas_int ) :: n_ , k_ , lda_ , incx_ logical :: ok if ( ARG_CHECK ) then ok = . true . ok = ok . and . abs ( n ) <= HUGE_BLAS_INT - 1 ok = ok . and . abs ( k ) <= HUGE_BLAS_INT - 1 ok = ok . and . abs ( lda ) <= HUGE_BLAS_INT - 1 ok = ok . and . abs ( incx ) <= HUGE_BLAS_INT - 1 if (. not . ok ) call show_message ( ERRMSG , WITH_ABORT ) end if n_ = int ( n , blas_int ) k_ = int ( k , blas_int ) lda_ = int ( lda , blas_int ) incx_ = int ( incx , blas_int ) call ctbsv ( uplo , trans , diag , n_ , k_ , a , lda_ , x , incx_ ) end subroutine oqp_ctbsv_i64 subroutine oqp_ctpmv_i64 ( uplo , trans , diag , n , ap , x , incx ) integer :: incx integer :: n character :: diag character :: trans character :: uplo complex :: ap ( * ) complex :: x ( * ) integer ( blas_int ) :: n_ , incx_ logical :: ok if ( ARG_CHECK ) then ok = . true . ok = ok . and . abs ( n ) <= HUGE_BLAS_INT - 1 ok = ok . and . abs ( incx ) <= HUGE_BLAS_INT - 1 if (. not . ok ) call show_message ( ERRMSG , WITH_ABORT ) end if n_ = int ( n , blas_int ) incx_ = int ( incx , blas_int ) call ctpmv ( uplo , trans , diag , n_ , ap , x , incx_ ) end subroutine oqp_ctpmv_i64 subroutine oqp_ctpsv_i64 ( uplo , trans , diag , n , ap , x , incx ) integer :: incx integer :: n character :: diag character :: trans character :: uplo complex :: ap ( * ) complex :: x ( * ) integer ( blas_int ) :: n_ , incx_ logical :: ok if ( ARG_CHECK ) then ok = . true . ok = ok . and . abs ( n ) <= HUGE_BLAS_INT - 1 ok = ok . and . abs ( incx ) <= HUGE_BLAS_INT - 1 if (. not . ok ) call show_message ( ERRMSG , WITH_ABORT ) end if n_ = int ( n , blas_int ) incx_ = int ( incx , blas_int ) call ctpsv ( uplo , trans , diag , n_ , ap , x , incx_ ) end subroutine oqp_ctpsv_i64 subroutine oqp_ctrmm_i64 ( side , uplo , transa , diag , m , n , alpha , a , lda , b , ldb ) complex :: alpha integer :: lda integer :: ldb integer :: m integer :: n character :: diag character :: side character :: transa character :: uplo complex :: a ( lda , * ) complex :: b ( ldb , * ) integer ( blas_int ) :: m_ , n_ , lda_ , ldb_ logical :: ok if ( ARG_CHECK ) then ok = . true . ok = ok . and . abs ( m ) <= HUGE_BLAS_INT - 1 ok = ok . and . abs ( n ) <= HUGE_BLAS_INT - 1 ok = ok . and . abs ( lda ) <= HUGE_BLAS_INT - 1 ok = ok . and . abs ( ldb ) <= HUGE_BLAS_INT - 1 if (. not . ok ) call show_message ( ERRMSG , WITH_ABORT ) end if m_ = int ( m , blas_int ) n_ = int ( n , blas_int ) lda_ = int ( lda , blas_int ) ldb_ = int ( ldb , blas_int ) call ctrmm ( side , uplo , transa , diag , m_ , n_ , alpha , a , lda_ , b , ldb_ ) end subroutine oqp_ctrmm_i64 subroutine oqp_ctrmv_i64 ( uplo , trans , diag , n , a , lda , x , incx ) integer :: incx integer :: lda integer :: n character :: diag character :: trans character :: uplo complex :: a ( lda , * ) complex :: x ( * ) integer ( blas_int ) :: n_ , lda_ , incx_ logical :: ok if ( ARG_CHECK ) then ok = . true . ok = ok . and . abs ( n ) <= HUGE_BLAS_INT - 1 ok = ok . and . abs ( lda ) <= HUGE_BLAS_INT - 1 ok = ok . and . abs ( incx ) <= HUGE_BLAS_INT - 1 if (. not . ok ) call show_message ( ERRMSG , WITH_ABORT ) end if n_ = int ( n , blas_int ) lda_ = int ( lda , blas_int ) incx_ = int ( incx , blas_int ) call ctrmv ( uplo , trans , diag , n_ , a , lda_ , x , incx_ ) end subroutine oqp_ctrmv_i64 subroutine oqp_ctrsm_i64 ( side , uplo , transa , diag , m , n , alpha , a , lda , b , ldb ) complex :: alpha integer :: lda integer :: ldb integer :: m integer :: n character :: diag character :: side character :: transa character :: uplo complex :: a ( lda , * ) complex :: b ( ldb , * ) integer ( blas_int ) :: m_ , n_ , lda_ , ldb_ logical :: ok if ( ARG_CHECK ) then ok = . true . ok = ok . and . abs ( m ) <= HUGE_BLAS_INT - 1 ok = ok . and . abs ( n ) <= HUGE_BLAS_INT - 1 ok = ok . and . abs ( lda ) <= HUGE_BLAS_INT - 1 ok = ok . and . abs ( ldb ) <= HUGE_BLAS_INT - 1 if (. not . ok ) call show_message ( ERRMSG , WITH_ABORT ) end if m_ = int ( m , blas_int ) n_ = int ( n , blas_int ) lda_ = int ( lda , blas_int ) ldb_ = int ( ldb , blas_int ) call ctrsm ( side , uplo , transa , diag , m_ , n_ , alpha , a , lda_ , b , ldb_ ) end subroutine oqp_ctrsm_i64 subroutine oqp_ctrsv_i64 ( uplo , trans , diag , n , a , lda , x , incx ) integer :: incx integer :: lda integer :: n character :: diag character :: trans character :: uplo complex :: a ( lda , * ) complex :: x ( * ) integer ( blas_int ) :: n_ , lda_ , incx_ logical :: ok if ( ARG_CHECK ) then ok = . true . ok = ok . and . abs ( n ) <= HUGE_BLAS_INT - 1 ok = ok . and . abs ( lda ) <= HUGE_BLAS_INT - 1 ok = ok . and . abs ( incx ) <= HUGE_BLAS_INT - 1 if (. not . ok ) call show_message ( ERRMSG , WITH_ABORT ) end if n_ = int ( n , blas_int ) lda_ = int ( lda , blas_int ) incx_ = int ( incx , blas_int ) call ctrsv ( uplo , trans , diag , n_ , a , lda_ , x , incx_ ) end subroutine oqp_ctrsv_i64 function oqp_dasum_i64 ( n , dx , incx ) double precision , external :: dasum double precision :: oqp_dasum_i64 integer :: incx integer :: n double precision :: dx ( * ) integer ( blas_int ) :: n_ , incx_ logical :: ok if ( ARG_CHECK ) then ok = . true . ok = ok . and . abs ( n ) <= HUGE_BLAS_INT - 1 ok = ok . and . abs ( incx ) <= HUGE_BLAS_INT - 1 if (. not . ok ) call show_message ( ERRMSG , WITH_ABORT ) end if n_ = int ( n , blas_int ) incx_ = int ( incx , blas_int ) oqp_dasum_i64 = dasum ( n_ , dx , incx_ ) end function oqp_dasum_i64 subroutine oqp_daxpy_i64 ( n , da , dx , incx , dy , incy ) double precision :: da integer :: incx integer :: incy integer :: n double precision :: dx ( * ) double precision :: dy ( * ) integer ( blas_int ) :: n_ , incx_ , incy_ logical :: ok if ( ARG_CHECK ) then ok = . true . ok = ok . and . abs ( n ) <= HUGE_BLAS_INT - 1 ok = ok . and . abs ( incx ) <= HUGE_BLAS_INT - 1 ok = ok . and . abs ( incy ) <= HUGE_BLAS_INT - 1 if (. not . ok ) call show_message ( ERRMSG , WITH_ABORT ) end if n_ = int ( n , blas_int ) incx_ = int ( incx , blas_int ) incy_ = int ( incy , blas_int ) call daxpy ( n_ , da , dx , incx_ , dy , incy_ ) end subroutine oqp_daxpy_i64 subroutine oqp_dcopy_i64 ( n , dx , incx , dy , incy ) integer :: incx integer :: incy integer :: n double precision :: dx ( * ) double precision :: dy ( * ) integer ( blas_int ) :: n_ , incx_ , incy_ logical :: ok if ( ARG_CHECK ) then ok = . true . ok = ok . and . abs ( n ) <= HUGE_BLAS_INT - 1 ok = ok . and . abs ( incx ) <= HUGE_BLAS_INT - 1 ok = ok . and . abs ( incy ) <= HUGE_BLAS_INT - 1 if (. not . ok ) call show_message ( ERRMSG , WITH_ABORT ) end if n_ = int ( n , blas_int ) incx_ = int ( incx , blas_int ) incy_ = int ( incy , blas_int ) call dcopy ( n_ , dx , incx_ , dy , incy_ ) end subroutine oqp_dcopy_i64 function oqp_ddot_i64 ( n , dx , incx , dy , incy ) double precision , external :: ddot double precision :: oqp_ddot_i64 integer :: incx integer :: incy integer :: n double precision :: dx ( * ) double precision :: dy ( * ) integer ( blas_int ) :: n_ , incx_ , incy_ logical :: ok if ( ARG_CHECK ) then ok = . true . ok = ok . and . abs ( n ) <= HUGE_BLAS_INT - 1 ok = ok . and . abs ( incx ) <= HUGE_BLAS_INT - 1 ok = ok . and . abs ( incy ) <= HUGE_BLAS_INT - 1 if (. not . ok ) call show_message ( ERRMSG , WITH_ABORT ) end if n_ = int ( n , blas_int ) incx_ = int ( incx , blas_int ) incy_ = int ( incy , blas_int ) oqp_ddot_i64 = ddot ( n_ , dx , incx_ , dy , incy_ ) end function oqp_ddot_i64 subroutine oqp_dgbmv_i64 ( trans , m , n , kl , ku , alpha , a , lda , x , incx , beta , y , incy ) double precision :: alpha double precision :: beta integer :: incx integer :: incy integer :: kl integer :: ku integer :: lda integer :: m integer :: n character :: trans double precision :: a ( lda , * ) double precision :: x ( * ) double precision :: y ( * ) integer ( blas_int ) :: m_ , n_ , kl_ , ku_ , lda_ , incx_ , incy_ logical :: ok if ( ARG_CHECK ) then ok = . true . ok = ok . and . abs ( m ) <= HUGE_BLAS_INT - 1 ok = ok . and . abs ( n ) <= HUGE_BLAS_INT - 1 ok = ok . and . abs ( kl ) <= HUGE_BLAS_INT - 1 ok = ok . and . abs ( ku ) <= HUGE_BLAS_INT - 1 ok = ok . and . abs ( lda ) <= HUGE_BLAS_INT - 1 ok = ok . and . abs ( incx ) <= HUGE_BLAS_INT - 1 ok = ok . and . abs ( incy ) <= HUGE_BLAS_INT - 1 if (. not . ok ) call show_message ( ERRMSG , WITH_ABORT ) end if m_ = int ( m , blas_int ) n_ = int ( n , blas_int ) kl_ = int ( kl , blas_int ) ku_ = int ( ku , blas_int ) lda_ = int ( lda , blas_int ) incx_ = int ( incx , blas_int ) incy_ = int ( incy , blas_int ) call dgbmv ( trans , m_ , n_ , kl_ , ku_ , alpha , a , lda_ , x , incx_ , beta , y , incy_ ) end subroutine oqp_dgbmv_i64 subroutine oqp_dgemm_i64 ( transa , transb , m , n , k , alpha , a , lda , b , ldb , beta , c , ldc ) double precision :: alpha double precision :: beta integer :: k integer :: lda integer :: ldb integer :: ldc integer :: m integer :: n character :: transa character :: transb double precision :: a ( lda , * ) double precision :: b ( ldb , * ) double precision :: c ( ldc , * ) integer ( blas_int ) :: m_ , n_ , k_ , lda_ , ldb_ , ldc_ logical :: ok if ( ARG_CHECK ) then ok = . true . ok = ok . and . abs ( m ) <= HUGE_BLAS_INT - 1 ok = ok . and . abs ( n ) <= HUGE_BLAS_INT - 1 ok = ok . and . abs ( k ) <= HUGE_BLAS_INT - 1 ok = ok . and . abs ( lda ) <= HUGE_BLAS_INT - 1 ok = ok . and . abs ( ldb ) <= HUGE_BLAS_INT - 1 ok = ok . and . abs ( ldc ) <= HUGE_BLAS_INT - 1 if (. not . ok ) call show_message ( ERRMSG , WITH_ABORT ) end if m_ = int ( m , blas_int ) n_ = int ( n , blas_int ) k_ = int ( k , blas_int ) lda_ = int ( lda , blas_int ) ldb_ = int ( ldb , blas_int ) ldc_ = int ( ldc , blas_int ) call dgemm ( transa , transb , m_ , n_ , k_ , alpha , a , lda_ , b , ldb_ , beta , c , ldc_ ) end subroutine oqp_dgemm_i64 subroutine oqp_dgemv_i64 ( trans , m , n , alpha , a , lda , x , incx , beta , y , incy ) double precision :: alpha double precision :: beta integer :: incx integer :: incy integer :: lda integer :: m integer :: n character :: trans double precision :: a ( lda , * ) double precision :: x ( * ) double precision :: y ( * ) integer ( blas_int ) :: m_ , n_ , lda_ , incx_ , incy_ logical :: ok if ( ARG_CHECK ) then ok = . true . ok = ok . and . abs ( m ) <= HUGE_BLAS_INT - 1 ok = ok . and . abs ( n ) <= HUGE_BLAS_INT - 1 ok = ok . and . abs ( lda ) <= HUGE_BLAS_INT - 1 ok = ok . and . abs ( incx ) <= HUGE_BLAS_INT - 1 ok = ok . and . abs ( incy ) <= HUGE_BLAS_INT - 1 if (. not . ok ) call show_message ( ERRMSG , WITH_ABORT ) end if m_ = int ( m , blas_int ) n_ = int ( n , blas_int ) lda_ = int ( lda , blas_int ) incx_ = int ( incx , blas_int ) incy_ = int ( incy , blas_int ) call dgemv ( trans , m_ , n_ , alpha , a , lda_ , x , incx_ , beta , y , incy_ ) end subroutine oqp_dgemv_i64 subroutine oqp_dger_i64 ( m , n , alpha , x , incx , y , incy , a , lda ) double precision :: alpha integer :: incx integer :: incy integer :: lda integer :: m integer :: n double precision :: a ( lda , * ) double precision :: x ( * ) double precision :: y ( * ) integer ( blas_int ) :: m_ , n_ , incx_ , incy_ , lda_ logical :: ok if ( ARG_CHECK ) then ok = . true . ok = ok . and . abs ( m ) <= HUGE_BLAS_INT - 1 ok = ok . and . abs ( n ) <= HUGE_BLAS_INT - 1 ok = ok . and . abs ( incx ) <= HUGE_BLAS_INT - 1 ok = ok . and . abs ( incy ) <= HUGE_BLAS_INT - 1 ok = ok . and . abs ( lda ) <= HUGE_BLAS_INT - 1 if (. not . ok ) call show_message ( ERRMSG , WITH_ABORT ) end if m_ = int ( m , blas_int ) n_ = int ( n , blas_int ) incx_ = int ( incx , blas_int ) incy_ = int ( incy , blas_int ) lda_ = int ( lda , blas_int ) call dger ( m_ , n_ , alpha , x , incx_ , y , incy_ , a , lda_ ) end subroutine oqp_dger_i64 subroutine oqp_drot_i64 ( n , dx , incx , dy , incy , c , s ) double precision :: c double precision :: s integer :: incx integer :: incy integer :: n double precision :: dx ( * ) double precision :: dy ( * ) integer ( blas_int ) :: n_ , incx_ , incy_ logical :: ok if ( ARG_CHECK ) then ok = . true . ok = ok . and . abs ( n ) <= HUGE_BLAS_INT - 1 ok = ok . and . abs ( incx ) <= HUGE_BLAS_INT - 1 ok = ok . and . abs ( incy ) <= HUGE_BLAS_INT - 1 if (. not . ok ) call show_message ( ERRMSG , WITH_ABORT ) end if n_ = int ( n , blas_int ) incx_ = int ( incx , blas_int ) incy_ = int ( incy , blas_int ) call drot ( n_ , dx , incx_ , dy , incy_ , c , s ) end subroutine oqp_drot_i64 subroutine oqp_drotm_i64 ( n , dx , incx , dy , incy , dparam ) integer :: incx integer :: incy integer :: n double precision :: dparam ( 5 ) double precision :: dx ( * ) double precision :: dy ( * ) integer ( blas_int ) :: n_ , incx_ , incy_ logical :: ok if ( ARG_CHECK ) then ok = . true . ok = ok . and . abs ( n ) <= HUGE_BLAS_INT - 1 ok = ok . and . abs ( incx ) <= HUGE_BLAS_INT - 1 ok = ok . and . abs ( incy ) <= HUGE_BLAS_INT - 1 if (. not . ok ) call show_message ( ERRMSG , WITH_ABORT ) end if n_ = int ( n , blas_int ) incx_ = int ( incx , blas_int ) incy_ = int ( incy , blas_int ) call drotm ( n_ , dx , incx_ , dy , incy_ , dparam ) end subroutine oqp_drotm_i64 subroutine oqp_dsbmv_i64 ( uplo , n , k , alpha , a , lda , x , incx , beta , y , incy ) double precision :: alpha double precision :: beta integer :: incx integer :: incy integer :: k integer :: lda integer :: n character :: uplo double precision :: a ( lda , * ) double precision :: x ( * ) double precision :: y ( * ) integer ( blas_int ) :: n_ , k_ , lda_ , incx_ , incy_ logical :: ok if ( ARG_CHECK ) then ok = . true . ok = ok . and . abs ( n ) <= HUGE_BLAS_INT - 1 ok = ok . and . abs ( k ) <= HUGE_BLAS_INT - 1 ok = ok . and . abs ( lda ) <= HUGE_BLAS_INT - 1 ok = ok . and . abs ( incx ) <= HUGE_BLAS_INT - 1 ok = ok . and . abs ( incy ) <= HUGE_BLAS_INT - 1 if (. not . ok ) call show_message ( ERRMSG , WITH_ABORT ) end if n_ = int ( n , blas_int ) k_ = int ( k , blas_int ) lda_ = int ( lda , blas_int ) incx_ = int ( incx , blas_int ) incy_ = int ( incy , blas_int ) call dsbmv ( uplo , n_ , k_ , alpha , a , lda_ , x , incx_ , beta , y , incy_ ) end subroutine oqp_dsbmv_i64 subroutine oqp_dscal_i64 ( n , da , dx , incx ) double precision :: da integer :: incx integer :: n double precision :: dx ( * ) integer ( blas_int ) :: n_ , incx_ logical :: ok if ( ARG_CHECK ) then ok = . true . ok = ok . and . abs ( n ) <= HUGE_BLAS_INT - 1 ok = ok . and . abs ( incx ) <= HUGE_BLAS_INT - 1 if (. not . ok ) call show_message ( ERRMSG , WITH_ABORT ) end if n_ = int ( n , blas_int ) incx_ = int ( incx , blas_int ) call dscal ( n_ , da , dx , incx_ ) end subroutine oqp_dscal_i64 function oqp_dsdot_i64 ( n , sx , incx , sy , incy ) double precision , external :: dsdot double precision :: oqp_dsdot_i64 integer :: incx integer :: incy integer :: n real :: sx ( * ) real :: sy ( * ) integer ( blas_int ) :: n_ , incx_ , incy_ logical :: ok if ( ARG_CHECK ) then ok = . true . ok = ok . and . abs ( n ) <= HUGE_BLAS_INT - 1 ok = ok . and . abs ( incx ) <= HUGE_BLAS_INT - 1 ok = ok . and . abs ( incy ) <= HUGE_BLAS_INT - 1 if (. not . ok ) call show_message ( ERRMSG , WITH_ABORT ) end if n_ = int ( n , blas_int ) incx_ = int ( incx , blas_int ) incy_ = int ( incy , blas_int ) oqp_dsdot_i64 = dsdot ( n_ , sx , incx_ , sy , incy_ ) end function oqp_dsdot_i64 subroutine oqp_dspmv_i64 ( uplo , n , alpha , ap , x , incx , beta , y , incy ) double precision :: alpha double precision :: beta integer :: incx integer :: incy integer :: n character :: uplo double precision :: ap ( * ) double precision :: x ( * ) double precision :: y ( * ) integer ( blas_int ) :: n_ , incx_ , incy_ logical :: ok if ( ARG_CHECK ) then ok = . true . ok = ok . and . abs ( n ) <= HUGE_BLAS_INT - 1 ok = ok . and . abs ( incx ) <= HUGE_BLAS_INT - 1 ok = ok . and . abs ( incy ) <= HUGE_BLAS_INT - 1 if (. not . ok ) call show_message ( ERRMSG , WITH_ABORT ) end if n_ = int ( n , blas_int ) incx_ = int ( incx , blas_int ) incy_ = int ( incy , blas_int ) call dspmv ( uplo , n_ , alpha , ap , x , incx_ , beta , y , incy_ ) end subroutine oqp_dspmv_i64 subroutine oqp_dspr_i64 ( uplo , n , alpha , x , incx , ap ) double precision :: alpha integer :: incx integer :: n character :: uplo double precision :: ap ( * ) double precision :: x ( * ) integer ( blas_int ) :: n_ , incx_ logical :: ok if ( ARG_CHECK ) then ok = . true . ok = ok . and . abs ( n ) <= HUGE_BLAS_INT - 1 ok = ok . and . abs ( incx ) <= HUGE_BLAS_INT - 1 if (. not . ok ) call show_message ( ERRMSG , WITH_ABORT ) end if n_ = int ( n , blas_int ) incx_ = int ( incx , blas_int ) call dspr ( uplo , n_ , alpha , x , incx_ , ap ) end subroutine oqp_dspr_i64 subroutine oqp_dspr2_i64 ( uplo , n , alpha , x , incx , y , incy , ap ) double precision :: alpha integer :: incx integer :: incy integer :: n character :: uplo double precision :: ap ( * ) double precision :: x ( * ) double precision :: y ( * ) integer ( blas_int ) :: n_ , incx_ , incy_ logical :: ok if ( ARG_CHECK ) then ok = . true . ok = ok . and . abs ( n ) <= HUGE_BLAS_INT - 1 ok = ok . and . abs ( incx ) <= HUGE_BLAS_INT - 1 ok = ok . and . abs ( incy ) <= HUGE_BLAS_INT - 1 if (. not . ok ) call show_message ( ERRMSG , WITH_ABORT ) end if n_ = int ( n , blas_int ) incx_ = int ( incx , blas_int ) incy_ = int ( incy , blas_int ) call dspr2 ( uplo , n_ , alpha , x , incx_ , y , incy_ , ap ) end subroutine oqp_dspr2_i64 subroutine oqp_dswap_i64 ( n , dx , incx , dy , incy ) integer :: incx integer :: incy integer :: n double precision :: dx ( * ) double precision :: dy ( * ) integer ( blas_int ) :: n_ , incx_ , incy_ logical :: ok if ( ARG_CHECK ) then ok = . true . ok = ok . and . abs ( n ) <= HUGE_BLAS_INT - 1 ok = ok . and . abs ( incx ) <= HUGE_BLAS_INT - 1 ok = ok . and . abs ( incy ) <= HUGE_BLAS_INT - 1 if (. not . ok ) call show_message ( ERRMSG , WITH_ABORT ) end if n_ = int ( n , blas_int ) incx_ = int ( incx , blas_int ) incy_ = int ( incy , blas_int ) call dswap ( n_ , dx , incx_ , dy , incy_ ) end subroutine oqp_dswap_i64 subroutine oqp_dsymm_i64 ( side , uplo , m , n , alpha , a , lda , b , ldb , beta , c , ldc ) double precision :: alpha double precision :: beta integer :: lda integer :: ldb integer :: ldc integer :: m integer :: n character :: side character :: uplo double precision :: a ( lda , * ) double precision :: b ( ldb , * ) double precision :: c ( ldc , * ) integer ( blas_int ) :: m_ , n_ , lda_ , ldb_ , ldc_ logical :: ok if ( ARG_CHECK ) then ok = . true . ok = ok . and . abs ( m ) <= HUGE_BLAS_INT - 1 ok = ok . and . abs ( n ) <= HUGE_BLAS_INT - 1 ok = ok . and . abs ( lda ) <= HUGE_BLAS_INT - 1 ok = ok . and . abs ( ldb ) <= HUGE_BLAS_INT - 1 ok = ok . and . abs ( ldc ) <= HUGE_BLAS_INT - 1 if (. not . ok ) call show_message ( ERRMSG , WITH_ABORT ) end if m_ = int ( m , blas_int ) n_ = int ( n , blas_int ) lda_ = int ( lda , blas_int ) ldb_ = int ( ldb , blas_int ) ldc_ = int ( ldc , blas_int ) call dsymm ( side , uplo , m_ , n_ , alpha , a , lda_ , b , ldb_ , beta , c , ldc_ ) end subroutine oqp_dsymm_i64 subroutine oqp_dsymv_i64 ( uplo , n , alpha , a , lda , x , incx , beta , y , incy ) double precision :: alpha double precision :: beta integer :: incx integer :: incy integer :: lda integer :: n character :: uplo double precision :: a ( lda , * ) double precision :: x ( * ) double precision :: y ( * ) integer ( blas_int ) :: n_ , lda_ , incx_ , incy_ logical :: ok if ( ARG_CHECK ) then ok = . true . ok = ok . and . abs ( n ) <= HUGE_BLAS_INT - 1 ok = ok . and . abs ( lda ) <= HUGE_BLAS_INT - 1 ok = ok . and . abs ( incx ) <= HUGE_BLAS_INT - 1 ok = ok . and . abs ( incy ) <= HUGE_BLAS_INT - 1 if (. not . ok ) call show_message ( ERRMSG , WITH_ABORT ) end if n_ = int ( n , blas_int ) lda_ = int ( lda , blas_int ) incx_ = int ( incx , blas_int ) incy_ = int ( incy , blas_int ) call dsymv ( uplo , n_ , alpha , a , lda_ , x , incx_ , beta , y , incy_ ) end subroutine oqp_dsymv_i64 subroutine oqp_dsyr_i64 ( uplo , n , alpha , x , incx , a , lda ) double precision :: alpha integer :: incx integer :: lda integer :: n character :: uplo double precision :: a ( lda , * ) double precision :: x ( * ) integer ( blas_int ) :: n_ , incx_ , lda_ logical :: ok if ( ARG_CHECK ) then ok = . true . ok = ok . and . abs ( n ) <= HUGE_BLAS_INT - 1 ok = ok . and . abs ( incx ) <= HUGE_BLAS_INT - 1 ok = ok . and . abs ( lda ) <= HUGE_BLAS_INT - 1 if (. not . ok ) call show_message ( ERRMSG , WITH_ABORT ) end if n_ = int ( n , blas_int ) incx_ = int ( incx , blas_int ) lda_ = int ( lda , blas_int ) call dsyr ( uplo , n_ , alpha , x , incx_ , a , lda_ ) end subroutine oqp_dsyr_i64 subroutine oqp_dsyr2_i64 ( uplo , n , alpha , x , incx , y , incy , a , lda ) double precision :: alpha integer :: incx integer :: incy integer :: lda integer :: n character :: uplo double precision :: a ( lda , * ) double precision :: x ( * ) double precision :: y ( * ) integer ( blas_int ) :: n_ , incx_ , incy_ , lda_ logical :: ok if ( ARG_CHECK ) then ok = . true . ok = ok . and . abs ( n ) <= HUGE_BLAS_INT - 1 ok = ok . and . abs ( incx ) <= HUGE_BLAS_INT - 1 ok = ok . and . abs ( incy ) <= HUGE_BLAS_INT - 1 ok = ok . and . abs ( lda ) <= HUGE_BLAS_INT - 1 if (. not . ok ) call show_message ( ERRMSG , WITH_ABORT ) end if n_ = int ( n , blas_int ) incx_ = int ( incx , blas_int ) incy_ = int ( incy , blas_int ) lda_ = int ( lda , blas_int ) call dsyr2 ( uplo , n_ , alpha , x , incx_ , y , incy_ , a , lda_ ) end subroutine oqp_dsyr2_i64 subroutine oqp_dsyr2k_i64 ( uplo , trans , n , k , alpha , a , lda , b , ldb , beta , c , ldc ) double precision :: alpha double precision :: beta integer :: k integer :: lda integer :: ldb integer :: ldc integer :: n character :: trans character :: uplo double precision :: a ( lda , * ) double precision :: b ( ldb , * ) double precision :: c ( ldc , * ) integer ( blas_int ) :: n_ , k_ , lda_ , ldb_ , ldc_ logical :: ok if ( ARG_CHECK ) then ok = . true . ok = ok . and . abs ( n ) <= HUGE_BLAS_INT - 1 ok = ok . and . abs ( k ) <= HUGE_BLAS_INT - 1 ok = ok . and . abs ( lda ) <= HUGE_BLAS_INT - 1 ok = ok . and . abs ( ldb ) <= HUGE_BLAS_INT - 1 ok = ok . and . abs ( ldc ) <= HUGE_BLAS_INT - 1 if (. not . ok ) call show_message ( ERRMSG , WITH_ABORT ) end if n_ = int ( n , blas_int ) k_ = int ( k , blas_int ) lda_ = int ( lda , blas_int ) ldb_ = int ( ldb , blas_int ) ldc_ = int ( ldc , blas_int ) call dsyr2k ( uplo , trans , n_ , k_ , alpha , a , lda_ , b , ldb_ , beta , c , ldc_ ) end subroutine oqp_dsyr2k_i64 subroutine oqp_dsyrk_i64 ( uplo , trans , n , k , alpha , a , lda , beta , c , ldc ) double precision :: alpha double precision :: beta integer :: k integer :: lda integer :: ldc integer :: n character :: trans character :: uplo double precision :: a ( lda , * ) double precision :: c ( ldc , * ) integer ( blas_int ) :: n_ , k_ , lda_ , ldc_ logical :: ok if ( ARG_CHECK ) then ok = . true . ok = ok . and . abs ( n ) <= HUGE_BLAS_INT - 1 ok = ok . and . abs ( k ) <= HUGE_BLAS_INT - 1 ok = ok . and . abs ( lda ) <= HUGE_BLAS_INT - 1 ok = ok . and . abs ( ldc ) <= HUGE_BLAS_INT - 1 if (. not . ok ) call show_message ( ERRMSG , WITH_ABORT ) end if n_ = int ( n , blas_int ) k_ = int ( k , blas_int ) lda_ = int ( lda , blas_int ) ldc_ = int ( ldc , blas_int ) call dsyrk ( uplo , trans , n_ , k_ , alpha , a , lda_ , beta , c , ldc_ ) end subroutine oqp_dsyrk_i64 subroutine oqp_dtbmv_i64 ( uplo , trans , diag , n , k , a , lda , x , incx ) integer :: incx integer :: k integer :: lda integer :: n character :: diag character :: trans character :: uplo double precision :: a ( lda , * ) double precision :: x ( * ) integer ( blas_int ) :: n_ , k_ , lda_ , incx_ logical :: ok if ( ARG_CHECK ) then ok = . true . ok = ok . and . abs ( n ) <= HUGE_BLAS_INT - 1 ok = ok . and . abs ( k ) <= HUGE_BLAS_INT - 1 ok = ok . and . abs ( lda ) <= HUGE_BLAS_INT - 1 ok = ok . and . abs ( incx ) <= HUGE_BLAS_INT - 1 if (. not . ok ) call show_message ( ERRMSG , WITH_ABORT ) end if n_ = int ( n , blas_int ) k_ = int ( k , blas_int ) lda_ = int ( lda , blas_int ) incx_ = int ( incx , blas_int ) call dtbmv ( uplo , trans , diag , n_ , k_ , a , lda_ , x , incx_ ) end subroutine oqp_dtbmv_i64 subroutine oqp_dtbsv_i64 ( uplo , trans , diag , n , k , a , lda , x , incx ) integer :: incx integer :: k integer :: lda integer :: n character :: diag character :: trans character :: uplo double precision :: a ( lda , * ) double precision :: x ( * ) integer ( blas_int ) :: n_ , k_ , lda_ , incx_ logical :: ok if ( ARG_CHECK ) then ok = . true . ok = ok . and . abs ( n ) <= HUGE_BLAS_INT - 1 ok = ok . and . abs ( k ) <= HUGE_BLAS_INT - 1 ok = ok . and . abs ( lda ) <= HUGE_BLAS_INT - 1 ok = ok . and . abs ( incx ) <= HUGE_BLAS_INT - 1 if (. not . ok ) call show_message ( ERRMSG , WITH_ABORT ) end if n_ = int ( n , blas_int ) k_ = int ( k , blas_int ) lda_ = int ( lda , blas_int ) incx_ = int ( incx , blas_int ) call dtbsv ( uplo , trans , diag , n_ , k_ , a , lda_ , x , incx_ ) end subroutine oqp_dtbsv_i64 subroutine oqp_dtpmv_i64 ( uplo , trans , diag , n , ap , x , incx ) integer :: incx integer :: n character :: diag character :: trans character :: uplo double precision :: ap ( * ) double precision :: x ( * ) integer ( blas_int ) :: n_ , incx_ logical :: ok if ( ARG_CHECK ) then ok = . true . ok = ok . and . abs ( n ) <= HUGE_BLAS_INT - 1 ok = ok . and . abs ( incx ) <= HUGE_BLAS_INT - 1 if (. not . ok ) call show_message ( ERRMSG , WITH_ABORT ) end if n_ = int ( n , blas_int ) incx_ = int ( incx , blas_int ) call dtpmv ( uplo , trans , diag , n_ , ap , x , incx_ ) end subroutine oqp_dtpmv_i64 subroutine oqp_dtpsv_i64 ( uplo , trans , diag , n , ap , x , incx ) integer :: incx integer :: n character :: diag character :: trans character :: uplo double precision :: ap ( * ) double precision :: x ( * ) integer ( blas_int ) :: n_ , incx_ logical :: ok if ( ARG_CHECK ) then ok = . true . ok = ok . and . abs ( n ) <= HUGE_BLAS_INT - 1 ok = ok . and . abs ( incx ) <= HUGE_BLAS_INT - 1 if (. not . ok ) call show_message ( ERRMSG , WITH_ABORT ) end if n_ = int ( n , blas_int ) incx_ = int ( incx , blas_int ) call dtpsv ( uplo , trans , diag , n_ , ap , x , incx_ ) end subroutine oqp_dtpsv_i64 subroutine oqp_dtrmm_i64 ( side , uplo , transa , diag , m , n , alpha , a , lda , b , ldb ) double precision :: alpha integer :: lda integer :: ldb integer :: m integer :: n character :: diag character :: side character :: transa character :: uplo double precision :: a ( lda , * ) double precision :: b ( ldb , * ) integer ( blas_int ) :: m_ , n_ , lda_ , ldb_ logical :: ok if ( ARG_CHECK ) then ok = . true . ok = ok . and . abs ( m ) <= HUGE_BLAS_INT - 1 ok = ok . and . abs ( n ) <= HUGE_BLAS_INT - 1 ok = ok . and . abs ( lda ) <= HUGE_BLAS_INT - 1 ok = ok . and . abs ( ldb ) <= HUGE_BLAS_INT - 1 if (. not . ok ) call show_message ( ERRMSG , WITH_ABORT ) end if m_ = int ( m , blas_int ) n_ = int ( n , blas_int ) lda_ = int ( lda , blas_int ) ldb_ = int ( ldb , blas_int ) call dtrmm ( side , uplo , transa , diag , m_ , n_ , alpha , a , lda_ , b , ldb_ ) end subroutine oqp_dtrmm_i64 subroutine oqp_dtrmv_i64 ( uplo , trans , diag , n , a , lda , x , incx ) integer :: incx integer :: lda integer :: n character :: diag character :: trans character :: uplo double precision :: a ( lda , * ) double precision :: x ( * ) integer ( blas_int ) :: n_ , lda_ , incx_ logical :: ok if ( ARG_CHECK ) then ok = . true . ok = ok . and . abs ( n ) <= HUGE_BLAS_INT - 1 ok = ok . and . abs ( lda ) <= HUGE_BLAS_INT - 1 ok = ok . and . abs ( incx ) <= HUGE_BLAS_INT - 1 if (. not . ok ) call show_message ( ERRMSG , WITH_ABORT ) end if n_ = int ( n , blas_int ) lda_ = int ( lda , blas_int ) incx_ = int ( incx , blas_int ) call dtrmv ( uplo , trans , diag , n_ , a , lda_ , x , incx_ ) end subroutine oqp_dtrmv_i64 subroutine oqp_dtrsm_i64 ( side , uplo , transa , diag , m , n , alpha , a , lda , b , ldb ) double precision :: alpha integer :: lda integer :: ldb integer :: m integer :: n character :: diag character :: side character :: transa character :: uplo double precision :: a ( lda , * ) double precision :: b ( ldb , * ) integer ( blas_int ) :: m_ , n_ , lda_ , ldb_ logical :: ok if ( ARG_CHECK ) then ok = . true . ok = ok . and . abs ( m ) <= HUGE_BLAS_INT - 1 ok = ok . and . abs ( n ) <= HUGE_BLAS_INT - 1 ok = ok . and . abs ( lda ) <= HUGE_BLAS_INT - 1 ok = ok . and . abs ( ldb ) <= HUGE_BLAS_INT - 1 if (. not . ok ) call show_message ( ERRMSG , WITH_ABORT ) end if m_ = int ( m , blas_int ) n_ = int ( n , blas_int ) lda_ = int ( lda , blas_int ) ldb_ = int ( ldb , blas_int ) call dtrsm ( side , uplo , transa , diag , m_ , n_ , alpha , a , lda_ , b , ldb_ ) end subroutine oqp_dtrsm_i64 subroutine oqp_dtrsv_i64 ( uplo , trans , diag , n , a , lda , x , incx ) integer :: incx integer :: lda integer :: n character :: diag character :: trans character :: uplo double precision :: a ( lda , * ) double precision :: x ( * ) integer ( blas_int ) :: n_ , lda_ , incx_ logical :: ok if ( ARG_CHECK ) then ok = . true . ok = ok . and . abs ( n ) <= HUGE_BLAS_INT - 1 ok = ok . and . abs ( lda ) <= HUGE_BLAS_INT - 1 ok = ok . and . abs ( incx ) <= HUGE_BLAS_INT - 1 if (. not . ok ) call show_message ( ERRMSG , WITH_ABORT ) end if n_ = int ( n , blas_int ) lda_ = int ( lda , blas_int ) incx_ = int ( incx , blas_int ) call dtrsv ( uplo , trans , diag , n_ , a , lda_ , x , incx_ ) end subroutine oqp_dtrsv_i64 function oqp_dzasum_i64 ( n , zx , incx ) double precision , external :: dzasum double precision :: oqp_dzasum_i64 integer :: incx integer :: n complex ( kind = 8 ) :: zx ( * ) integer ( blas_int ) :: n_ , incx_ logical :: ok if ( ARG_CHECK ) then ok = . true . ok = ok . and . abs ( n ) <= HUGE_BLAS_INT - 1 ok = ok . and . abs ( incx ) <= HUGE_BLAS_INT - 1 if (. not . ok ) call show_message ( ERRMSG , WITH_ABORT ) end if n_ = int ( n , blas_int ) incx_ = int ( incx , blas_int ) oqp_dzasum_i64 = dzasum ( n_ , zx , incx_ ) end function oqp_dzasum_i64 function oqp_icamax_i64 ( n , cx , incx ) integer ( blas_int ), external :: icamax integer :: oqp_icamax_i64 integer :: incx integer :: n complex :: cx ( * ) integer ( blas_int ) :: n_ , incx_ logical :: ok if ( ARG_CHECK ) then ok = . true . ok = ok . and . abs ( n ) <= HUGE_BLAS_INT - 1 ok = ok . and . abs ( incx ) <= HUGE_BLAS_INT - 1 if (. not . ok ) call show_message ( ERRMSG , WITH_ABORT ) end if n_ = int ( n , blas_int ) incx_ = int ( incx , blas_int ) oqp_icamax_i64 = icamax ( n_ , cx , incx_ ) end function oqp_icamax_i64 function oqp_idamax_i64 ( n , dx , incx ) integer ( blas_int ), external :: idamax integer :: oqp_idamax_i64 integer :: incx integer :: n double precision :: dx ( * ) integer ( blas_int ) :: n_ , incx_ logical :: ok if ( ARG_CHECK ) then ok = . true . ok = ok . and . abs ( n ) <= HUGE_BLAS_INT - 1 ok = ok . and . abs ( incx ) <= HUGE_BLAS_INT - 1 if (. not . ok ) call show_message ( ERRMSG , WITH_ABORT ) end if n_ = int ( n , blas_int ) incx_ = int ( incx , blas_int ) oqp_idamax_i64 = idamax ( n_ , dx , incx_ ) end function oqp_idamax_i64 function oqp_isamax_i64 ( n , sx , incx ) integer ( blas_int ), external :: isamax integer :: oqp_isamax_i64 integer :: incx integer :: n real :: sx ( * ) integer ( blas_int ) :: n_ , incx_ logical :: ok if ( ARG_CHECK ) then ok = . true . ok = ok . and . abs ( n ) <= HUGE_BLAS_INT - 1 ok = ok . and . abs ( incx ) <= HUGE_BLAS_INT - 1 if (. not . ok ) call show_message ( ERRMSG , WITH_ABORT ) end if n_ = int ( n , blas_int ) incx_ = int ( incx , blas_int ) oqp_isamax_i64 = isamax ( n_ , sx , incx_ ) end function oqp_isamax_i64 function oqp_izamax_i64 ( n , zx , incx ) integer ( blas_int ), external :: izamax integer :: oqp_izamax_i64 integer :: incx integer :: n complex ( kind = 8 ) :: zx ( * ) integer ( blas_int ) :: n_ , incx_ logical :: ok if ( ARG_CHECK ) then ok = . true . ok = ok . and . abs ( n ) <= HUGE_BLAS_INT - 1 ok = ok . and . abs ( incx ) <= HUGE_BLAS_INT - 1 if (. not . ok ) call show_message ( ERRMSG , WITH_ABORT ) end if n_ = int ( n , blas_int ) incx_ = int ( incx , blas_int ) oqp_izamax_i64 = izamax ( n_ , zx , incx_ ) end function oqp_izamax_i64 function oqp_sasum_i64 ( n , sx , incx ) real , external :: sasum real :: oqp_sasum_i64 integer :: incx integer :: n real :: sx ( * ) integer ( blas_int ) :: n_ , incx_ logical :: ok if ( ARG_CHECK ) then ok = . true . ok = ok . and . abs ( n ) <= HUGE_BLAS_INT - 1 ok = ok . and . abs ( incx ) <= HUGE_BLAS_INT - 1 if (. not . ok ) call show_message ( ERRMSG , WITH_ABORT ) end if n_ = int ( n , blas_int ) incx_ = int ( incx , blas_int ) oqp_sasum_i64 = sasum ( n_ , sx , incx_ ) end function oqp_sasum_i64 subroutine oqp_saxpy_i64 ( n , sa , sx , incx , sy , incy ) real :: sa integer :: incx integer :: incy integer :: n real :: sx ( * ) real :: sy ( * ) integer ( blas_int ) :: n_ , incx_ , incy_ logical :: ok if ( ARG_CHECK ) then ok = . true . ok = ok . and . abs ( n ) <= HUGE_BLAS_INT - 1 ok = ok . and . abs ( incx ) <= HUGE_BLAS_INT - 1 ok = ok . and . abs ( incy ) <= HUGE_BLAS_INT - 1 if (. not . ok ) call show_message ( ERRMSG , WITH_ABORT ) end if n_ = int ( n , blas_int ) incx_ = int ( incx , blas_int ) incy_ = int ( incy , blas_int ) call saxpy ( n_ , sa , sx , incx_ , sy , incy_ ) end subroutine oqp_saxpy_i64 function oqp_scasum_i64 ( n , cx , incx ) real , external :: scasum real :: oqp_scasum_i64 integer :: incx integer :: n complex :: cx ( * ) integer ( blas_int ) :: n_ , incx_ logical :: ok if ( ARG_CHECK ) then ok = . true . ok = ok . and . abs ( n ) <= HUGE_BLAS_INT - 1 ok = ok . and . abs ( incx ) <= HUGE_BLAS_INT - 1 if (. not . ok ) call show_message ( ERRMSG , WITH_ABORT ) end if n_ = int ( n , blas_int ) incx_ = int ( incx , blas_int ) oqp_scasum_i64 = scasum ( n_ , cx , incx_ ) end function oqp_scasum_i64 subroutine oqp_scopy_i64 ( n , sx , incx , sy , incy ) integer :: incx integer :: incy integer :: n real :: sx ( * ) real :: sy ( * ) integer ( blas_int ) :: n_ , incx_ , incy_ logical :: ok if ( ARG_CHECK ) then ok = . true . ok = ok . and . abs ( n ) <= HUGE_BLAS_INT - 1 ok = ok . and . abs ( incx ) <= HUGE_BLAS_INT - 1 ok = ok . and . abs ( incy ) <= HUGE_BLAS_INT - 1 if (. not . ok ) call show_message ( ERRMSG , WITH_ABORT ) end if n_ = int ( n , blas_int ) incx_ = int ( incx , blas_int ) incy_ = int ( incy , blas_int ) call scopy ( n_ , sx , incx_ , sy , incy_ ) end subroutine oqp_scopy_i64 function oqp_sdot_i64 ( n , sx , incx , sy , incy ) real , external :: sdot real :: oqp_sdot_i64 integer :: incx integer :: incy integer :: n real :: sx ( * ) real :: sy ( * ) integer ( blas_int ) :: n_ , incx_ , incy_ logical :: ok if ( ARG_CHECK ) then ok = . true . ok = ok . and . abs ( n ) <= HUGE_BLAS_INT - 1 ok = ok . and . abs ( incx ) <= HUGE_BLAS_INT - 1 ok = ok . and . abs ( incy ) <= HUGE_BLAS_INT - 1 if (. not . ok ) call show_message ( ERRMSG , WITH_ABORT ) end if n_ = int ( n , blas_int ) incx_ = int ( incx , blas_int ) incy_ = int ( incy , blas_int ) oqp_sdot_i64 = sdot ( n_ , sx , incx_ , sy , incy_ ) end function oqp_sdot_i64 function oqp_sdsdot_i64 ( n , sb , sx , incx , sy , incy ) real , external :: sdsdot real :: oqp_sdsdot_i64 real :: sb integer :: incx integer :: incy integer :: n real :: sx ( * ) real :: sy ( * ) integer ( blas_int ) :: n_ , incx_ , incy_ logical :: ok if ( ARG_CHECK ) then ok = . true . ok = ok . and . abs ( n ) <= HUGE_BLAS_INT - 1 ok = ok . and . abs ( incx ) <= HUGE_BLAS_INT - 1 ok = ok . and . abs ( incy ) <= HUGE_BLAS_INT - 1 if (. not . ok ) call show_message ( ERRMSG , WITH_ABORT ) end if n_ = int ( n , blas_int ) incx_ = int ( incx , blas_int ) incy_ = int ( incy , blas_int ) oqp_sdsdot_i64 = sdsdot ( n_ , sb , sx , incx_ , sy , incy_ ) end function oqp_sdsdot_i64 subroutine oqp_sgbmv_i64 ( trans , m , n , kl , ku , alpha , a , lda , x , incx , beta , y , incy ) real :: alpha real :: beta integer :: incx integer :: incy integer :: kl integer :: ku integer :: lda integer :: m integer :: n character :: trans real :: a ( lda , * ) real :: x ( * ) real :: y ( * ) integer ( blas_int ) :: m_ , n_ , kl_ , ku_ , lda_ , incx_ , incy_ logical :: ok if ( ARG_CHECK ) then ok = . true . ok = ok . and . abs ( m ) <= HUGE_BLAS_INT - 1 ok = ok . and . abs ( n ) <= HUGE_BLAS_INT - 1 ok = ok . and . abs ( kl ) <= HUGE_BLAS_INT - 1 ok = ok . and . abs ( ku ) <= HUGE_BLAS_INT - 1 ok = ok . and . abs ( lda ) <= HUGE_BLAS_INT - 1 ok = ok . and . abs ( incx ) <= HUGE_BLAS_INT - 1 ok = ok . and . abs ( incy ) <= HUGE_BLAS_INT - 1 if (. not . ok ) call show_message ( ERRMSG , WITH_ABORT ) end if m_ = int ( m , blas_int ) n_ = int ( n , blas_int ) kl_ = int ( kl , blas_int ) ku_ = int ( ku , blas_int ) lda_ = int ( lda , blas_int ) incx_ = int ( incx , blas_int ) incy_ = int ( incy , blas_int ) call sgbmv ( trans , m_ , n_ , kl_ , ku_ , alpha , a , lda_ , x , incx_ , beta , y , incy_ ) end subroutine oqp_sgbmv_i64 subroutine oqp_sgemm_i64 ( transa , transb , m , n , k , alpha , a , lda , b , ldb , beta , c , ldc ) real :: alpha real :: beta integer :: k integer :: lda integer :: ldb integer :: ldc integer :: m integer :: n character :: transa character :: transb real :: a ( lda , * ) real :: b ( ldb , * ) real :: c ( ldc , * ) integer ( blas_int ) :: m_ , n_ , k_ , lda_ , ldb_ , ldc_ logical :: ok if ( ARG_CHECK ) then ok = . true . ok = ok . and . abs ( m ) <= HUGE_BLAS_INT - 1 ok = ok . and . abs ( n ) <= HUGE_BLAS_INT - 1 ok = ok . and . abs ( k ) <= HUGE_BLAS_INT - 1 ok = ok . and . abs ( lda ) <= HUGE_BLAS_INT - 1 ok = ok . and . abs ( ldb ) <= HUGE_BLAS_INT - 1 ok = ok . and . abs ( ldc ) <= HUGE_BLAS_INT - 1 if (. not . ok ) call show_message ( ERRMSG , WITH_ABORT ) end if m_ = int ( m , blas_int ) n_ = int ( n , blas_int ) k_ = int ( k , blas_int ) lda_ = int ( lda , blas_int ) ldb_ = int ( ldb , blas_int ) ldc_ = int ( ldc , blas_int ) call sgemm ( transa , transb , m_ , n_ , k_ , alpha , a , lda_ , b , ldb_ , beta , c , ldc_ ) end subroutine oqp_sgemm_i64 subroutine oqp_sgemv_i64 ( trans , m , n , alpha , a , lda , x , incx , beta , y , incy ) real :: alpha real :: beta integer :: incx integer :: incy integer :: lda integer :: m integer :: n character :: trans real :: a ( lda , * ) real :: x ( * ) real :: y ( * ) integer ( blas_int ) :: m_ , n_ , lda_ , incx_ , incy_ logical :: ok if ( ARG_CHECK ) then ok = . true . ok = ok . and . abs ( m ) <= HUGE_BLAS_INT - 1 ok = ok . and . abs ( n ) <= HUGE_BLAS_INT - 1 ok = ok . and . abs ( lda ) <= HUGE_BLAS_INT - 1 ok = ok . and . abs ( incx ) <= HUGE_BLAS_INT - 1 ok = ok . and . abs ( incy ) <= HUGE_BLAS_INT - 1 if (. not . ok ) call show_message ( ERRMSG , WITH_ABORT ) end if m_ = int ( m , blas_int ) n_ = int ( n , blas_int ) lda_ = int ( lda , blas_int ) incx_ = int ( incx , blas_int ) incy_ = int ( incy , blas_int ) call sgemv ( trans , m_ , n_ , alpha , a , lda_ , x , incx_ , beta , y , incy_ ) end subroutine oqp_sgemv_i64 subroutine oqp_sger_i64 ( m , n , alpha , x , incx , y , incy , a , lda ) real :: alpha integer :: incx integer :: incy integer :: lda integer :: m integer :: n real :: a ( lda , * ) real :: x ( * ) real :: y ( * ) integer ( blas_int ) :: m_ , n_ , incx_ , incy_ , lda_ logical :: ok if ( ARG_CHECK ) then ok = . true . ok = ok . and . abs ( m ) <= HUGE_BLAS_INT - 1 ok = ok . and . abs ( n ) <= HUGE_BLAS_INT - 1 ok = ok . and . abs ( incx ) <= HUGE_BLAS_INT - 1 ok = ok . and . abs ( incy ) <= HUGE_BLAS_INT - 1 ok = ok . and . abs ( lda ) <= HUGE_BLAS_INT - 1 if (. not . ok ) call show_message ( ERRMSG , WITH_ABORT ) end if m_ = int ( m , blas_int ) n_ = int ( n , blas_int ) incx_ = int ( incx , blas_int ) incy_ = int ( incy , blas_int ) lda_ = int ( lda , blas_int ) call sger ( m_ , n_ , alpha , x , incx_ , y , incy_ , a , lda_ ) end subroutine oqp_sger_i64 subroutine oqp_srot_i64 ( n , sx , incx , sy , incy , c , s ) real :: c real :: s integer :: incx integer :: incy integer :: n real :: sx ( * ) real :: sy ( * ) integer ( blas_int ) :: n_ , incx_ , incy_ logical :: ok if ( ARG_CHECK ) then ok = . true . ok = ok . and . abs ( n ) <= HUGE_BLAS_INT - 1 ok = ok . and . abs ( incx ) <= HUGE_BLAS_INT - 1 ok = ok . and . abs ( incy ) <= HUGE_BLAS_INT - 1 if (. not . ok ) call show_message ( ERRMSG , WITH_ABORT ) end if n_ = int ( n , blas_int ) incx_ = int ( incx , blas_int ) incy_ = int ( incy , blas_int ) call srot ( n_ , sx , incx_ , sy , incy_ , c , s ) end subroutine oqp_srot_i64 subroutine oqp_srotm_i64 ( n , sx , incx , sy , incy , sparam ) integer :: incx integer :: incy integer :: n real :: sparam ( 5 ) real :: sx ( * ) real :: sy ( * ) integer ( blas_int ) :: n_ , incx_ , incy_ logical :: ok if ( ARG_CHECK ) then ok = . true . ok = ok . and . abs ( n ) <= HUGE_BLAS_INT - 1 ok = ok . and . abs ( incx ) <= HUGE_BLAS_INT - 1 ok = ok . and . abs ( incy ) <= HUGE_BLAS_INT - 1 if (. not . ok ) call show_message ( ERRMSG , WITH_ABORT ) end if n_ = int ( n , blas_int ) incx_ = int ( incx , blas_int ) incy_ = int ( incy , blas_int ) call srotm ( n_ , sx , incx_ , sy , incy_ , sparam ) end subroutine oqp_srotm_i64 subroutine oqp_ssbmv_i64 ( uplo , n , k , alpha , a , lda , x , incx , beta , y , incy ) real :: alpha real :: beta integer :: incx integer :: incy integer :: k integer :: lda integer :: n character :: uplo real :: a ( lda , * ) real :: x ( * ) real :: y ( * ) integer ( blas_int ) :: n_ , k_ , lda_ , incx_ , incy_ logical :: ok if ( ARG_CHECK ) then ok = . true . ok = ok . and . abs ( n ) <= HUGE_BLAS_INT - 1 ok = ok . and . abs ( k ) <= HUGE_BLAS_INT - 1 ok = ok . and . abs ( lda ) <= HUGE_BLAS_INT - 1 ok = ok . and . abs ( incx ) <= HUGE_BLAS_INT - 1 ok = ok . and . abs ( incy ) <= HUGE_BLAS_INT - 1 if (. not . ok ) call show_message ( ERRMSG , WITH_ABORT ) end if n_ = int ( n , blas_int ) k_ = int ( k , blas_int ) lda_ = int ( lda , blas_int ) incx_ = int ( incx , blas_int ) incy_ = int ( incy , blas_int ) call ssbmv ( uplo , n_ , k_ , alpha , a , lda_ , x , incx_ , beta , y , incy_ ) end subroutine oqp_ssbmv_i64 subroutine oqp_sscal_i64 ( n , sa , sx , incx ) real :: sa integer :: incx integer :: n real :: sx ( * ) integer ( blas_int ) :: n_ , incx_ logical :: ok if ( ARG_CHECK ) then ok = . true . ok = ok . and . abs ( n ) <= HUGE_BLAS_INT - 1 ok = ok . and . abs ( incx ) <= HUGE_BLAS_INT - 1 if (. not . ok ) call show_message ( ERRMSG , WITH_ABORT ) end if n_ = int ( n , blas_int ) incx_ = int ( incx , blas_int ) call sscal ( n_ , sa , sx , incx_ ) end subroutine oqp_sscal_i64 subroutine oqp_sspmv_i64 ( uplo , n , alpha , ap , x , incx , beta , y , incy ) real :: alpha real :: beta integer :: incx integer :: incy integer :: n character :: uplo real :: ap ( * ) real :: x ( * ) real :: y ( * ) integer ( blas_int ) :: n_ , incx_ , incy_ logical :: ok if ( ARG_CHECK ) then ok = . true . ok = ok . and . abs ( n ) <= HUGE_BLAS_INT - 1 ok = ok . and . abs ( incx ) <= HUGE_BLAS_INT - 1 ok = ok . and . abs ( incy ) <= HUGE_BLAS_INT - 1 if (. not . ok ) call show_message ( ERRMSG , WITH_ABORT ) end if n_ = int ( n , blas_int ) incx_ = int ( incx , blas_int ) incy_ = int ( incy , blas_int ) call sspmv ( uplo , n_ , alpha , ap , x , incx_ , beta , y , incy_ ) end subroutine oqp_sspmv_i64 subroutine oqp_sspr_i64 ( uplo , n , alpha , x , incx , ap ) real :: alpha integer :: incx integer :: n character :: uplo real :: ap ( * ) real :: x ( * ) integer ( blas_int ) :: n_ , incx_ logical :: ok if ( ARG_CHECK ) then ok = . true . ok = ok . and . abs ( n ) <= HUGE_BLAS_INT - 1 ok = ok . and . abs ( incx ) <= HUGE_BLAS_INT - 1 if (. not . ok ) call show_message ( ERRMSG , WITH_ABORT ) end if n_ = int ( n , blas_int ) incx_ = int ( incx , blas_int ) call sspr ( uplo , n_ , alpha , x , incx_ , ap ) end subroutine oqp_sspr_i64 subroutine oqp_sspr2_i64 ( uplo , n , alpha , x , incx , y , incy , ap ) real :: alpha integer :: incx integer :: incy integer :: n character :: uplo real :: ap ( * ) real :: x ( * ) real :: y ( * ) integer ( blas_int ) :: n_ , incx_ , incy_ logical :: ok if ( ARG_CHECK ) then ok = . true . ok = ok . and . abs ( n ) <= HUGE_BLAS_INT - 1 ok = ok . and . abs ( incx ) <= HUGE_BLAS_INT - 1 ok = ok . and . abs ( incy ) <= HUGE_BLAS_INT - 1 if (. not . ok ) call show_message ( ERRMSG , WITH_ABORT ) end if n_ = int ( n , blas_int ) incx_ = int ( incx , blas_int ) incy_ = int ( incy , blas_int ) call sspr2 ( uplo , n_ , alpha , x , incx_ , y , incy_ , ap ) end subroutine oqp_sspr2_i64 subroutine oqp_sswap_i64 ( n , sx , incx , sy , incy ) integer :: incx integer :: incy integer :: n real :: sx ( * ) real :: sy ( * ) integer ( blas_int ) :: n_ , incx_ , incy_ logical :: ok if ( ARG_CHECK ) then ok = . true . ok = ok . and . abs ( n ) <= HUGE_BLAS_INT - 1 ok = ok . and . abs ( incx ) <= HUGE_BLAS_INT - 1 ok = ok . and . abs ( incy ) <= HUGE_BLAS_INT - 1 if (. not . ok ) call show_message ( ERRMSG , WITH_ABORT ) end if n_ = int ( n , blas_int ) incx_ = int ( incx , blas_int ) incy_ = int ( incy , blas_int ) call sswap ( n_ , sx , incx_ , sy , incy_ ) end subroutine oqp_sswap_i64 subroutine oqp_ssymm_i64 ( side , uplo , m , n , alpha , a , lda , b , ldb , beta , c , ldc ) real :: alpha real :: beta integer :: lda integer :: ldb integer :: ldc integer :: m integer :: n character :: side character :: uplo real :: a ( lda , * ) real :: b ( ldb , * ) real :: c ( ldc , * ) integer ( blas_int ) :: m_ , n_ , lda_ , ldb_ , ldc_ logical :: ok if ( ARG_CHECK ) then ok = . true . ok = ok . and . abs ( m ) <= HUGE_BLAS_INT - 1 ok = ok . and . abs ( n ) <= HUGE_BLAS_INT - 1 ok = ok . and . abs ( lda ) <= HUGE_BLAS_INT - 1 ok = ok . and . abs ( ldb ) <= HUGE_BLAS_INT - 1 ok = ok . and . abs ( ldc ) <= HUGE_BLAS_INT - 1 if (. not . ok ) call show_message ( ERRMSG , WITH_ABORT ) end if m_ = int ( m , blas_int ) n_ = int ( n , blas_int ) lda_ = int ( lda , blas_int ) ldb_ = int ( ldb , blas_int ) ldc_ = int ( ldc , blas_int ) call ssymm ( side , uplo , m_ , n_ , alpha , a , lda_ , b , ldb_ , beta , c , ldc_ ) end subroutine oqp_ssymm_i64 subroutine oqp_ssymv_i64 ( uplo , n , alpha , a , lda , x , incx , beta , y , incy ) real :: alpha real :: beta integer :: incx integer :: incy integer :: lda integer :: n character :: uplo real :: a ( lda , * ) real :: x ( * ) real :: y ( * ) integer ( blas_int ) :: n_ , lda_ , incx_ , incy_ logical :: ok if ( ARG_CHECK ) then ok = . true . ok = ok . and . abs ( n ) <= HUGE_BLAS_INT - 1 ok = ok . and . abs ( lda ) <= HUGE_BLAS_INT - 1 ok = ok . and . abs ( incx ) <= HUGE_BLAS_INT - 1 ok = ok . and . abs ( incy ) <= HUGE_BLAS_INT - 1 if (. not . ok ) call show_message ( ERRMSG , WITH_ABORT ) end if n_ = int ( n , blas_int ) lda_ = int ( lda , blas_int ) incx_ = int ( incx , blas_int ) incy_ = int ( incy , blas_int ) call ssymv ( uplo , n_ , alpha , a , lda_ , x , incx_ , beta , y , incy_ ) end subroutine oqp_ssymv_i64 subroutine oqp_ssyr_i64 ( uplo , n , alpha , x , incx , a , lda ) real :: alpha integer :: incx integer :: lda integer :: n character :: uplo real :: a ( lda , * ) real :: x ( * ) integer ( blas_int ) :: n_ , incx_ , lda_ logical :: ok if ( ARG_CHECK ) then ok = . true . ok = ok . and . abs ( n ) <= HUGE_BLAS_INT - 1 ok = ok . and . abs ( incx ) <= HUGE_BLAS_INT - 1 ok = ok . and . abs ( lda ) <= HUGE_BLAS_INT - 1 if (. not . ok ) call show_message ( ERRMSG , WITH_ABORT ) end if n_ = int ( n , blas_int ) incx_ = int ( incx , blas_int ) lda_ = int ( lda , blas_int ) call ssyr ( uplo , n_ , alpha , x , incx_ , a , lda_ ) end subroutine oqp_ssyr_i64 subroutine oqp_ssyr2_i64 ( uplo , n , alpha , x , incx , y , incy , a , lda ) real :: alpha integer :: incx integer :: incy integer :: lda integer :: n character :: uplo real :: a ( lda , * ) real :: x ( * ) real :: y ( * ) integer ( blas_int ) :: n_ , incx_ , incy_ , lda_ logical :: ok if ( ARG_CHECK ) then ok = . true . ok = ok . and . abs ( n ) <= HUGE_BLAS_INT - 1 ok = ok . and . abs ( incx ) <= HUGE_BLAS_INT - 1 ok = ok . and . abs ( incy ) <= HUGE_BLAS_INT - 1 ok = ok . and . abs ( lda ) <= HUGE_BLAS_INT - 1 if (. not . ok ) call show_message ( ERRMSG , WITH_ABORT ) end if n_ = int ( n , blas_int ) incx_ = int ( incx , blas_int ) incy_ = int ( incy , blas_int ) lda_ = int ( lda , blas_int ) call ssyr2 ( uplo , n_ , alpha , x , incx_ , y , incy_ , a , lda_ ) end subroutine oqp_ssyr2_i64 subroutine oqp_ssyr2k_i64 ( uplo , trans , n , k , alpha , a , lda , b , ldb , beta , c , ldc ) real :: alpha real :: beta integer :: k integer :: lda integer :: ldb integer :: ldc integer :: n character :: trans character :: uplo real :: a ( lda , * ) real :: b ( ldb , * ) real :: c ( ldc , * ) integer ( blas_int ) :: n_ , k_ , lda_ , ldb_ , ldc_ logical :: ok if ( ARG_CHECK ) then ok = . true . ok = ok . and . abs ( n ) <= HUGE_BLAS_INT - 1 ok = ok . and . abs ( k ) <= HUGE_BLAS_INT - 1 ok = ok . and . abs ( lda ) <= HUGE_BLAS_INT - 1 ok = ok . and . abs ( ldb ) <= HUGE_BLAS_INT - 1 ok = ok . and . abs ( ldc ) <= HUGE_BLAS_INT - 1 if (. not . ok ) call show_message ( ERRMSG , WITH_ABORT ) end if n_ = int ( n , blas_int ) k_ = int ( k , blas_int ) lda_ = int ( lda , blas_int ) ldb_ = int ( ldb , blas_int ) ldc_ = int ( ldc , blas_int ) call ssyr2k ( uplo , trans , n_ , k_ , alpha , a , lda_ , b , ldb_ , beta , c , ldc_ ) end subroutine oqp_ssyr2k_i64 subroutine oqp_ssyrk_i64 ( uplo , trans , n , k , alpha , a , lda , beta , c , ldc ) real :: alpha real :: beta integer :: k integer :: lda integer :: ldc integer :: n character :: trans character :: uplo real :: a ( lda , * ) real :: c ( ldc , * ) integer ( blas_int ) :: n_ , k_ , lda_ , ldc_ logical :: ok if ( ARG_CHECK ) then ok = . true . ok = ok . and . abs ( n ) <= HUGE_BLAS_INT - 1 ok = ok . and . abs ( k ) <= HUGE_BLAS_INT - 1 ok = ok . and . abs ( lda ) <= HUGE_BLAS_INT - 1 ok = ok . and . abs ( ldc ) <= HUGE_BLAS_INT - 1 if (. not . ok ) call show_message ( ERRMSG , WITH_ABORT ) end if n_ = int ( n , blas_int ) k_ = int ( k , blas_int ) lda_ = int ( lda , blas_int ) ldc_ = int ( ldc , blas_int ) call ssyrk ( uplo , trans , n_ , k_ , alpha , a , lda_ , beta , c , ldc_ ) end subroutine oqp_ssyrk_i64 subroutine oqp_stbmv_i64 ( uplo , trans , diag , n , k , a , lda , x , incx ) integer :: incx integer :: k integer :: lda integer :: n character :: diag character :: trans character :: uplo real :: a ( lda , * ) real :: x ( * ) integer ( blas_int ) :: n_ , k_ , lda_ , incx_ logical :: ok if ( ARG_CHECK ) then ok = . true . ok = ok . and . abs ( n ) <= HUGE_BLAS_INT - 1 ok = ok . and . abs ( k ) <= HUGE_BLAS_INT - 1 ok = ok . and . abs ( lda ) <= HUGE_BLAS_INT - 1 ok = ok . and . abs ( incx ) <= HUGE_BLAS_INT - 1 if (. not . ok ) call show_message ( ERRMSG , WITH_ABORT ) end if n_ = int ( n , blas_int ) k_ = int ( k , blas_int ) lda_ = int ( lda , blas_int ) incx_ = int ( incx , blas_int ) call stbmv ( uplo , trans , diag , n_ , k_ , a , lda_ , x , incx_ ) end subroutine oqp_stbmv_i64 subroutine oqp_stbsv_i64 ( uplo , trans , diag , n , k , a , lda , x , incx ) integer :: incx integer :: k integer :: lda integer :: n character :: diag character :: trans character :: uplo real :: a ( lda , * ) real :: x ( * ) integer ( blas_int ) :: n_ , k_ , lda_ , incx_ logical :: ok if ( ARG_CHECK ) then ok = . true . ok = ok . and . abs ( n ) <= HUGE_BLAS_INT - 1 ok = ok . and . abs ( k ) <= HUGE_BLAS_INT - 1 ok = ok . and . abs ( lda ) <= HUGE_BLAS_INT - 1 ok = ok . and . abs ( incx ) <= HUGE_BLAS_INT - 1 if (. not . ok ) call show_message ( ERRMSG , WITH_ABORT ) end if n_ = int ( n , blas_int ) k_ = int ( k , blas_int ) lda_ = int ( lda , blas_int ) incx_ = int ( incx , blas_int ) call stbsv ( uplo , trans , diag , n_ , k_ , a , lda_ , x , incx_ ) end subroutine oqp_stbsv_i64 subroutine oqp_stpmv_i64 ( uplo , trans , diag , n , ap , x , incx ) integer :: incx integer :: n character :: diag character :: trans character :: uplo real :: ap ( * ) real :: x ( * ) integer ( blas_int ) :: n_ , incx_ logical :: ok if ( ARG_CHECK ) then ok = . true . ok = ok . and . abs ( n ) <= HUGE_BLAS_INT - 1 ok = ok . and . abs ( incx ) <= HUGE_BLAS_INT - 1 if (. not . ok ) call show_message ( ERRMSG , WITH_ABORT ) end if n_ = int ( n , blas_int ) incx_ = int ( incx , blas_int ) call stpmv ( uplo , trans , diag , n_ , ap , x , incx_ ) end subroutine oqp_stpmv_i64 subroutine oqp_stpsv_i64 ( uplo , trans , diag , n , ap , x , incx ) integer :: incx integer :: n character :: diag character :: trans character :: uplo real :: ap ( * ) real :: x ( * ) integer ( blas_int ) :: n_ , incx_ logical :: ok if ( ARG_CHECK ) then ok = . true . ok = ok . and . abs ( n ) <= HUGE_BLAS_INT - 1 ok = ok . and . abs ( incx ) <= HUGE_BLAS_INT - 1 if (. not . ok ) call show_message ( ERRMSG , WITH_ABORT ) end if n_ = int ( n , blas_int ) incx_ = int ( incx , blas_int ) call stpsv ( uplo , trans , diag , n_ , ap , x , incx_ ) end subroutine oqp_stpsv_i64 subroutine oqp_strmm_i64 ( side , uplo , transa , diag , m , n , alpha , a , lda , b , ldb ) real :: alpha integer :: lda integer :: ldb integer :: m integer :: n character :: diag character :: side character :: transa character :: uplo real :: a ( lda , * ) real :: b ( ldb , * ) integer ( blas_int ) :: m_ , n_ , lda_ , ldb_ logical :: ok if ( ARG_CHECK ) then ok = . true . ok = ok . and . abs ( m ) <= HUGE_BLAS_INT - 1 ok = ok . and . abs ( n ) <= HUGE_BLAS_INT - 1 ok = ok . and . abs ( lda ) <= HUGE_BLAS_INT - 1 ok = ok . and . abs ( ldb ) <= HUGE_BLAS_INT - 1 if (. not . ok ) call show_message ( ERRMSG , WITH_ABORT ) end if m_ = int ( m , blas_int ) n_ = int ( n , blas_int ) lda_ = int ( lda , blas_int ) ldb_ = int ( ldb , blas_int ) call strmm ( side , uplo , transa , diag , m_ , n_ , alpha , a , lda_ , b , ldb_ ) end subroutine oqp_strmm_i64 subroutine oqp_strmv_i64 ( uplo , trans , diag , n , a , lda , x , incx ) integer :: incx integer :: lda integer :: n character :: diag character :: trans character :: uplo real :: a ( lda , * ) real :: x ( * ) integer ( blas_int ) :: n_ , lda_ , incx_ logical :: ok if ( ARG_CHECK ) then ok = . true . ok = ok . and . abs ( n ) <= HUGE_BLAS_INT - 1 ok = ok . and . abs ( lda ) <= HUGE_BLAS_INT - 1 ok = ok . and . abs ( incx ) <= HUGE_BLAS_INT - 1 if (. not . ok ) call show_message ( ERRMSG , WITH_ABORT ) end if n_ = int ( n , blas_int ) lda_ = int ( lda , blas_int ) incx_ = int ( incx , blas_int ) call strmv ( uplo , trans , diag , n_ , a , lda_ , x , incx_ ) end subroutine oqp_strmv_i64 subroutine oqp_strsm_i64 ( side , uplo , transa , diag , m , n , alpha , a , lda , b , ldb ) real :: alpha integer :: lda integer :: ldb integer :: m integer :: n character :: diag character :: side character :: transa character :: uplo real :: a ( lda , * ) real :: b ( ldb , * ) integer ( blas_int ) :: m_ , n_ , lda_ , ldb_ logical :: ok if ( ARG_CHECK ) then ok = . true . ok = ok . and . abs ( m ) <= HUGE_BLAS_INT - 1 ok = ok . and . abs ( n ) <= HUGE_BLAS_INT - 1 ok = ok . and . abs ( lda ) <= HUGE_BLAS_INT - 1 ok = ok . and . abs ( ldb ) <= HUGE_BLAS_INT - 1 if (. not . ok ) call show_message ( ERRMSG , WITH_ABORT ) end if m_ = int ( m , blas_int ) n_ = int ( n , blas_int ) lda_ = int ( lda , blas_int ) ldb_ = int ( ldb , blas_int ) call strsm ( side , uplo , transa , diag , m_ , n_ , alpha , a , lda_ , b , ldb_ ) end subroutine oqp_strsm_i64 subroutine oqp_strsv_i64 ( uplo , trans , diag , n , a , lda , x , incx ) integer :: incx integer :: lda integer :: n character :: diag character :: trans character :: uplo real :: a ( lda , * ) real :: x ( * ) integer ( blas_int ) :: n_ , lda_ , incx_ logical :: ok if ( ARG_CHECK ) then ok = . true . ok = ok . and . abs ( n ) <= HUGE_BLAS_INT - 1 ok = ok . and . abs ( lda ) <= HUGE_BLAS_INT - 1 ok = ok . and . abs ( incx ) <= HUGE_BLAS_INT - 1 if (. not . ok ) call show_message ( ERRMSG , WITH_ABORT ) end if n_ = int ( n , blas_int ) lda_ = int ( lda , blas_int ) incx_ = int ( incx , blas_int ) call strsv ( uplo , trans , diag , n_ , a , lda_ , x , incx_ ) end subroutine oqp_strsv_i64 subroutine oqp_xerbla_i64 ( srname , info ) character :: srname integer :: info integer ( blas_int ) :: info_ logical :: ok if ( ARG_CHECK ) then ok = . true . ok = ok . and . abs ( info ) <= HUGE_BLAS_INT - 1 if (. not . ok ) call show_message ( ERRMSG , WITH_ABORT ) end if info_ = int ( info , blas_int ) call xerbla ( srname , info_ ) end subroutine oqp_xerbla_i64 !  subroutine oqp_xerbla_array_i64(srname_array, srname_len, info) !    integer :: srname_len !    integer :: info !    character :: srname_array(srname_len) ! !    integer(blas_int) :: srname_len_, info_ !    logical :: ok ! !    if (ARG_CHECK) then !      ok = .true. !      ok = ok .and. abs(srname_len ) <= HUGE_BLAS_INT-1 !      ok = ok .and. abs(info       ) <= HUGE_BLAS_INT-1 !      if (.not.ok) call show_message(ERRMSG, WITH_ABORT) !    end if ! !    srname_len_ = int(srname_len , blas_int) !    info_       = int(info       , blas_int) ! !    call xerbla_array(srname_array, srname_len_, info_) ! !  end subroutine oqp_xerbla_array_i64 subroutine oqp_zaxpy_i64 ( n , za , zx , incx , zy , incy ) complex ( kind = 8 ) :: za integer :: incx integer :: incy integer :: n complex ( kind = 8 ) :: zx ( * ) complex ( kind = 8 ) :: zy ( * ) integer ( blas_int ) :: n_ , incx_ , incy_ logical :: ok if ( ARG_CHECK ) then ok = . true . ok = ok . and . abs ( n ) <= HUGE_BLAS_INT - 1 ok = ok . and . abs ( incx ) <= HUGE_BLAS_INT - 1 ok = ok . and . abs ( incy ) <= HUGE_BLAS_INT - 1 if (. not . ok ) call show_message ( ERRMSG , WITH_ABORT ) end if n_ = int ( n , blas_int ) incx_ = int ( incx , blas_int ) incy_ = int ( incy , blas_int ) call zaxpy ( n_ , za , zx , incx_ , zy , incy_ ) end subroutine oqp_zaxpy_i64 subroutine oqp_zcopy_i64 ( n , zx , incx , zy , incy ) integer :: incx integer :: incy integer :: n complex ( kind = 8 ) :: zx ( * ) complex ( kind = 8 ) :: zy ( * ) integer ( blas_int ) :: n_ , incx_ , incy_ logical :: ok if ( ARG_CHECK ) then ok = . true . ok = ok . and . abs ( n ) <= HUGE_BLAS_INT - 1 ok = ok . and . abs ( incx ) <= HUGE_BLAS_INT - 1 ok = ok . and . abs ( incy ) <= HUGE_BLAS_INT - 1 if (. not . ok ) call show_message ( ERRMSG , WITH_ABORT ) end if n_ = int ( n , blas_int ) incx_ = int ( incx , blas_int ) incy_ = int ( incy , blas_int ) call zcopy ( n_ , zx , incx_ , zy , incy_ ) end subroutine oqp_zcopy_i64 function oqp_zdotc_i64 ( n , zx , incx , zy , incy ) complex ( kind = 8 ), external :: zdotc complex ( kind = 8 ) :: oqp_zdotc_i64 integer :: incx integer :: incy integer :: n complex ( kind = 8 ) :: zx ( * ) complex ( kind = 8 ) :: zy ( * ) integer ( blas_int ) :: n_ , incx_ , incy_ logical :: ok if ( ARG_CHECK ) then ok = . true . ok = ok . and . abs ( n ) <= HUGE_BLAS_INT - 1 ok = ok . and . abs ( incx ) <= HUGE_BLAS_INT - 1 ok = ok . and . abs ( incy ) <= HUGE_BLAS_INT - 1 if (. not . ok ) call show_message ( ERRMSG , WITH_ABORT ) end if n_ = int ( n , blas_int ) incx_ = int ( incx , blas_int ) incy_ = int ( incy , blas_int ) oqp_zdotc_i64 = zdotc ( n_ , zx , incx_ , zy , incy_ ) end function oqp_zdotc_i64 function oqp_zdotu_i64 ( n , zx , incx , zy , incy ) complex ( kind = 8 ), external :: zdotu complex ( kind = 8 ) :: oqp_zdotu_i64 integer :: incx integer :: incy integer :: n complex ( kind = 8 ) :: zx ( * ) complex ( kind = 8 ) :: zy ( * ) integer ( blas_int ) :: n_ , incx_ , incy_ logical :: ok if ( ARG_CHECK ) then ok = . true . ok = ok . and . abs ( n ) <= HUGE_BLAS_INT - 1 ok = ok . and . abs ( incx ) <= HUGE_BLAS_INT - 1 ok = ok . and . abs ( incy ) <= HUGE_BLAS_INT - 1 if (. not . ok ) call show_message ( ERRMSG , WITH_ABORT ) end if n_ = int ( n , blas_int ) incx_ = int ( incx , blas_int ) incy_ = int ( incy , blas_int ) oqp_zdotu_i64 = zdotu ( n_ , zx , incx_ , zy , incy_ ) end function oqp_zdotu_i64 subroutine oqp_zdrot_i64 ( n , zx , incx , zy , incy , c , s ) integer :: incx integer :: incy integer :: n double precision :: c double precision :: s complex ( kind = 8 ) :: zx ( * ) complex ( kind = 8 ) :: zy ( * ) integer ( blas_int ) :: n_ , incx_ , incy_ logical :: ok if ( ARG_CHECK ) then ok = . true . ok = ok . and . abs ( n ) <= HUGE_BLAS_INT - 1 ok = ok . and . abs ( incx ) <= HUGE_BLAS_INT - 1 ok = ok . and . abs ( incy ) <= HUGE_BLAS_INT - 1 if (. not . ok ) call show_message ( ERRMSG , WITH_ABORT ) end if n_ = int ( n , blas_int ) incx_ = int ( incx , blas_int ) incy_ = int ( incy , blas_int ) call zdrot ( n_ , zx , incx_ , zy , incy_ , c , s ) end subroutine oqp_zdrot_i64 subroutine oqp_zdscal_i64 ( n , da , zx , incx ) double precision :: da integer :: incx integer :: n complex ( kind = 8 ) :: zx ( * ) integer ( blas_int ) :: n_ , incx_ logical :: ok if ( ARG_CHECK ) then ok = . true . ok = ok . and . abs ( n ) <= HUGE_BLAS_INT - 1 ok = ok . and . abs ( incx ) <= HUGE_BLAS_INT - 1 if (. not . ok ) call show_message ( ERRMSG , WITH_ABORT ) end if n_ = int ( n , blas_int ) incx_ = int ( incx , blas_int ) call zdscal ( n_ , da , zx , incx_ ) end subroutine oqp_zdscal_i64 subroutine oqp_zgbmv_i64 ( trans , m , n , kl , ku , alpha , a , lda , x , incx , beta , y , incy ) complex ( kind = 8 ) :: alpha complex ( kind = 8 ) :: beta integer :: incx integer :: incy integer :: kl integer :: ku integer :: lda integer :: m integer :: n character :: trans complex ( kind = 8 ) :: a ( lda , * ) complex ( kind = 8 ) :: x ( * ) complex ( kind = 8 ) :: y ( * ) integer ( blas_int ) :: m_ , n_ , kl_ , ku_ , lda_ , incx_ , incy_ logical :: ok if ( ARG_CHECK ) then ok = . true . ok = ok . and . abs ( m ) <= HUGE_BLAS_INT - 1 ok = ok . and . abs ( n ) <= HUGE_BLAS_INT - 1 ok = ok . and . abs ( kl ) <= HUGE_BLAS_INT - 1 ok = ok . and . abs ( ku ) <= HUGE_BLAS_INT - 1 ok = ok . and . abs ( lda ) <= HUGE_BLAS_INT - 1 ok = ok . and . abs ( incx ) <= HUGE_BLAS_INT - 1 ok = ok . and . abs ( incy ) <= HUGE_BLAS_INT - 1 if (. not . ok ) call show_message ( ERRMSG , WITH_ABORT ) end if m_ = int ( m , blas_int ) n_ = int ( n , blas_int ) kl_ = int ( kl , blas_int ) ku_ = int ( ku , blas_int ) lda_ = int ( lda , blas_int ) incx_ = int ( incx , blas_int ) incy_ = int ( incy , blas_int ) call zgbmv ( trans , m_ , n_ , kl_ , ku_ , alpha , a , lda_ , x , incx_ , beta , y , incy_ ) end subroutine oqp_zgbmv_i64 subroutine oqp_zgemm_i64 ( transa , transb , m , n , k , alpha , a , lda , b , ldb , beta , c , ldc ) complex ( kind = 8 ) :: alpha complex ( kind = 8 ) :: beta integer :: k integer :: lda integer :: ldb integer :: ldc integer :: m integer :: n character :: transa character :: transb complex ( kind = 8 ) :: a ( lda , * ) complex ( kind = 8 ) :: b ( ldb , * ) complex ( kind = 8 ) :: c ( ldc , * ) integer ( blas_int ) :: m_ , n_ , k_ , lda_ , ldb_ , ldc_ logical :: ok if ( ARG_CHECK ) then ok = . true . ok = ok . and . abs ( m ) <= HUGE_BLAS_INT - 1 ok = ok . and . abs ( n ) <= HUGE_BLAS_INT - 1 ok = ok . and . abs ( k ) <= HUGE_BLAS_INT - 1 ok = ok . and . abs ( lda ) <= HUGE_BLAS_INT - 1 ok = ok . and . abs ( ldb ) <= HUGE_BLAS_INT - 1 ok = ok . and . abs ( ldc ) <= HUGE_BLAS_INT - 1 if (. not . ok ) call show_message ( ERRMSG , WITH_ABORT ) end if m_ = int ( m , blas_int ) n_ = int ( n , blas_int ) k_ = int ( k , blas_int ) lda_ = int ( lda , blas_int ) ldb_ = int ( ldb , blas_int ) ldc_ = int ( ldc , blas_int ) call zgemm ( transa , transb , m_ , n_ , k_ , alpha , a , lda_ , b , ldb_ , beta , c , ldc_ ) end subroutine oqp_zgemm_i64 subroutine oqp_zgemv_i64 ( trans , m , n , alpha , a , lda , x , incx , beta , y , incy ) complex ( kind = 8 ) :: alpha complex ( kind = 8 ) :: beta integer :: incx integer :: incy integer :: lda integer :: m integer :: n character :: trans complex ( kind = 8 ) :: a ( lda , * ) complex ( kind = 8 ) :: x ( * ) complex ( kind = 8 ) :: y ( * ) integer ( blas_int ) :: m_ , n_ , lda_ , incx_ , incy_ logical :: ok if ( ARG_CHECK ) then ok = . true . ok = ok . and . abs ( m ) <= HUGE_BLAS_INT - 1 ok = ok . and . abs ( n ) <= HUGE_BLAS_INT - 1 ok = ok . and . abs ( lda ) <= HUGE_BLAS_INT - 1 ok = ok . and . abs ( incx ) <= HUGE_BLAS_INT - 1 ok = ok . and . abs ( incy ) <= HUGE_BLAS_INT - 1 if (. not . ok ) call show_message ( ERRMSG , WITH_ABORT ) end if m_ = int ( m , blas_int ) n_ = int ( n , blas_int ) lda_ = int ( lda , blas_int ) incx_ = int ( incx , blas_int ) incy_ = int ( incy , blas_int ) call zgemv ( trans , m_ , n_ , alpha , a , lda_ , x , incx_ , beta , y , incy_ ) end subroutine oqp_zgemv_i64 subroutine oqp_zgerc_i64 ( m , n , alpha , x , incx , y , incy , a , lda ) complex ( kind = 8 ) :: alpha integer :: incx integer :: incy integer :: lda integer :: m integer :: n complex ( kind = 8 ) :: a ( lda , * ) complex ( kind = 8 ) :: x ( * ) complex ( kind = 8 ) :: y ( * ) integer ( blas_int ) :: m_ , n_ , incx_ , incy_ , lda_ logical :: ok if ( ARG_CHECK ) then ok = . true . ok = ok . and . abs ( m ) <= HUGE_BLAS_INT - 1 ok = ok . and . abs ( n ) <= HUGE_BLAS_INT - 1 ok = ok . and . abs ( incx ) <= HUGE_BLAS_INT - 1 ok = ok . and . abs ( incy ) <= HUGE_BLAS_INT - 1 ok = ok . and . abs ( lda ) <= HUGE_BLAS_INT - 1 if (. not . ok ) call show_message ( ERRMSG , WITH_ABORT ) end if m_ = int ( m , blas_int ) n_ = int ( n , blas_int ) incx_ = int ( incx , blas_int ) incy_ = int ( incy , blas_int ) lda_ = int ( lda , blas_int ) call zgerc ( m_ , n_ , alpha , x , incx_ , y , incy_ , a , lda_ ) end subroutine oqp_zgerc_i64 subroutine oqp_zgeru_i64 ( m , n , alpha , x , incx , y , incy , a , lda ) complex ( kind = 8 ) :: alpha integer :: incx integer :: incy integer :: lda integer :: m integer :: n complex ( kind = 8 ) :: a ( lda , * ) complex ( kind = 8 ) :: x ( * ) complex ( kind = 8 ) :: y ( * ) integer ( blas_int ) :: m_ , n_ , incx_ , incy_ , lda_ logical :: ok if ( ARG_CHECK ) then ok = . true . ok = ok . and . abs ( m ) <= HUGE_BLAS_INT - 1 ok = ok . and . abs ( n ) <= HUGE_BLAS_INT - 1 ok = ok . and . abs ( incx ) <= HUGE_BLAS_INT - 1 ok = ok . and . abs ( incy ) <= HUGE_BLAS_INT - 1 ok = ok . and . abs ( lda ) <= HUGE_BLAS_INT - 1 if (. not . ok ) call show_message ( ERRMSG , WITH_ABORT ) end if m_ = int ( m , blas_int ) n_ = int ( n , blas_int ) incx_ = int ( incx , blas_int ) incy_ = int ( incy , blas_int ) lda_ = int ( lda , blas_int ) call zgeru ( m_ , n_ , alpha , x , incx_ , y , incy_ , a , lda_ ) end subroutine oqp_zgeru_i64 subroutine oqp_zhbmv_i64 ( uplo , n , k , alpha , a , lda , x , incx , beta , y , incy ) complex ( kind = 8 ) :: alpha complex ( kind = 8 ) :: beta integer :: incx integer :: incy integer :: k integer :: lda integer :: n character :: uplo complex ( kind = 8 ) :: a ( lda , * ) complex ( kind = 8 ) :: x ( * ) complex ( kind = 8 ) :: y ( * ) integer ( blas_int ) :: n_ , k_ , lda_ , incx_ , incy_ logical :: ok if ( ARG_CHECK ) then ok = . true . ok = ok . and . abs ( n ) <= HUGE_BLAS_INT - 1 ok = ok . and . abs ( k ) <= HUGE_BLAS_INT - 1 ok = ok . and . abs ( lda ) <= HUGE_BLAS_INT - 1 ok = ok . and . abs ( incx ) <= HUGE_BLAS_INT - 1 ok = ok . and . abs ( incy ) <= HUGE_BLAS_INT - 1 if (. not . ok ) call show_message ( ERRMSG , WITH_ABORT ) end if n_ = int ( n , blas_int ) k_ = int ( k , blas_int ) lda_ = int ( lda , blas_int ) incx_ = int ( incx , blas_int ) incy_ = int ( incy , blas_int ) call zhbmv ( uplo , n_ , k_ , alpha , a , lda_ , x , incx_ , beta , y , incy_ ) end subroutine oqp_zhbmv_i64 subroutine oqp_zhemm_i64 ( side , uplo , m , n , alpha , a , lda , b , ldb , beta , c , ldc ) complex ( kind = 8 ) :: alpha complex ( kind = 8 ) :: beta integer :: lda integer :: ldb integer :: ldc integer :: m integer :: n character :: side character :: uplo complex ( kind = 8 ) :: a ( lda , * ) complex ( kind = 8 ) :: b ( ldb , * ) complex ( kind = 8 ) :: c ( ldc , * ) integer ( blas_int ) :: m_ , n_ , lda_ , ldb_ , ldc_ logical :: ok if ( ARG_CHECK ) then ok = . true . ok = ok . and . abs ( m ) <= HUGE_BLAS_INT - 1 ok = ok . and . abs ( n ) <= HUGE_BLAS_INT - 1 ok = ok . and . abs ( lda ) <= HUGE_BLAS_INT - 1 ok = ok . and . abs ( ldb ) <= HUGE_BLAS_INT - 1 ok = ok . and . abs ( ldc ) <= HUGE_BLAS_INT - 1 if (. not . ok ) call show_message ( ERRMSG , WITH_ABORT ) end if m_ = int ( m , blas_int ) n_ = int ( n , blas_int ) lda_ = int ( lda , blas_int ) ldb_ = int ( ldb , blas_int ) ldc_ = int ( ldc , blas_int ) call zhemm ( side , uplo , m_ , n_ , alpha , a , lda_ , b , ldb_ , beta , c , ldc_ ) end subroutine oqp_zhemm_i64 subroutine oqp_zhemv_i64 ( uplo , n , alpha , a , lda , x , incx , beta , y , incy ) complex ( kind = 8 ) :: alpha complex ( kind = 8 ) :: beta integer :: incx integer :: incy integer :: lda integer :: n character :: uplo complex ( kind = 8 ) :: a ( lda , * ) complex ( kind = 8 ) :: x ( * ) complex ( kind = 8 ) :: y ( * ) integer ( blas_int ) :: n_ , lda_ , incx_ , incy_ logical :: ok if ( ARG_CHECK ) then ok = . true . ok = ok . and . abs ( n ) <= HUGE_BLAS_INT - 1 ok = ok . and . abs ( lda ) <= HUGE_BLAS_INT - 1 ok = ok . and . abs ( incx ) <= HUGE_BLAS_INT - 1 ok = ok . and . abs ( incy ) <= HUGE_BLAS_INT - 1 if (. not . ok ) call show_message ( ERRMSG , WITH_ABORT ) end if n_ = int ( n , blas_int ) lda_ = int ( lda , blas_int ) incx_ = int ( incx , blas_int ) incy_ = int ( incy , blas_int ) call zhemv ( uplo , n_ , alpha , a , lda_ , x , incx_ , beta , y , incy_ ) end subroutine oqp_zhemv_i64 subroutine oqp_zher_i64 ( uplo , n , alpha , x , incx , a , lda ) double precision :: alpha integer :: incx integer :: lda integer :: n character :: uplo complex ( kind = 8 ) :: a ( lda , * ) complex ( kind = 8 ) :: x ( * ) integer ( blas_int ) :: n_ , incx_ , lda_ logical :: ok if ( ARG_CHECK ) then ok = . true . ok = ok . and . abs ( n ) <= HUGE_BLAS_INT - 1 ok = ok . and . abs ( incx ) <= HUGE_BLAS_INT - 1 ok = ok . and . abs ( lda ) <= HUGE_BLAS_INT - 1 if (. not . ok ) call show_message ( ERRMSG , WITH_ABORT ) end if n_ = int ( n , blas_int ) incx_ = int ( incx , blas_int ) lda_ = int ( lda , blas_int ) call zher ( uplo , n_ , alpha , x , incx_ , a , lda_ ) end subroutine oqp_zher_i64 subroutine oqp_zher2_i64 ( uplo , n , alpha , x , incx , y , incy , a , lda ) complex ( kind = 8 ) :: alpha integer :: incx integer :: incy integer :: lda integer :: n character :: uplo complex ( kind = 8 ) :: a ( lda , * ) complex ( kind = 8 ) :: x ( * ) complex ( kind = 8 ) :: y ( * ) integer ( blas_int ) :: n_ , incx_ , incy_ , lda_ logical :: ok if ( ARG_CHECK ) then ok = . true . ok = ok . and . abs ( n ) <= HUGE_BLAS_INT - 1 ok = ok . and . abs ( incx ) <= HUGE_BLAS_INT - 1 ok = ok . and . abs ( incy ) <= HUGE_BLAS_INT - 1 ok = ok . and . abs ( lda ) <= HUGE_BLAS_INT - 1 if (. not . ok ) call show_message ( ERRMSG , WITH_ABORT ) end if n_ = int ( n , blas_int ) incx_ = int ( incx , blas_int ) incy_ = int ( incy , blas_int ) lda_ = int ( lda , blas_int ) call zher2 ( uplo , n_ , alpha , x , incx_ , y , incy_ , a , lda_ ) end subroutine oqp_zher2_i64 subroutine oqp_zher2k_i64 ( uplo , trans , n , k , alpha , a , lda , b , ldb , beta , c , ldc ) complex ( kind = 8 ) :: alpha double precision :: beta integer :: k integer :: lda integer :: ldb integer :: ldc integer :: n character :: trans character :: uplo complex ( kind = 8 ) :: a ( lda , * ) complex ( kind = 8 ) :: b ( ldb , * ) complex ( kind = 8 ) :: c ( ldc , * ) integer ( blas_int ) :: n_ , k_ , lda_ , ldb_ , ldc_ logical :: ok if ( ARG_CHECK ) then ok = . true . ok = ok . and . abs ( n ) <= HUGE_BLAS_INT - 1 ok = ok . and . abs ( k ) <= HUGE_BLAS_INT - 1 ok = ok . and . abs ( lda ) <= HUGE_BLAS_INT - 1 ok = ok . and . abs ( ldb ) <= HUGE_BLAS_INT - 1 ok = ok . and . abs ( ldc ) <= HUGE_BLAS_INT - 1 if (. not . ok ) call show_message ( ERRMSG , WITH_ABORT ) end if n_ = int ( n , blas_int ) k_ = int ( k , blas_int ) lda_ = int ( lda , blas_int ) ldb_ = int ( ldb , blas_int ) ldc_ = int ( ldc , blas_int ) call zher2k ( uplo , trans , n_ , k_ , alpha , a , lda_ , b , ldb_ , beta , c , ldc_ ) end subroutine oqp_zher2k_i64 subroutine oqp_zherk_i64 ( uplo , trans , n , k , alpha , a , lda , beta , c , ldc ) double precision :: alpha double precision :: beta integer :: k integer :: lda integer :: ldc integer :: n character :: trans character :: uplo complex ( kind = 8 ) :: a ( lda , * ) complex ( kind = 8 ) :: c ( ldc , * ) integer ( blas_int ) :: n_ , k_ , lda_ , ldc_ logical :: ok if ( ARG_CHECK ) then ok = . true . ok = ok . and . abs ( n ) <= HUGE_BLAS_INT - 1 ok = ok . and . abs ( k ) <= HUGE_BLAS_INT - 1 ok = ok . and . abs ( lda ) <= HUGE_BLAS_INT - 1 ok = ok . and . abs ( ldc ) <= HUGE_BLAS_INT - 1 if (. not . ok ) call show_message ( ERRMSG , WITH_ABORT ) end if n_ = int ( n , blas_int ) k_ = int ( k , blas_int ) lda_ = int ( lda , blas_int ) ldc_ = int ( ldc , blas_int ) call zherk ( uplo , trans , n_ , k_ , alpha , a , lda_ , beta , c , ldc_ ) end subroutine oqp_zherk_i64 subroutine oqp_zhpmv_i64 ( uplo , n , alpha , ap , x , incx , beta , y , incy ) complex ( kind = 8 ) :: alpha complex ( kind = 8 ) :: beta integer :: incx integer :: incy integer :: n character :: uplo complex ( kind = 8 ) :: ap ( * ) complex ( kind = 8 ) :: x ( * ) complex ( kind = 8 ) :: y ( * ) integer ( blas_int ) :: n_ , incx_ , incy_ logical :: ok if ( ARG_CHECK ) then ok = . true . ok = ok . and . abs ( n ) <= HUGE_BLAS_INT - 1 ok = ok . and . abs ( incx ) <= HUGE_BLAS_INT - 1 ok = ok . and . abs ( incy ) <= HUGE_BLAS_INT - 1 if (. not . ok ) call show_message ( ERRMSG , WITH_ABORT ) end if n_ = int ( n , blas_int ) incx_ = int ( incx , blas_int ) incy_ = int ( incy , blas_int ) call zhpmv ( uplo , n_ , alpha , ap , x , incx_ , beta , y , incy_ ) end subroutine oqp_zhpmv_i64 subroutine oqp_zhpr_i64 ( uplo , n , alpha , x , incx , ap ) double precision :: alpha integer :: incx integer :: n character :: uplo complex ( kind = 8 ) :: ap ( * ) complex ( kind = 8 ) :: x ( * ) integer ( blas_int ) :: n_ , incx_ logical :: ok if ( ARG_CHECK ) then ok = . true . ok = ok . and . abs ( n ) <= HUGE_BLAS_INT - 1 ok = ok . and . abs ( incx ) <= HUGE_BLAS_INT - 1 if (. not . ok ) call show_message ( ERRMSG , WITH_ABORT ) end if n_ = int ( n , blas_int ) incx_ = int ( incx , blas_int ) call zhpr ( uplo , n_ , alpha , x , incx_ , ap ) end subroutine oqp_zhpr_i64 subroutine oqp_zhpr2_i64 ( uplo , n , alpha , x , incx , y , incy , ap ) complex ( kind = 8 ) :: alpha integer :: incx integer :: incy integer :: n character :: uplo complex ( kind = 8 ) :: ap ( * ) complex ( kind = 8 ) :: x ( * ) complex ( kind = 8 ) :: y ( * ) integer ( blas_int ) :: n_ , incx_ , incy_ logical :: ok if ( ARG_CHECK ) then ok = . true . ok = ok . and . abs ( n ) <= HUGE_BLAS_INT - 1 ok = ok . and . abs ( incx ) <= HUGE_BLAS_INT - 1 ok = ok . and . abs ( incy ) <= HUGE_BLAS_INT - 1 if (. not . ok ) call show_message ( ERRMSG , WITH_ABORT ) end if n_ = int ( n , blas_int ) incx_ = int ( incx , blas_int ) incy_ = int ( incy , blas_int ) call zhpr2 ( uplo , n_ , alpha , x , incx_ , y , incy_ , ap ) end subroutine oqp_zhpr2_i64 subroutine oqp_zscal_i64 ( n , za , zx , incx ) complex ( kind = 8 ) :: za integer :: incx integer :: n complex ( kind = 8 ) :: zx ( * ) integer ( blas_int ) :: n_ , incx_ logical :: ok if ( ARG_CHECK ) then ok = . true . ok = ok . and . abs ( n ) <= HUGE_BLAS_INT - 1 ok = ok . and . abs ( incx ) <= HUGE_BLAS_INT - 1 if (. not . ok ) call show_message ( ERRMSG , WITH_ABORT ) end if n_ = int ( n , blas_int ) incx_ = int ( incx , blas_int ) call zscal ( n_ , za , zx , incx_ ) end subroutine oqp_zscal_i64 subroutine oqp_zswap_i64 ( n , zx , incx , zy , incy ) integer :: incx integer :: incy integer :: n complex ( kind = 8 ) :: zx ( * ) complex ( kind = 8 ) :: zy ( * ) integer ( blas_int ) :: n_ , incx_ , incy_ logical :: ok if ( ARG_CHECK ) then ok = . true . ok = ok . and . abs ( n ) <= HUGE_BLAS_INT - 1 ok = ok . and . abs ( incx ) <= HUGE_BLAS_INT - 1 ok = ok . and . abs ( incy ) <= HUGE_BLAS_INT - 1 if (. not . ok ) call show_message ( ERRMSG , WITH_ABORT ) end if n_ = int ( n , blas_int ) incx_ = int ( incx , blas_int ) incy_ = int ( incy , blas_int ) call zswap ( n_ , zx , incx_ , zy , incy_ ) end subroutine oqp_zswap_i64 subroutine oqp_zsymm_i64 ( side , uplo , m , n , alpha , a , lda , b , ldb , beta , c , ldc ) complex ( kind = 8 ) :: alpha complex ( kind = 8 ) :: beta integer :: lda integer :: ldb integer :: ldc integer :: m integer :: n character :: side character :: uplo complex ( kind = 8 ) :: a ( lda , * ) complex ( kind = 8 ) :: b ( ldb , * ) complex ( kind = 8 ) :: c ( ldc , * ) integer ( blas_int ) :: m_ , n_ , lda_ , ldb_ , ldc_ logical :: ok if ( ARG_CHECK ) then ok = . true . ok = ok . and . abs ( m ) <= HUGE_BLAS_INT - 1 ok = ok . and . abs ( n ) <= HUGE_BLAS_INT - 1 ok = ok . and . abs ( lda ) <= HUGE_BLAS_INT - 1 ok = ok . and . abs ( ldb ) <= HUGE_BLAS_INT - 1 ok = ok . and . abs ( ldc ) <= HUGE_BLAS_INT - 1 if (. not . ok ) call show_message ( ERRMSG , WITH_ABORT ) end if m_ = int ( m , blas_int ) n_ = int ( n , blas_int ) lda_ = int ( lda , blas_int ) ldb_ = int ( ldb , blas_int ) ldc_ = int ( ldc , blas_int ) call zsymm ( side , uplo , m_ , n_ , alpha , a , lda_ , b , ldb_ , beta , c , ldc_ ) end subroutine oqp_zsymm_i64 subroutine oqp_zsyr2k_i64 ( uplo , trans , n , k , alpha , a , lda , b , ldb , beta , c , ldc ) complex ( kind = 8 ) :: alpha complex ( kind = 8 ) :: beta integer :: k integer :: lda integer :: ldb integer :: ldc integer :: n character :: trans character :: uplo complex ( kind = 8 ) :: a ( lda , * ) complex ( kind = 8 ) :: b ( ldb , * ) complex ( kind = 8 ) :: c ( ldc , * ) integer ( blas_int ) :: n_ , k_ , lda_ , ldb_ , ldc_ logical :: ok if ( ARG_CHECK ) then ok = . true . ok = ok . and . abs ( n ) <= HUGE_BLAS_INT - 1 ok = ok . and . abs ( k ) <= HUGE_BLAS_INT - 1 ok = ok . and . abs ( lda ) <= HUGE_BLAS_INT - 1 ok = ok . and . abs ( ldb ) <= HUGE_BLAS_INT - 1 ok = ok . and . abs ( ldc ) <= HUGE_BLAS_INT - 1 if (. not . ok ) call show_message ( ERRMSG , WITH_ABORT ) end if n_ = int ( n , blas_int ) k_ = int ( k , blas_int ) lda_ = int ( lda , blas_int ) ldb_ = int ( ldb , blas_int ) ldc_ = int ( ldc , blas_int ) call zsyr2k ( uplo , trans , n_ , k_ , alpha , a , lda_ , b , ldb_ , beta , c , ldc_ ) end subroutine oqp_zsyr2k_i64 subroutine oqp_zsyrk_i64 ( uplo , trans , n , k , alpha , a , lda , beta , c , ldc ) complex ( kind = 8 ) :: alpha complex ( kind = 8 ) :: beta integer :: k integer :: lda integer :: ldc integer :: n character :: trans character :: uplo complex ( kind = 8 ) :: a ( lda , * ) complex ( kind = 8 ) :: c ( ldc , * ) integer ( blas_int ) :: n_ , k_ , lda_ , ldc_ logical :: ok if ( ARG_CHECK ) then ok = . true . ok = ok . and . abs ( n ) <= HUGE_BLAS_INT - 1 ok = ok . and . abs ( k ) <= HUGE_BLAS_INT - 1 ok = ok . and . abs ( lda ) <= HUGE_BLAS_INT - 1 ok = ok . and . abs ( ldc ) <= HUGE_BLAS_INT - 1 if (. not . ok ) call show_message ( ERRMSG , WITH_ABORT ) end if n_ = int ( n , blas_int ) k_ = int ( k , blas_int ) lda_ = int ( lda , blas_int ) ldc_ = int ( ldc , blas_int ) call zsyrk ( uplo , trans , n_ , k_ , alpha , a , lda_ , beta , c , ldc_ ) end subroutine oqp_zsyrk_i64 subroutine oqp_ztbmv_i64 ( uplo , trans , diag , n , k , a , lda , x , incx ) integer :: incx integer :: k integer :: lda integer :: n character :: diag character :: trans character :: uplo complex ( kind = 8 ) :: a ( lda , * ) complex ( kind = 8 ) :: x ( * ) integer ( blas_int ) :: n_ , k_ , lda_ , incx_ logical :: ok if ( ARG_CHECK ) then ok = . true . ok = ok . and . abs ( n ) <= HUGE_BLAS_INT - 1 ok = ok . and . abs ( k ) <= HUGE_BLAS_INT - 1 ok = ok . and . abs ( lda ) <= HUGE_BLAS_INT - 1 ok = ok . and . abs ( incx ) <= HUGE_BLAS_INT - 1 if (. not . ok ) call show_message ( ERRMSG , WITH_ABORT ) end if n_ = int ( n , blas_int ) k_ = int ( k , blas_int ) lda_ = int ( lda , blas_int ) incx_ = int ( incx , blas_int ) call ztbmv ( uplo , trans , diag , n_ , k_ , a , lda_ , x , incx_ ) end subroutine oqp_ztbmv_i64 subroutine oqp_ztbsv_i64 ( uplo , trans , diag , n , k , a , lda , x , incx ) integer :: incx integer :: k integer :: lda integer :: n character :: diag character :: trans character :: uplo complex ( kind = 8 ) :: a ( lda , * ) complex ( kind = 8 ) :: x ( * ) integer ( blas_int ) :: n_ , k_ , lda_ , incx_ logical :: ok if ( ARG_CHECK ) then ok = . true . ok = ok . and . abs ( n ) <= HUGE_BLAS_INT - 1 ok = ok . and . abs ( k ) <= HUGE_BLAS_INT - 1 ok = ok . and . abs ( lda ) <= HUGE_BLAS_INT - 1 ok = ok . and . abs ( incx ) <= HUGE_BLAS_INT - 1 if (. not . ok ) call show_message ( ERRMSG , WITH_ABORT ) end if n_ = int ( n , blas_int ) k_ = int ( k , blas_int ) lda_ = int ( lda , blas_int ) incx_ = int ( incx , blas_int ) call ztbsv ( uplo , trans , diag , n_ , k_ , a , lda_ , x , incx_ ) end subroutine oqp_ztbsv_i64 subroutine oqp_ztpmv_i64 ( uplo , trans , diag , n , ap , x , incx ) integer :: incx integer :: n character :: diag character :: trans character :: uplo complex ( kind = 8 ) :: ap ( * ) complex ( kind = 8 ) :: x ( * ) integer ( blas_int ) :: n_ , incx_ logical :: ok if ( ARG_CHECK ) then ok = . true . ok = ok . and . abs ( n ) <= HUGE_BLAS_INT - 1 ok = ok . and . abs ( incx ) <= HUGE_BLAS_INT - 1 if (. not . ok ) call show_message ( ERRMSG , WITH_ABORT ) end if n_ = int ( n , blas_int ) incx_ = int ( incx , blas_int ) call ztpmv ( uplo , trans , diag , n_ , ap , x , incx_ ) end subroutine oqp_ztpmv_i64 subroutine oqp_ztpsv_i64 ( uplo , trans , diag , n , ap , x , incx ) integer :: incx integer :: n character :: diag character :: trans character :: uplo complex ( kind = 8 ) :: ap ( * ) complex ( kind = 8 ) :: x ( * ) integer ( blas_int ) :: n_ , incx_ logical :: ok if ( ARG_CHECK ) then ok = . true . ok = ok . and . abs ( n ) <= HUGE_BLAS_INT - 1 ok = ok . and . abs ( incx ) <= HUGE_BLAS_INT - 1 if (. not . ok ) call show_message ( ERRMSG , WITH_ABORT ) end if n_ = int ( n , blas_int ) incx_ = int ( incx , blas_int ) call ztpsv ( uplo , trans , diag , n_ , ap , x , incx_ ) end subroutine oqp_ztpsv_i64 subroutine oqp_ztrmm_i64 ( side , uplo , transa , diag , m , n , alpha , a , lda , b , ldb ) complex ( kind = 8 ) :: alpha integer :: lda integer :: ldb integer :: m integer :: n character :: diag character :: side character :: transa character :: uplo complex ( kind = 8 ) :: a ( lda , * ) complex ( kind = 8 ) :: b ( ldb , * ) integer ( blas_int ) :: m_ , n_ , lda_ , ldb_ logical :: ok if ( ARG_CHECK ) then ok = . true . ok = ok . and . abs ( m ) <= HUGE_BLAS_INT - 1 ok = ok . and . abs ( n ) <= HUGE_BLAS_INT - 1 ok = ok . and . abs ( lda ) <= HUGE_BLAS_INT - 1 ok = ok . and . abs ( ldb ) <= HUGE_BLAS_INT - 1 if (. not . ok ) call show_message ( ERRMSG , WITH_ABORT ) end if m_ = int ( m , blas_int ) n_ = int ( n , blas_int ) lda_ = int ( lda , blas_int ) ldb_ = int ( ldb , blas_int ) call ztrmm ( side , uplo , transa , diag , m_ , n_ , alpha , a , lda_ , b , ldb_ ) end subroutine oqp_ztrmm_i64 subroutine oqp_ztrmv_i64 ( uplo , trans , diag , n , a , lda , x , incx ) integer :: incx integer :: lda integer :: n character :: diag character :: trans character :: uplo complex ( kind = 8 ) :: a ( lda , * ) complex ( kind = 8 ) :: x ( * ) integer ( blas_int ) :: n_ , lda_ , incx_ logical :: ok if ( ARG_CHECK ) then ok = . true . ok = ok . and . abs ( n ) <= HUGE_BLAS_INT - 1 ok = ok . and . abs ( lda ) <= HUGE_BLAS_INT - 1 ok = ok . and . abs ( incx ) <= HUGE_BLAS_INT - 1 if (. not . ok ) call show_message ( ERRMSG , WITH_ABORT ) end if n_ = int ( n , blas_int ) lda_ = int ( lda , blas_int ) incx_ = int ( incx , blas_int ) call ztrmv ( uplo , trans , diag , n_ , a , lda_ , x , incx_ ) end subroutine oqp_ztrmv_i64 subroutine oqp_ztrsm_i64 ( side , uplo , transa , diag , m , n , alpha , a , lda , b , ldb ) complex ( kind = 8 ) :: alpha integer :: lda integer :: ldb integer :: m integer :: n character :: diag character :: side character :: transa character :: uplo complex ( kind = 8 ) :: a ( lda , * ) complex ( kind = 8 ) :: b ( ldb , * ) integer ( blas_int ) :: m_ , n_ , lda_ , ldb_ logical :: ok if ( ARG_CHECK ) then ok = . true . ok = ok . and . abs ( m ) <= HUGE_BLAS_INT - 1 ok = ok . and . abs ( n ) <= HUGE_BLAS_INT - 1 ok = ok . and . abs ( lda ) <= HUGE_BLAS_INT - 1 ok = ok . and . abs ( ldb ) <= HUGE_BLAS_INT - 1 if (. not . ok ) call show_message ( ERRMSG , WITH_ABORT ) end if m_ = int ( m , blas_int ) n_ = int ( n , blas_int ) lda_ = int ( lda , blas_int ) ldb_ = int ( ldb , blas_int ) call ztrsm ( side , uplo , transa , diag , m_ , n_ , alpha , a , lda_ , b , ldb_ ) end subroutine oqp_ztrsm_i64 subroutine oqp_ztrsv_i64 ( uplo , trans , diag , n , a , lda , x , incx ) integer :: incx integer :: lda integer :: n character :: diag character :: trans character :: uplo complex ( kind = 8 ) :: a ( lda , * ) complex ( kind = 8 ) :: x ( * ) integer ( blas_int ) :: n_ , lda_ , incx_ logical :: ok if ( ARG_CHECK ) then ok = . true . ok = ok . and . abs ( n ) <= HUGE_BLAS_INT - 1 ok = ok . and . abs ( lda ) <= HUGE_BLAS_INT - 1 ok = ok . and . abs ( incx ) <= HUGE_BLAS_INT - 1 if (. not . ok ) call show_message ( ERRMSG , WITH_ABORT ) end if n_ = int ( n , blas_int ) lda_ = int ( lda , blas_int ) incx_ = int ( incx , blas_int ) call ztrsv ( uplo , trans , diag , n_ , a , lda_ , x , incx_ ) end subroutine oqp_ztrsv_i64 function oqp_dnrm2_i64 ( n , x , incx ) real ( kind = 8 ), external :: dnrm2 real ( kind = 8 ) :: oqp_dnrm2_i64 integer :: incx integer :: n real ( kind = 8 ) :: x ( * ) integer ( blas_int ) :: n_ , incx_ logical :: ok if ( ARG_CHECK ) then ok = . true . ok = ok . and . abs ( n ) <= HUGE_BLAS_INT - 1 ok = ok . and . abs ( incx ) <= HUGE_BLAS_INT - 1 if (. not . ok ) call show_message ( ERRMSG , WITH_ABORT ) end if n_ = int ( n , blas_int ) incx_ = int ( incx , blas_int ) oqp_dnrm2_i64 = dnrm2 ( n_ , x , incx_ ) end function oqp_dnrm2_i64 function oqp_dznrm2_i64 ( n , x , incx ) real ( kind = 8 ), external :: dznrm2 real ( kind = 8 ) :: oqp_dznrm2_i64 integer :: incx integer :: n complex ( kind = 8 ) :: x ( * ) integer ( blas_int ) :: n_ , incx_ logical :: ok if ( ARG_CHECK ) then ok = . true . ok = ok . and . abs ( n ) <= HUGE_BLAS_INT - 1 ok = ok . and . abs ( incx ) <= HUGE_BLAS_INT - 1 if (. not . ok ) call show_message ( ERRMSG , WITH_ABORT ) end if n_ = int ( n , blas_int ) incx_ = int ( incx , blas_int ) oqp_dznrm2_i64 = dznrm2 ( n_ , x , incx_ ) end function oqp_dznrm2_i64 function oqp_scnrm2_i64 ( n , x , incx ) real ( kind = 4 ), external :: scnrm2 real ( kind = 4 ) :: oqp_scnrm2_i64 integer :: incx integer :: n complex ( kind = 4 ) :: x ( * ) integer ( blas_int ) :: n_ , incx_ logical :: ok if ( ARG_CHECK ) then ok = . true . ok = ok . and . abs ( n ) <= HUGE_BLAS_INT - 1 ok = ok . and . abs ( incx ) <= HUGE_BLAS_INT - 1 if (. not . ok ) call show_message ( ERRMSG , WITH_ABORT ) end if n_ = int ( n , blas_int ) incx_ = int ( incx , blas_int ) oqp_scnrm2_i64 = scnrm2 ( n_ , x , incx_ ) end function oqp_scnrm2_i64 function oqp_snrm2_i64 ( n , x , incx ) real ( kind = 4 ), external :: snrm2 real ( kind = 4 ) :: oqp_snrm2_i64 integer :: incx integer :: n real ( kind = 4 ) :: x ( * ) integer ( blas_int ) :: n_ , incx_ logical :: ok if ( ARG_CHECK ) then ok = . true . ok = ok . and . abs ( n ) <= HUGE_BLAS_INT - 1 ok = ok . and . abs ( incx ) <= HUGE_BLAS_INT - 1 if (. not . ok ) call show_message ( ERRMSG , WITH_ABORT ) end if n_ = int ( n , blas_int ) incx_ = int ( incx , blas_int ) oqp_snrm2_i64 = snrm2 ( n_ , x , incx_ ) end function oqp_snrm2_i64 end module","tags":"","url":"sourcefile/blas_wrap.f90.html"},{"title":"blas_thread.F90 – OpenQP Fortran API","text":"Source Code !> @brief Runtime control of BLAS-library internal threading !> @details Thin Fortran interface to `blas_thread_ctl.c`, which resolves !>   the thread-count setter/getter of the linked BLAS library (OpenBLAS, !>   MKL, BLIS) at run time via dlsym().  Use it to switch BLAS to !>   single-threaded mode around OpenMP-parallel regions that issue many !>   small BLAS calls, where a BLAS-internal thread pool (e.g. pthread !>   builds of OpenBLAS) oversubscribes the machine and serializes on its !>   pool lock. !> !>   If the BLAS library is not recognized, `blas_thread_count` returns -1 !>   and `blas_thread_set` is a no-op, so the calls are always safe: !> !>     nSaved = blas_thread_count() !>     call blas_thread_set(1_c_int64_t) !>     !$omp parallel !>     ... !>     !$omp end parallel !>     call blas_thread_set(nSaved)  ! no-op if nSaved == -1 module blas_thread use , intrinsic :: iso_c_binding , only : c_int64_t implicit none private public :: blas_thread_count public :: blas_thread_set interface !> @brief Current BLAS thread count, or -1 if the BLAS library is unknown function blas_thread_count () bind ( c , name = \"oqp_blas_thread_count\" ) result ( n ) import :: c_int64_t integer ( c_int64_t ) :: n end function !> @brief Set BLAS thread count; no-op for n < 1 or unknown BLAS library subroutine blas_thread_set ( n ) bind ( c , name = \"oqp_blas_thread_set\" ) import :: c_int64_t integer ( c_int64_t ), value :: n end subroutine end interface end module blas_thread","tags":"","url":"sourcefile/blas_thread.f90.html"},{"title":"boys.F90 – OpenQP Fortran API","text":"Source Code ! @brief This module contains Boys function code module boys use precision , only : dp , qp use boys_lut , only : fgrid , xgrid , rfinc , rmr , tlgm , tmax , rxinc , nord , igrid , irgrd implicit none private public boysf public fgrid public xgrid public rfinc public rmr public rxinc public tlgm public tmax public nord public igrid public irgrd real ( kind = 8 ), parameter :: & pi = 4 * atan ( 1.0_dp ), & sqrtpi = sqrt ( pi ), & halfsqrtpi = 0.5d0 * sqrtpi contains !    subroutine boysf(n, tt, ftout) pure subroutine boysf ( n , tt , ft ) !!$omp declare simd(boysf) uniform(n) linear(ref(tt)) implicit none real ( kind = 8 ), intent ( in ) :: tt integer , intent ( in ) :: n !real(kind=8), intent(out) :: ftout(0:) real ( kind = 8 ) :: ftf !real(kind=8) :: ft(0:16) real ( kind = 8 ), intent ( out ) :: ft ( 0 : * ) real ( kind = 8 ) :: tv , tx , fx , et , t2 integer :: m , ip , ix , ifxgrd , iftgrd if ( tt > tmax ) then ftf = halfsqrtpi / sqrt ( tt ) t2 = tt * 2 do m = 0 , n ft ( m ) = tlgm ( m ) * ftf ftf = ftf / t2 end do else ifxgrd = igrid ( n ) iftgrd = irgrd ( n ) tv = tt * rfinc ( ifxgrd ) tx = tt * rxinc ip = nint ( tv ) ix = nint ( tx ) fx = 0 et = 0 do m = nord , 0 , - 1 fx = ( fx * tv + fgrid ( m , ip , ifxgrd )) et = ( et * tx + xgrid ( m , ix )) end do ft ( iftgrd ) = fx t2 = tt + tt do m = iftgrd , 1 , - 1 ft ( m - 1 ) = ( t2 * ft ( m ) + et ) * rmr ( m ) end do end if !ftout(0:n) = ft(0:n) end subroutine boysf end module boys","tags":"","url":"sourcefile/boys.f90.html"},{"title":"guess.F90 – OpenQP Fortran API","text":"Source Code ! 17 Aug 12 - CHC - Initial program ! This moldule contains initial guess routines. ! module guess use precision , only : dp use oqp_linalg implicit none private public get_ab_initio_density public get_ab_initio_orbital public corresponding_orbital_projection public mksphar contains !> @brief  this will calculatte the density matrix subroutine get_ab_initio_density ( alpha_density , alpha_orbital , beta_density , beta_orbital , infos , basis ) use mathlib , only : orb_to_dens use messages , only : show_message , with_abort use types , only : information use basis_tools , only : basis_set implicit none type ( information ), intent ( in ) :: infos type ( basis_set ), intent ( in ) :: basis integer :: ok integer :: scftype , nocc , na , nb , nbasis , na2 real ( dp ) :: alpha_density (:), & alpha_orbital (:,:) real ( dp ), optional :: beta_density (:), & beta_orbital (:,:) real ( dp ), dimension (:), allocatable :: occno ! scftype = infos % control % scftype na = infos % mol_prop % nelec_a nb = infos % mol_prop % nelec_b nbasis = basis % nbf nocc = infos % mol_prop % nocc allocate ( occno ( nocc ), stat = ok ) if ( ok /= 0 ) call show_message ( 'allocation of occno fails' , with_abort ) occno = 2 if ( scftype /= 1 ) occno = 1 na2 = nocc if ( scftype /= 1 ) na2 = na !  alpha density is always calculated for RHF/ROHF/UHF call orb_to_dens ( alpha_density , alpha_orbital , occno , na2 , nbasis , nbasis ) if ( nb == 0 ) then beta_density = 0 if ( scftype == 2 ) beta_orbital = 0 else select case ( scftype ) case ( 1 ) case ( 2 ) call orb_to_dens ( beta_density , beta_orbital , occno , nb , nbasis , nbasis ) case ( 3 ) call orb_to_dens ( beta_density , alpha_orbital , occno , nb , nbasis , nbasis ) end select end if end subroutine get_ab_initio_density !> @brief Solve \\f$ F C = \\eps S C \\f$ subroutine get_ab_initio_orbital ( fock_m , orbitals , orbital_e , q_m ) use messages , only : show_message , WITH_ABORT use mathlib , only : orthogonal_transform use eigen , only : diag_symm_full use mathlib , only : unpack_matrix , pack_matrix implicit none ! real ( kind = dp ) :: orbital_e ( * ) real ( kind = dp ) :: fock_m ( * ) real ( kind = dp ) :: orbitals (:,:), q_m (:,:) real ( kind = dp ), allocatable :: wrk (:,:), f2 (:,:), tfock (:,:) integer :: info , ok , nbf nbf = ubound ( orbitals , 1 ) allocate ( wrk ( nbf , nbf ), f2 ( nbf , nbf ), tfock ( nbf , nbf ), stat = ok ) if ( ok /= 0 ) call show_message ( 'Cannot allocate memory' , WITH_ABORT ) call unpack_matrix ( fock_m , f2 ) ! F = S&#94;{-1/2} * F * S&#94;{-1/2} ! can use orthogonal_transform subroutine, because S&#94;{-1/2} is symmetric call orthogonal_transform ( 'n' , nbf , q_m , f2 , tfock , wrk ) deallocate ( f2 , wrk ) ! Get orbitals C' = S&#94;{1/2} C call diag_symm_full ( 1 , nbf , tfock , nbf , orbital_e , info ) ! Recover orbitals in AO basis ! C = S&#94;{-1/2} * C' call dgemm ( 'n' , 'n' , nbf , nbf , nbf , & 1.0_dp , q_m , nbf , & tfock , nbf , & 0.0_dp , orbitals , nbf ) end subroutine get_ab_initio_orbital !> !> @brief Corresponding orbital projection !> @param[in]     nproj  number of orbitals from `vb` to projected onto !> @param[in]     l0     number of the first orbitals from the `va` space to project `vb` to !> @param[in,out] va     `a` orbitals on entry, !>                       replaced by corresponding orbitals on exit !> @param[in]     vb     `b` orbitals on entry, unchanged on exit !> @param[in]     sba    overlap integrals between the two bases, ! !> @note The corresponding orbitals in the `b` basis are not generated. !> @note H.F.King, R.E.Stanton, H.Kim, R.E.Wyatt, R.G.Parr J.Chem.Phys. 47, 1936-1941 (1967) subroutine corresponding_orbital_projection ( vb , sba , va , & ndoc , nact , nproj , nbf , l1co , l0 ) use messages , only : show_message , WITH_ABORT implicit none real ( kind = dp ) :: vb ( l1co , nproj ), sba ( l1co , nbf ), va ( nbf , l0 ) integer :: ndoc , nact , nproj , nbf , l1co , l0 real ( kind = dp ), allocatable :: & vaco (:,:), rhs (:,:), d (:,:), tmp (:,:), scr (:) integer , allocatable :: iwrk (:) logical , allocatable :: unused (:) integer :: ok allocate ( vaco ( nbf , nbf ), & rhs ( nbf , nbf ), & d ( nbf , l0 ), & tmp ( nbf , nbf ), & scr ( nbf ), & source = 0.0_dp , & stat = ok ) allocate ( iwrk ( nbf ), & source = 0 , & stat = ok ) allocate ( unused ( nbf ), & source = . false ., & stat = ok ) ! Precompute Vb&#94;T * Sba once for all nproj reference orbitals; ! each project() call below uses its own row block of it call dgemm ( 't' , 'n' , nproj , nbf , l1co , & 1.0_dp , vb , l1co , & sba , l1co , & 0.0_dp , rhs , nbf ) ! The three orbital subspaces are projected independently and in ! order, so that each later step works in the orthogonal complement ! of the previous ones: ! 1. doubly occupied (core) space call project ( va , rhs , 1 , ndoc , l0 , nbf ) ! 2. singly occupied (active) space, ROHF/UHF only call project ( va , rhs , ndoc + 1 , ndoc + nact , l0 , nbf ) ! 3. low virtual space call project ( va , rhs , ndoc + nact + 1 , nproj , l0 , nbf ) contains subroutine project ( va , rhs , minmo , maxmo , l0 , nbf ) implicit none real ( kind = dp ) :: va ( nbf , * ), rhs ( nbf , * ) integer :: minmo , maxmo , l0 , nbf integer :: i , j integer :: nrest , nmo , nsv , lwork , info real ( kind = dp ), allocatable :: sv (:), vt (:,:), wrk (:) real ( kind = dp ) :: wrksize ( 1 ), udummy ( 1 ) nrest = l0 - minmo + 1 nmo = maxmo - minmo + 1 if ( nrest <= 0 ) return if ( nmo == 0 ) return !   Overlap between the nmo reference orbitals (b set) and the !   nrest orbitals of the active window of the a set: !   D = Vb&#94;T * Sab * Va, dimension (nmo x nrest). !   rhs already holds Vb&#94;T * Sab for all nproj reference orbitals. call dgemm ( 'n' , 'n' , nmo , nrest , nbf , & 1.0_dp , rhs ( minmo , 1 ), nbf , & va ( 1 , minmo ), nbf , & 0.0_dp , d , nbf ) !   We need the `nmo` eigenvectors of D&#94;T * D with the largest !   eigenvalues (largest overlap with the `b` set); they are the !   leading right singular vectors of D. The thin SVD of the !   (nmo x nrest) matrix D delivers them in descending-overlap order !   at O(nmo&#94;2*nrest) cost, instead of the O(nrest&#94;3) diagonalization !   of D&#94;T * D. We don't need the singular values. nsv = min ( nmo , nrest ) allocate ( sv ( nsv ), vt ( nsv , nrest )) call dgesvd ( 'N' , 'S' , nmo , nrest , d , nbf , sv , udummy , 1 , vt , nsv , & wrksize , - 1 , info ) lwork = int ( wrksize ( 1 )) allocate ( wrk ( lwork )) call dgesvd ( 'N' , 'S' , nmo , nrest , d , nbf , sv , udummy , 1 , vt , nsv , & wrk , lwork , info ) if ( info /= 0 ) & call show_message ( 'Corresponding orbital projection: SVD failed' , WITH_ABORT ) vaco ( 1 : nrest , 1 : nsv ) = transpose ( vt ( 1 : nsv , 1 : nrest )) deallocate ( sv , vt , wrk ) !   Cannot project more orbitals than the remaining space can hold if ( nmo > nrest ) & call show_message ( 'Corresponding orbital projection: nmo > nrest' , WITH_ABORT ) !   Rotate va to the corresponding orbital set, a' = a*Q, where the !   orthogonal Q completes the nmo leading corresponding vectors to a !   full basis of the nrest space (the near zero overlap part of the !   space is not determined by the SVD; the QR completion provides a !   symmetry adapted complement). Q is applied directly from its !   Householder reflectors (dgeqrf+dormqr) at O(nbf*nrest*nmo) cost, !   instead of forming Q explicitly and multiplying at O(nbf*nrest&#94;2). call dgeqrf ( nrest , nmo , vaco , nbf , scr , wrksize , - 1 , info ) lwork = int ( wrksize ( 1 )) call dormqr ( 'r' , 'n' , nbf , nrest , nmo , vaco , nbf , scr , & va ( 1 , minmo ), nbf , wrksize , - 1 , info ) lwork = max ( lwork , int ( wrksize ( 1 ))) allocate ( wrk ( lwork )) call dgeqrf ( nrest , nmo , vaco , nbf , scr , wrk , lwork , info ) call dormqr ( 'r' , 'n' , nbf , nrest , nmo , vaco , nbf , scr , & va ( 1 , minmo ), nbf , wrk , lwork , info ) deallocate ( wrk ) !   Get overlap between `b` and the `a'` corresponding set, !   D = Vb&#94;T * Sab * VaCO !   Only the leading (nmo x nmo) block is used by the pairing below. call dgemm ( 't' , 't' , nmo , nmo , nbf , & 1.0_dp , va ( 1 , minmo ), nbf , & rhs ( minmo , 1 ), nbf , & 0.0_dp , tmp , nbf ) !   Pair each projected orbital with the reference orbital it !   overlaps most (greedy assignment), so that guess orbital i !   corresponds to Huckel/old MO i in order unused (: nmo ) = . true . do i = 1 , nmo j = maxloc ( abs ( tmp (: nmo , i )), dim = 1 , mask = unused ) iwrk ( i ) = j unused ( j ) = . false . end do call reorder_columns ( va ( 1 , minmo ), iwrk , nmo , nbf ) end subroutine end subroutine corresponding_orbital_projection !> @brief Reorder a set of molecular orbitals !> @param[in]     iorder  reordering instructions !> @param[in,out] v       matrix (ldv,n) to reorder !> @param[in]     ldv     matrix dimension !> @param[in]     n       matrix dimension subroutine reorder_columns ( v , iorder , n , ldv ) use messages , only : show_message , WITH_ABORT implicit none real ( kind = dp ), intent ( inout ) :: v ( ldv , * ) integer , intent ( inout ) :: iorder ( * ) integer , intent ( in ) :: n , ldv integer :: i , j , k do i = 1 , n if (. not . any ( iorder ( 1 : n ) == i )) then call show_message ( \"(A,I4,A)\" , \"**** Error, element\" , i , & \" is missing from reordering instructions\" , WITH_ABORT ) end if end do do i = 1 , n j = iorder ( i ) call dswap ( ldv , v (:, i ), 1 , v (:, j ), 1 ) do k = i + 1 , n if ( iorder ( k ) == i ) iorder ( k ) = j end do end do end subroutine reorder_columns ! !> @brief   Generate transformation to spherical harmonics basis !> !> @details This is used by the MINI basis during the Huckel guess, !>          to convert any d or f shells to spherical harmonics. !> !> @author  MWS: 4/2013 rewrite returns pure s,p,d,f spherical subroutine mksphar ( w , l1co , l0co , notsp , basis ) use messages , only : show_message , WITH_ABORT use basis_tools , only : basis_set ! implicit none ! ! type ( basis_set ), intent ( in ) :: basis logical :: notsp real ( kind = dp ) :: w ( l1co , l1co ) integer :: l1co , l0co ! real ( kind = dp ), parameter :: RT0304 = SQRT ( 3.0D+00 / 4.0D+00 ) real ( kind = dp ), parameter :: RT0920 = SQRT ( 9.0D+00 / 2 0.0D+00 ) integer :: sph , ncont , n , cart , ndim , l ! !     Transform to spherical harmonic basis w = 0 sph = 1 ncont = 0 notsp = . false . do n = 1 , basis % nshell notsp = notsp . or . ( basis % am ( n ) > 1 ) ! !        S,P,L shell is already spherical harmonics. if ( basis % am ( n ) <= 1 ) then cart = basis % ao_offset ( n ) ndim = basis % naos ( n ) do l = 1 , ndim w ( cart + l - 1 , sph + l - 1 ) = 1.0d0 enddo sph = sph + ndim end if ! if ( basis % am ( n ) == 2 ) then cart = basis % ao_offset ( n ) !           true D orbitals, from eg irrep of Oh w ( cart , sph ) = rt0304 w ( cart + 1 , sph ) = - rt0304 w ( cart , sph + 1 ) = - 0.5d0 w ( cart + 1 , sph + 1 ) = - 0.5d0 w ( cart + 2 , sph + 1 ) = 1.0d0 !           true d orbitals, from t2g irrep of oh w ( cart + 3 , sph + 2 ) = 1.0d0 w ( cart + 4 , sph + 3 ) = 1.0d0 w ( cart + 5 , sph + 4 ) = 1.0d0 ncont = ncont + 1 sph = sph + 5 end if ! if ( basis % am ( n ) == 3 ) then cart = basis % ao_offset ( n ) !           T1U (IN OH) COMBINATIONS w ( cart , sph ) = 1.0d0 w ( cart + 5 , sph ) = - rt0920 w ( cart + 7 , sph ) = - rt0920 w ( cart + 1 , sph + 1 ) = 1.0d0 w ( cart + 3 , sph + 1 ) = - rt0920 w ( cart + 8 , sph + 1 ) = - rt0920 w ( cart + 2 , sph + 2 ) = 1.0d0 w ( cart + 4 , sph + 2 ) = - rt0920 w ( cart + 6 , sph + 2 ) = - rt0920 !           t2u (in oh) combinations w ( cart + 5 , sph + 3 ) = rt0304 w ( cart + 7 , sph + 3 ) = - rt0304 w ( cart + 3 , sph + 4 ) = rt0304 w ( cart + 8 , sph + 4 ) = - rt0304 w ( cart + 4 , sph + 5 ) = rt0304 w ( cart + 6 , sph + 5 ) = - rt0304 !           a2u (in oh) combination w ( cart + 9 , sph + 6 ) = 1.0d0 ncont = ncont + 3 sph = sph + 7 end if ! if ( basis % am ( n ) > 3 ) then CALL show_message ( 'MKSPHAR: CALLED FOR BASIS WITH G/H/I AOS' , WITH_ABORT ) end if end do l0co = l1co - ncont end subroutine mksphar end module guess","tags":"","url":"sourcefile/guess.f90.html"},{"title":"nmr_giao_shielding.F90 – OpenQP Fortran API","text":"Source Code module nmr_giao_shielding_mod use precision , only : dp implicit none character ( len =* ), parameter :: module_name = \"nmr_giao_shielding_mod\" private public nmr_giao_shielding_debug contains subroutine nmr_giao_shielding_debug_C ( c_handle ) bind ( C , name = \"nmr_giao_shielding_debug\" ) use c_interop , only : oqp_handle_t , oqp_handle_get_info use types , only : information type ( oqp_handle_t ) :: c_handle type ( information ), pointer :: inf inf => oqp_handle_get_info ( c_handle ) call nmr_giao_shielding_debug ( inf ) end subroutine nmr_giao_shielding_debug_C !> Production entry point for GIAO NMR shielding (RHF/UHF/ROHF). subroutine nmr_giao_shielding_C ( c_handle ) bind ( C , name = \"nmr_giao_shielding\" ) use c_interop , only : oqp_handle_t , oqp_handle_get_info use types , only : information type ( oqp_handle_t ) :: c_handle type ( information ), pointer :: inf inf => oqp_handle_get_info ( c_handle ) call nmr_giao_shielding_debug ( inf ) end subroutine nmr_giao_shielding_C !> @brief Test-only/debug emitter for native GIAO (London-orbital) NMR shielding. !> @details Computes the GIAO paramagnetic nuclear magnetic shielding tensor for !>  RHF/UHF/ROHF (and the corresponding DFT) references.  Open-shell support: !>  the diamagnetic term uses the total density D_alpha+D_beta; the paramagnetic !>  term is solved per spin channel (independent same-spin exchange response) and !>  summed.  ROHF orbitals are semicanonicalized (from the ground-state spin Fock !>  matrices) so the UHF-like CPHF is well defined; the closed-shell ROHF limit !>  reproduces RHF, and open-shell UHF/ROHF match an independent GIAO reference to ~1e-4 !>  ppm (OH, CH3 radicals).  Built from the validated native GIAO building blocks: !>   - first-order GIAO core Hamiltonian h10 (one-electron, giao_h10_core), !>   - first-order GIAO two-electron Fock derivative (giao_h10_twoe_matrix), !>   - first-order GIAO overlap derivative S10 (giao_overlap_derivative), !>   - the PSO operator at each nucleus (pso_integrals). !>  It assembles the magnetic first-order Hamiltonian/overlap in the MO basis, !>  solves the GIAO CPHF/CPKS first-order equation (uncoupled and coupled; the !>  coupled response is exchange-only for the imaginary/antisymmetric first-order !>  density, scaled by the exact-exchange fraction c_x), and contracts the !>  resulting first-order density with the PSO operator to form the paramagnetic !>  shielding. !> !>  Hartree-Fock (RHF/UHF/ROHF) is validated against an independent GIAO reference. !> !>  DFT (RKS/UKS/ROKS) is supported: the closed-shell h1 two-electron exchange is !>  scaled by c_x, and the London (GIAO) derivative of the exchange-correlation !>  potential (the \"vxc_giao\" term -- an essential contribution, ~tens of ppm) is !>  added via a GIAO-weighted XC grid integration (mod_dft_gridint_giao::giao_vxc; !>  the London derivative of the AO values and gradients).  Validated vs an independent !>  reference (replicating get_vxc_giao): H2O/PBE and /PBE0 reproduce the !>  reference to ~1e-3 ppm.  vxc_giao is grid-sensitive, so DFT GIAO benefits from !>  a converged integration grid. !> !>  Results are written as machine-parseable records to the log so !>  the native GIAO path can be validated against an independent GIAO reference WITHOUT !>  ungating production nmr_gauge=giao. !> !>  Diamagnetic GIAO term (both pieces reference-validated): !>   - a11part (London diamagnetic): validated CGO diamagnetic at gauge origin 0 !>     plus the Hellmann-Feynman field correction weighted by the ket center. !>   - a01gp (GIAO gauge correction = London derivative of the PSO): cvec x M, !>     M&#94;{(col)}_b = <mu| r_b PSO_col |nu> with r referenced to the molecular !>     origin (R0I = (r-R_bra) bra-raise + R_bra*base, the libcint convention). !>     Full-tensor agreement with libcint int1e_a01gp to ~3e-8 (e.g. CH4). !>  Total GIAO shielding matches an independent GIAO reference to ~1e-4 ppm for HF !>  (grid-free) and to cross-code DFT-SCF/grid level (~0.03 ppm) for DFT, for all !>  geometries and angular momenta tested (He, H2, HF, CO2, CH4, H2O). !>  SG/SC/SA are sign/scale conventions fixed against the oracle (SA folds the !>  factor-2 normalization of the native a01gp vs the libcint int1e_a01gp). !> !>  References (GIAO/London-orbital NMR shielding methodology): !>   - F. London, J. Phys. Radium 8, 397 (1937). !>   - R. Ditchfield, Mol. Phys. 27, 789 (1974). !>   - K. Wolinski, J. F. Hinton, P. Pulay, J. Am. Chem. Soc. 112, 8251 (1990). !>   - T. Helgaker, M. Jaszunski, K. Ruud, Chem. Rev. 99, 293 (1999). subroutine nmr_giao_shielding_debug ( infos ) use io_constants , only : iw use oqp_tagarray_driver use basis_tools , only : basis_set use messages , only : show_message , with_abort use types , only : information use constants , only : tol_int use int1 , only : giao_h10_core , giao_overlap_derivative , pso_integrals , & nmr_dia_shielding , giao_a11part_corr , giao_a01gp_contract use nmr_giao_debug_mod , only : giao_h10_twoe_matrix use dft , only : dft_initialize use mod_dft_molgrid , only : dft_grid_t use mod_dft_gridint_giao , only : giao_vxc implicit none character ( len =* ), parameter :: subroutine_name = \"nmr_giao_shielding_debug\" real ( kind = dp ), parameter :: ALPHA = 1.0d0 / 13 7.035999084d0 real ( kind = dp ), parameter :: a2ppm = ALPHA * ALPHA * 1.0d6 real ( kind = dp ), parameter :: ha2ppm = 0.5d0 * ALPHA * ALPHA * 1.0d6 ! Calibration signs for the GIAO diamagnetic pieces (fixed vs the reference). real ( kind = dp ), parameter :: SG = - 1.0d0 , SC = 1.0d0 , SA = - 0.5d0 real ( kind = dp ), parameter :: SX = - 1.0d0 ! London-XC (vxc_giao): h1 -= vxc_giao type ( information ), target , intent ( inout ) :: infos type ( basis_set ), pointer :: basis integer :: nbf , nbf2 , nat , nocc , nmo , nvir , nocc_b integer :: i , j , m , c , t , s , ok , iat integer ( 4 ) :: status logical :: is_dft , open_shell , iw_open real ( kind = dp ) :: tol , scale_exch real ( kind = dp ), allocatable :: h10p (:,:), s10p (:,:) ! packed (nbf2,3) real ( kind = dp ), allocatable :: twoe (:,:,:), twoe2 (:,:,:), vj (:,:,:), vk (:,:,:), vkb (:,:,:) real ( kind = dp ), allocatable :: dm (:,:), dmp (:), dm_b (:,:) real ( kind = dp ), allocatable :: h1ao (:,:,:), h1ao_b (:,:,:), s1ao (:,:,:) ! (nbf,nbf,3) real ( kind = dp ), allocatable :: coords (:,:), zq (:) real ( kind = dp ), allocatable :: sig_u (:,:,:), sig_c (:,:,:) ! (3,3,nat) real ( kind = dp ), allocatable :: vxa (:,:,:), vxb (:,:,:) ! London-XC (vxc_giao) type ( dft_grid_t ) :: molGrid integer :: mxAngMom real ( kind = dp ), allocatable :: gdia0 (:,:,:), corrpre (:,:,:) ! GIAO dia pieces real ( kind = dp ), allocatable :: a01 (:,:,:) ! a01gp contracted real ( kind = dp ), allocatable :: sig_dia (:,:,:), sig_tot (:,:,:) ! (3,3,nat) real ( kind = dp ) :: trg0 , trc , o0 ( 3 ) real ( kind = dp ), contiguous , pointer :: dmat_a (:), dmat_b (:) real ( kind = dp ), contiguous , pointer :: mo_a (:,:), mo_b (:,:) real ( kind = dp ), contiguous , pointer :: mo_e (:), mo_e_b (:) real ( kind = dp ), contiguous , pointer :: fock_a (:), fock_b (:) real ( kind = dp ), contiguous , pointer :: nmrout (:) real ( kind = dp ), allocatable :: ca_sc (:,:), cb_sc (:,:), ea_sc (:), eb_sc (:) basis => infos % basis basis % atoms => infos % atoms nbf = basis % nbf nbf2 = nbf * ( nbf + 1 ) / 2 nat = ubound ( basis % atoms % zn , 1 ) tol = log ( 1 0.0d0 ) * tol_int ! Connect the log unit early so guard aborts and CPHF warnings land in the ! log instead of an orphan fort.* file. inquire ( unit = iw , opened = iw_open ) if (. not . iw_open ) open ( unit = iw , file = infos % log_filename , position = \"append\" ) call tagarray_get_data ( infos % dat , OQP_DM_A , dmat_a , status ) call check_status ( status , module_name , subroutine_name , OQP_DM_A ) call tagarray_get_data ( infos % dat , OQP_VEC_MO_A , mo_a , status ) call check_status ( status , module_name , subroutine_name , OQP_VEC_MO_A ) call tagarray_get_data ( infos % dat , OQP_E_MO_A , mo_e , status ) call check_status ( status , module_name , subroutine_name , OQP_E_MO_A ) ! scftype: 1=RHF (closed shell), 2=UHF, 3=ROHF open_shell = infos % control % scftype == 2 . or . infos % control % scftype == 3 nmo = size ( mo_e ) if ( open_shell ) then nocc = int ( infos % mol_prop % nelec_A ) nocc_b = int ( infos % mol_prop % nelec_B ) call tagarray_get_data ( infos % dat , OQP_DM_B , dmat_b , status ) call check_status ( status , module_name , subroutine_name , OQP_DM_B ) call tagarray_get_data ( infos % dat , OQP_VEC_MO_B , mo_b , status ) call check_status ( status , module_name , subroutine_name , OQP_VEC_MO_B ) call tagarray_get_data ( infos % dat , OQP_E_MO_B , mo_e_b , status ) call check_status ( status , module_name , subroutine_name , OQP_E_MO_B ) else nocc = int ( infos % mol_prop % nocc ) nocc_b = nocc end if nvir = nmo - nocc is_dft = infos % control % hamilton == 20 scale_exch = 1.0d0 if ( is_dft ) scale_exch = infos % dft % HFscale ! Not-implemented classes must abort instead of silently producing wrong ! shieldings: !  - CAM/range-separated hybrids: the coupled magnetic response and the !    GIAO two-electron derivative use the global exchange fraction only; !    the range-separation attenuation (alpha/beta/mu) is not wired in. !  - meta-GGAs: the tau channel of the London-XC (vxc_giao) term is not !    implemented (mod_dft_gridint_giao evaluates LDA/GGA ingredients only). !  - ECP: no effective-core magnetic-derivative term is implemented. if ( is_dft ) then if ( infos % dft % cam_flag ) then call show_message ( 'GIAO NMR shielding with range-separated (CAM) & &functionals is not implemented' , with_abort ) end if if ( infos % functional % needtau ) then call show_message ( 'GIAO NMR shielding with meta-GGA (tau-dependent) & &functionals is not implemented' , with_abort ) end if end if if ( allocated ( infos % basis % ecp_zn_num )) then if ( any ( infos % basis % ecp_zn_num /= 0 )) then call show_message ( 'GIAO NMR shielding with ECP basis sets is not & &implemented' , with_abort ) end if end if allocate ( coords ( 3 , nat ), zq ( nat )) do iat = 1 , nat coords (:, iat ) = basis % atoms % xyz (:, iat ) end do zq = infos % atoms % zn - infos % basis % ecp_zn_num ! --- Total density (full + packed).  For RHF OQP_DM_A is already the total !     (closed-shell) density; for UHF/ROHF total = D_alpha + D_beta. --- allocate ( dm ( nbf , nbf ), dmp ( nbf2 ), source = 0.0d0 ) if ( open_shell ) then allocate ( dm_b ( nbf , nbf ), source = 0.0d0 ) dmp = dmat_a + dmat_b call unpack_sym ( dmat_a , dm , nbf ) ! D_alpha call unpack_sym ( dmat_b , dm_b , nbf ) ! D_beta else dmp = dmat_a call unpack_sym ( dmp , dm , nbf ) ! D_total (closed shell) end if ! --- One-electron GIAO Hamiltonian h10(1e) and overlap derivative S10 --- allocate ( h10p ( nbf2 , 3 ), s10p ( nbf2 , 3 ), source = 0.0d0 ) call giao_h10_core ( basis , coords , zq , h10p , debug = . false ., logtol = tol ) call giao_overlap_derivative ( basis , s10p , debug = . false ., logtol = tol ) allocate ( h1ao ( nbf , nbf , 3 ), s1ao ( nbf , nbf , 3 ), source = 0.0d0 ) do c = 1 , 3 call expand_antisym ( h10p (:, c ), h1ao (:,:, c ), nbf ) call expand_antisym ( s10p (:, c ), s1ao (:,:, c ), nbf ) end do ! --- London (GIAO) derivative of the XC potential (vxc_giao); DFT only --- allocate ( vxa ( 3 , nbf , nbf ), vxb ( 3 , nbf , nbf ), source = 0.0d0 ) if ( is_dft ) then mxAngMom = maxval ( basis % am ) + 2 call dft_initialize ( infos , basis , molGrid ) block real ( kind = dp ), allocatable :: ca (:,:), cb (:,:) allocate ( ca ( nbf , nbf ), cb ( nbf , nbf )) ca = mo_a (:, 1 : nbf ) if ( open_shell ) then cb = mo_b (:, 1 : nbf ) call giao_vxc ( basis , molGrid , infos , ca , cb , . true ., & vxa , vxb , mxAngMom , nbf , infos % dft % grid_density_cutoff ) else cb = ca call giao_vxc ( basis , molGrid , infos , ca , cb , . false ., & vxa , vxb , mxAngMom , nbf , infos % dft % grid_density_cutoff ) end if deallocate ( ca , cb ) end block end if ! --- Two-electron GIAO Fock derivative --- allocate ( twoe ( 3 , nbf , nbf ), twoe2 ( 3 , nbf , nbf ), vj ( 3 , nbf , nbf ), vk ( 3 , nbf , nbf ), source = 0.0d0 ) allocate ( sig_u ( 3 , 3 , nat ), sig_c ( 3 , 3 , nat ), source = 0.0d0 ) if ( open_shell ) then ! Spin-resolved: h1_sigma = h10(1e) + J[D_tot] - cx*K[D_sigma].  giao_h10_ ! twoe_matrix returns (vj=J, vk=K, h10) for its input density; call it once ! per density, using a throwaway 'twoe' for the unused J/h10 outputs. allocate ( vkb ( 3 , nbf , nbf ), h1ao_b ( nbf , nbf , 3 ), source = 0.0d0 ) call giao_h10_twoe_matrix ( basis , infos , dm + dm_b , vj , twoe , twoe2 ) ! vj  = J[D_tot] call giao_h10_twoe_matrix ( basis , infos , dm , twoe , vk , twoe2 ) ! vk  = K[D_a] call giao_h10_twoe_matrix ( basis , infos , dm_b , twoe , vkb , twoe2 ) ! vkb = K[D_b] do c = 1 , 3 do i = 1 , nbf do j = 1 , nbf h1ao_b ( i , j , c ) = h1ao ( i , j , c ) + vj ( c , i , j ) - scale_exch * vkb ( c , i , j ) + SX * vxb ( c , i , j ) h1ao ( i , j , c ) = h1ao ( i , j , c ) + vj ( c , i , j ) - scale_exch * vk ( c , i , j ) + SX * vxa ( c , i , j ) end do end do end do ! Two independent spin channels (same-spin exchange), each occ_factor = 1. if ( infos % control % scftype == 3 ) then ! ROHF: a single orbital set with effective-Fock eigenvalues.  Build ! semicanonical spin orbitals/energies from the ground-state spin Fock ! matrices so the UHF-like CPHF/Delta-e is well defined. call tagarray_get_data ( infos % dat , OQP_FOCK_A , fock_a , status ) call check_status ( status , module_name , subroutine_name , OQP_FOCK_A ) call tagarray_get_data ( infos % dat , OQP_FOCK_B , fock_b , status ) call check_status ( status , module_name , subroutine_name , OQP_FOCK_B ) allocate ( ca_sc ( nbf , nmo ), cb_sc ( nbf , nmo ), ea_sc ( nmo ), eb_sc ( nmo ), source = 0.0d0 ) call semicanon_orbitals ( fock_a , mo_a , nbf , nmo , nocc , ca_sc , ea_sc ) call semicanon_orbitals ( fock_b , mo_b , nbf , nmo , nocc_b , cb_sc , eb_sc ) call giao_para_channel ( infos , basis , ca_sc , ea_sc , nocc , nmo , nbf , nat , & coords , h1ao , s1ao , scale_exch , 1.0d0 , sig_u , sig_c ) call giao_para_channel ( infos , basis , cb_sc , eb_sc , nocc_b , nmo , nbf , nat , & coords , h1ao_b , s1ao , scale_exch , 1.0d0 , sig_u , sig_c ) else call giao_para_channel ( infos , basis , mo_a , mo_e , nocc , nmo , nbf , nat , & coords , h1ao , s1ao , scale_exch , 1.0d0 , sig_u , sig_c ) call giao_para_channel ( infos , basis , mo_b , mo_e_b , nocc_b , nmo , nbf , nat , & coords , h1ao_b , s1ao , scale_exch , 1.0d0 , sig_u , sig_c ) end if else ! Closed shell: h1 = h10(1e) + (J - 0.5 K)[D_tot] (twoe), single channel. call giao_h10_twoe_matrix ( basis , infos , dm , vj , vk , twoe ) do c = 1 , 3 do i = 1 , nbf do j = 1 , nbf h1ao ( i , j , c ) = h1ao ( i , j , c ) + vj ( c , i , j ) - 0.5d0 * scale_exch * vk ( c , i , j ) + SX * vxa ( c , i , j ) end do end do end do call giao_para_channel ( infos , basis , mo_a , mo_e , nocc , nmo , nbf , nat , & coords , h1ao , s1ao , scale_exch , 2.0d0 , sig_u , sig_c ) end if sig_u = sig_u * a2ppm sig_c = sig_c * a2ppm ! --- Diamagnetic shielding (GIAO) --- !   a11part = cg_a11part(O=0) + 0.5 field_a R_nu,b  (verified vs libcint). !   e11_pre_{t,s} = 0.5*gdia0_{s,t} + corrpre_{t,s};  e11 = e11_pre - I*tr; !   sigma_dia = e11 * alpha&#94;2 * 1e6.  (a01gp gauge-correction: TODO.) o0 = 0.0d0 allocate ( gdia0 ( 3 , 3 , nat ), corrpre ( 3 , 3 , nat ), a01 ( 3 , 3 , nat ), & sig_dia ( 3 , 3 , nat ), sig_tot ( 3 , 3 , nat ), source = 0.0d0 ) call nmr_dia_shielding ( basis , dmp , o0 , coords , nat , gdia0 , logtol = tol ) call giao_a11part_corr ( basis , dmp , coords , nat , corrpre , logtol = tol ) call giao_a01gp_contract ( basis , dmp , coords , nat , a01 , logtol = tol ) do iat = 1 , nat trg0 = gdia0 ( 1 , 1 , iat ) + gdia0 ( 2 , 2 , iat ) + gdia0 ( 3 , 3 , iat ) trc = corrpre ( 1 , 1 , iat ) + corrpre ( 2 , 2 , iat ) + corrpre ( 3 , 3 , iat ) do t = 1 , 3 do s = 1 , 3 ! a11part (trace-corrected) + a01gp (raw, per the standard diamagnetic decomposition) sig_dia ( t , s , iat ) = ( SG * 0.5d0 * gdia0 ( s , t , iat ) + SC * corrpre ( t , s , iat ) & - merge ( SG * 0.5d0 * trg0 + SC * trc , 0.0d0 , t == s ) & + SA * a01 ( t , s , iat ) ) * a2ppm sig_tot ( t , s , iat ) = sig_dia ( t , s , iat ) + sig_c ( t , s , iat ) end do end do end do ! --- Store isotropic shielding (ppm) to a tagarray for JSON output --- !     rows: dia, para_uncoupled, para_coupled, total_uncoupled, total_coupled !     stored atom-major (flat): atom a occupies entries 5*(a-1)+1 .. 5*a. call infos % dat % alloc_or_die ( OQP_nmr_shielding , ( / 5 * nat / ), nmrout , description = OQP_nmr_shielding_comment ) do iat = 1 , nat nmrout ( 5 * ( iat - 1 ) + 1 ) = ( sig_dia ( 1 , 1 , iat ) + sig_dia ( 2 , 2 , iat ) + sig_dia ( 3 , 3 , iat )) / 3.0d0 nmrout ( 5 * ( iat - 1 ) + 2 ) = ( sig_u ( 1 , 1 , iat ) + sig_u ( 2 , 2 , iat ) + sig_u ( 3 , 3 , iat )) / 3.0d0 nmrout ( 5 * ( iat - 1 ) + 3 ) = ( sig_c ( 1 , 1 , iat ) + sig_c ( 2 , 2 , iat ) + sig_c ( 3 , 3 , iat )) / 3.0d0 nmrout ( 5 * ( iat - 1 ) + 4 ) = nmrout ( 5 * ( iat - 1 ) + 1 ) + nmrout ( 5 * ( iat - 1 ) + 2 ) nmrout ( 5 * ( iat - 1 ) + 5 ) = nmrout ( 5 * ( iat - 1 ) + 1 ) + nmrout ( 5 * ( iat - 1 ) + 3 ) end do ! --- Emit parseable records --- inquire ( unit = iw , opened = iw_open ) if (. not . iw_open ) open ( unit = iw , file = infos % log_filename , position = \"append\" ) write ( iw , '(/,A)' ) 'GIAO_SHIELDING_DEBUG_BEGIN native-giao shielding (ppm)' write ( iw , '(A,1X,I0)' ) 'GIAO_SHIELDING_DEBUG_NATOM' , nat write ( iw , '(A,1X,F10.6)' ) 'GIAO_SHIELDING_DEBUG_CX' , scale_exch do iat = 1 , nat do t = 1 , 3 do s = 1 , 3 write ( iw , '(A,1X,I0,1X,I0,1X,I0,1X,ES24.16)' ) 'GIAO_SHIELDING_DEBUG_PARA_UNC' , & iat , t , s , sig_u ( t , s , iat ) write ( iw , '(A,1X,I0,1X,I0,1X,I0,1X,ES24.16)' ) 'GIAO_SHIELDING_DEBUG_PARA_CPL' , & iat , t , s , sig_c ( t , s , iat ) write ( iw , '(A,1X,I0,1X,I0,1X,I0,1X,ES24.16)' ) 'GIAO_SHIELDING_DEBUG_DIA' , & iat , t , s , sig_dia ( t , s , iat ) write ( iw , '(A,1X,I0,1X,I0,1X,I0,1X,ES24.16)' ) 'GIAO_SHIELDING_DEBUG_TOTAL' , & iat , t , s , sig_tot ( t , s , iat ) end do end do write ( iw , '(A,1X,I0,4(1X,ES24.16))' ) 'GIAO_SHIELDING_DEBUG_ISO' , iat , & ( sig_u ( 1 , 1 , iat ) + sig_u ( 2 , 2 , iat ) + sig_u ( 3 , 3 , iat )) / 3.0d0 , & ( sig_c ( 1 , 1 , iat ) + sig_c ( 2 , 2 , iat ) + sig_c ( 3 , 3 , iat )) / 3.0d0 , & ( sig_dia ( 1 , 1 , iat ) + sig_dia ( 2 , 2 , iat ) + sig_dia ( 3 , 3 , iat )) / 3.0d0 , & ( sig_tot ( 1 , 1 , iat ) + sig_tot ( 2 , 2 , iat ) + sig_tot ( 3 , 3 , iat )) / 3.0d0 end do write ( iw , '(A)' ) 'GIAO_SHIELDING_DEBUG_END' ! --- Human-readable production table (GIAO isotropic shielding) --- write ( iw , '(2/)' ) write ( iw , '(4x,a)' ) '========================================' write ( iw , '(4x,a)' ) 'NMR nuclear magnetic shielding (GIAO)' write ( iw , '(4x,a)' ) '========================================' write ( iw , '(4x,a)' ) 'Gauge formulation: GIAO (London) atomic orbitals; gauge-origin independent.' if ( open_shell ) then write ( iw , '(4x,a)' ) 'Reference: open shell (UHF/ROHF); diamagnetic from total density, ' // & 'paramagnetic summed over spin channels.' end if write ( iw , '(/4x,a,f8.4,a)' ) 'Isotropic shielding (GIAO, ppm)   [exact-exchange c_x =' , & scale_exch , ']' write ( iw , '(4x,a)' ) '   Atom    Z   sigma_dia   para_uncoupled   para_coupled' // & '   total_uncoupled   total_coupled' do iat = 1 , nat write ( iw , '(4x,i6,f6.1,5f16.6)' ) iat , basis % atoms % zn ( iat ), & ( sig_dia ( 1 , 1 , iat ) + sig_dia ( 2 , 2 , iat ) + sig_dia ( 3 , 3 , iat )) / 3.0d0 , & ( sig_u ( 1 , 1 , iat ) + sig_u ( 2 , 2 , iat ) + sig_u ( 3 , 3 , iat )) / 3.0d0 , & ( sig_c ( 1 , 1 , iat ) + sig_c ( 2 , 2 , iat ) + sig_c ( 3 , 3 , iat )) / 3.0d0 , & ( sig_dia ( 1 , 1 , iat ) + sig_dia ( 2 , 2 , iat ) + sig_dia ( 3 , 3 , iat )) / 3.0d0 + & ( sig_u ( 1 , 1 , iat ) + sig_u ( 2 , 2 , iat ) + sig_u ( 3 , 3 , iat )) / 3.0d0 , & ( sig_tot ( 1 , 1 , iat ) + sig_tot ( 2 , 2 , iat ) + sig_tot ( 3 , 3 , iat )) / 3.0d0 end do close ( iw ) deallocate ( gdia0 , corrpre , a01 , sig_dia , sig_tot ) deallocate ( h10p , s10p , twoe , twoe2 , vj , vk , dm , dmp , h1ao , s1ao ) if ( allocated ( vxa )) deallocate ( vxa ) if ( allocated ( vxb )) deallocate ( vxb ) deallocate ( coords , zq , sig_u , sig_c ) if ( allocated ( vkb )) deallocate ( vkb ) if ( allocated ( h1ao_b )) deallocate ( h1ao_b ) if ( allocated ( dm_b )) deallocate ( dm_b ) end subroutine nmr_giao_shielding_debug !> Expand packed lower-triangular antisymmetric matrix to full form. subroutine expand_antisym ( packed , full , n ) real ( kind = dp ), intent ( in ) :: packed (:) real ( kind = dp ), intent ( out ) :: full (:,:) integer , intent ( in ) :: n integer :: p , q , idx full = 0.0d0 do p = 1 , n do q = 1 , p idx = q + p * ( p - 1 ) / 2 full ( p , q ) = packed ( idx ) full ( q , p ) = - packed ( idx ) end do end do end subroutine expand_antisym subroutine unpack_sym ( packed , full , n ) real ( kind = dp ), intent ( in ) :: packed (:) real ( kind = dp ), intent ( out ) :: full (:,:) integer , intent ( in ) :: n integer :: i , j , ij full = 0.0d0 do i = 1 , n do j = 1 , i ij = j + i * ( i - 1 ) / 2 full ( i , j ) = packed ( ij ) full ( j , i ) = packed ( ij ) end do end do end subroutine unpack_sym !> MO transform keeping occupied ket columns: m(p,i) = sum_mn C(m,p) a(m,n) C(n,i), !>  p = 1..nmo, i = 1..nocc. subroutine ao_to_mo_occ ( a_ao , c , m_mo , nbf , nmo , nocc ) real ( kind = dp ), intent ( in ) :: a_ao (:,:), c (:,:) real ( kind = dp ), intent ( out ) :: m_mo (:,:) integer , intent ( in ) :: nbf , nmo , nocc real ( kind = dp ), allocatable :: tmp (:,:) allocate ( tmp ( nbf , nocc )) tmp = matmul ( a_ao , c (:, 1 : nocc )) m_mo ( 1 : nmo , 1 : nocc ) = matmul ( transpose ( c (:, 1 : nmo )), tmp ) deallocate ( tmp ) end subroutine ao_to_mo_occ !> Uncoupled first-order equation (standard uncoupled first-order equation): !>   hs = h1 - s1*e_i ;  mo1[vir,i] = -hs[vir,i]/(e_a-e_i) ; !>   mo1[occ,i] = -0.5*s1[occ,i]. subroutine solve_mo1_uncoupled ( h1mo , s1mo , e , nocc , nmo , mo1 ) real ( kind = dp ), intent ( in ) :: h1mo (:,:,:), s1mo (:,:,:), e (:) integer , intent ( in ) :: nocc , nmo real ( kind = dp ), intent ( out ) :: mo1 (:,:,:) integer :: x , p , i real ( kind = dp ) :: hs mo1 = 0.0d0 do x = 1 , 3 do i = 1 , nocc do p = 1 , nmo hs = h1mo ( p , i , x ) - s1mo ( p , i , x ) * e ( i ) if ( p > nocc ) then mo1 ( p , i , x ) = - hs / ( e ( p ) - e ( i )) else mo1 ( p , i , x ) = - 0.5d0 * s1mo ( p , i , x ) end if end do end do end do end subroutine solve_mo1_uncoupled !> Coupled GIAO CPHF/CPKS: fixed-point of !>   mo1[vir,i] = -(hs[vir,i] + v1[vir,i])/(e_a-e_i),  mo1[occ,i] = -0.5 s1[occ,i], !>  with v1 the exact-exchange response (scaled by c_x) of the imaginary !>  antisymmetric first-order density built from the full mo1.  For c_x = 0 the !>  loop is skipped and the result equals the uncoupled solution. subroutine solve_mo1_coupled ( infos , basis , mo , h1mo , s1mo , e , nocc , nmo , & scale_exch , mo1 ) use int2_compute , only : int2_compute_t use tdhf_lib , only : int2_td_data_t , mntoia use types , only : information use basis_tools , only : basis_set use messages , only : show_message real ( kind = dp ), intent ( in ) :: mo (:,:), h1mo (:,:,:), s1mo (:,:,:), e (:) integer , intent ( in ) :: nocc , nmo real ( kind = dp ), intent ( in ) :: scale_exch real ( kind = dp ), intent ( out ) :: mo1 (:,:,:) type ( information ), target , intent ( inout ) :: infos type ( basis_set ), intent ( in ) :: basis integer , parameter :: maxit = 100 real ( kind = dp ), parameter :: tol = 1.0d-9 integer :: nbf , nvir , x , p , i , a , k , it real ( kind = dp ) :: diff , hs type ( int2_compute_t ) :: int2_driver type ( int2_td_data_t ), target :: kdat real ( kind = dp ), allocatable , target :: pa (:,:,:) real ( kind = dp ), allocatable :: gxv (:), mo1x (:,:), prev (:,:), gao (:,:) nbf = basis % nbf nvir = nmo - nocc ! Start from the uncoupled solution. call solve_mo1_uncoupled ( h1mo , s1mo , e , nocc , nmo , mo1 ) if ( abs ( scale_exch ) <= 1.0d-12 ) return allocate ( pa ( nbf , nbf , 1 ), gxv ( nocc * nvir ), mo1x ( nmo , nocc ), & prev ( nmo , nocc ), gao ( nbf , nbf ), source = 0.0d0 ) call int2_driver % init ( basis , infos ) ! NMR uses the native Rys ERI path only (the GIAO two-electron derivative ! and the reference data are Rys-based); never route through libint. int2_driver % rys_only = . true . call int2_driver % set_screening () kdat = int2_td_data_t ( d2 = pa , int_apb = . false ., int_amb = . true ., & tamm_dancoff = . false ., scale_exchange = scale_exch ) do x = 1 , 3 mo1x = mo1 (:,:, x ) do it = 1 , maxit prev = mo1x ! Imaginary antisymmetric AO first-order density from the full MO ! response (occ + vir rows); CGO-consistent normalization (no x2). call giao_pb_density ( mo , mo1x , pa (:,:, 1 ), nbf , nmo , nocc ) call int2_driver % run ( kdat ) gao = 0.5d0 * kdat % amb (:,:, 1 , 1 ) ! Exchange response projected to the occ-vir block (i fast): ! gxv(i+(a-1)*nocc) = (C&#94;T gao C)[i_occ, a_vir]. call mntoia ( gao , gxv , mo , mo , nocc , nocc ) do i = 1 , nocc do a = 1 , nvir p = nocc + a k = i + ( a - 1 ) * nocc hs = h1mo ( p , i , x ) - s1mo ( p , i , x ) * e ( i ) ! mntoia returns the [occ,vir] block gxv(i,a); the response element ! needed here is the [vir,occ] entry v1(a,i) = -gxv(i,a) (the ! exchange image is antisymmetric). mo1x ( p , i ) = - ( hs - gxv ( k )) / ( e ( p ) - e ( i )) end do do p = 1 , nocc mo1x ( p , i ) = - 0.5d0 * s1mo ( p , i , x ) end do end do diff = maxval ( abs ( mo1x - prev )) if ( diff < tol ) exit end do if ( diff >= tol ) then call show_message ( 'WARNING: GIAO coupled magnetic response (CPHF) did & &not converge within the iteration limit; shieldings may be inaccurate' ) end if mo1 (:,:, x ) = mo1x end do call int2_driver % clean () deallocate ( pa , gxv , mo1x , prev , gao ) end subroutine solve_mo1_coupled !> Imaginary antisymmetric AO first-order density from a full MO response vector !>  (CGO-consistent normalization, no double-occupancy factor): !>   D = C mo1 orbo&#94;T ;  pa = D - D&#94;T. subroutine giao_pb_density ( mo , mo1x , pa , nbf , nmo , nocc ) real ( kind = dp ), intent ( in ) :: mo (:,:), mo1x (:,:) real ( kind = dp ), intent ( out ) :: pa (:,:) integer , intent ( in ) :: nbf , nmo , nocc real ( kind = dp ), allocatable :: dleft (:,:) allocate ( dleft ( nbf , nbf )) dleft = matmul ( mo (:, 1 : nmo ), matmul ( mo1x , transpose ( mo (:, 1 : nocc )))) pa = dleft - transpose ( dleft ) deallocate ( dleft ) end subroutine giao_pb_density !> Paramagnetic shielding tensor for one nucleus (standard paramagnetic convention): !>   dm10(a,b,x) = 2 sum_{p,i} C(a,p) mo1(p,i,x) C(b,i) ; !>   sigma_para[x,y] = 2 sum_{a,b} dm10(a,b,x) * h01i(b,a,y). !> Paramagnetic shielding contribution from one spin channel: MO transform, !> CPHF (uncoupled + coupled), and PSO contraction, ACCUMULATED into sig_u/sig_c. !> occ_factor = 2 for RHF (closed shell), 1 for each UHF spin channel. subroutine giao_para_channel ( infos , basis , mo , e , nocc , nmo , nbf , nat , coords , & h1ao , s1ao , scale_exch , occ_factor , sig_u , sig_c ) use types , only : information use basis_tools , only : basis_set use int1 , only : pso_integrals type ( information ), target , intent ( inout ) :: infos type ( basis_set ), intent ( in ) :: basis real ( kind = dp ), intent ( in ) :: mo (:,:), e (:), coords (:,:) real ( kind = dp ), intent ( in ) :: h1ao (:,:,:), s1ao (:,:,:), scale_exch , occ_factor integer , intent ( in ) :: nocc , nmo , nbf , nat real ( kind = dp ), intent ( inout ) :: sig_u (:,:,:), sig_c (:,:,:) real ( kind = dp ), allocatable :: h1mo (:,:,:), s1mo (:,:,:), mo1u (:,:,:), mo1c (:,:,:) real ( kind = dp ), allocatable :: pso (:,:,:), st (:,:) integer :: c , iat allocate ( h1mo ( nmo , nocc , 3 ), s1mo ( nmo , nocc , 3 ), mo1u ( nmo , nocc , 3 ), mo1c ( nmo , nocc , 3 ), & pso ( nbf , nbf , 3 ), st ( 3 , 3 ), source = 0.0d0 ) do c = 1 , 3 call ao_to_mo_occ ( h1ao (:,:, c ), mo , h1mo (:,:, c ), nbf , nmo , nocc ) call ao_to_mo_occ ( s1ao (:,:, c ), mo , s1mo (:,:, c ), nbf , nmo , nocc ) end do call solve_mo1_uncoupled ( h1mo , s1mo , e , nocc , nmo , mo1u ) call solve_mo1_coupled ( infos , basis , mo , h1mo , s1mo , e , nocc , nmo , scale_exch , mo1c ) do iat = 1 , nat call pso_integrals ( basis , coords (:, iat ), pso ) call para_tensor ( mo1u , mo , pso , nbf , nmo , nocc , st , occ_factor ) sig_u (:,:, iat ) = sig_u (:,:, iat ) + st call para_tensor ( mo1c , mo , pso , nbf , nmo , nocc , st , occ_factor ) sig_c (:,:, iat ) = sig_c (:,:, iat ) + st end do deallocate ( h1mo , s1mo , mo1u , mo1c , pso , st ) end subroutine giao_para_channel !> Semicanonicalize ROHF orbitals for spin sigma: diagonalize the occ-occ and !> vir-vir blocks of C&#94;T F_sigma C, returning semicanonical orbitals (csc) and !> orbital energies (esc).  ROHF stores a single orbital set with effective-Fock !> eigenvalues; the UHF-like CPHF needs proper spin orbital energies (the !> ground-state spin Fock matrices F_a/F_b from OQP_FOCK_A/B). subroutine semicanon_orbitals ( fock_p , c0 , nbf , nmo , nocc , csc , esc ) use eigen , only : diag_symm_full real ( kind = dp ), intent ( in ) :: fock_p (:), c0 (:,:) integer , intent ( in ) :: nbf , nmo , nocc real ( kind = dp ), intent ( out ) :: csc (:,:), esc (:) real ( kind = dp ), allocatable :: fao (:,:), fmo (:,:), blk (:,:), eb (:) integer :: nvir , ierr nvir = nmo - nocc allocate ( fao ( nbf , nbf ), fmo ( nmo , nmo )) call unpack_sym ( fock_p , fao , nbf ) fmo = matmul ( transpose ( c0 (:, 1 : nmo )), matmul ( fao , c0 (:, 1 : nmo ))) csc = c0 (:, 1 : nmo ); esc = 0.0d0 if ( nocc > 0 ) then allocate ( blk ( nocc , nocc ), eb ( nocc )) blk = fmo ( 1 : nocc , 1 : nocc ) call diag_symm_full ( 1 , nocc , blk , nocc , eb , ierr ) csc (:, 1 : nocc ) = matmul ( c0 (:, 1 : nocc ), blk ) esc ( 1 : nocc ) = eb ( 1 : nocc ) deallocate ( blk , eb ) end if if ( nvir > 0 ) then allocate ( blk ( nvir , nvir ), eb ( nvir )) blk = fmo ( nocc + 1 : nmo , nocc + 1 : nmo ) call diag_symm_full ( 1 , nvir , blk , nvir , eb , ierr ) csc (:, nocc + 1 : nmo ) = matmul ( c0 (:, nocc + 1 : nmo ), blk ) esc ( nocc + 1 : nmo ) = eb ( 1 : nvir ) deallocate ( blk , eb ) end if deallocate ( fao , fmo ) end subroutine semicanon_orbitals subroutine para_tensor ( mo1 , mo , h01i , nbf , nmo , nocc , sig , occ_factor ) real ( kind = dp ), intent ( in ) :: mo1 (:,:,:), mo (:,:), h01i (:,:,:) integer , intent ( in ) :: nbf , nmo , nocc real ( kind = dp ), intent ( out ) :: sig (:,:) real ( kind = dp ), intent ( in ), optional :: occ_factor integer :: x , y , a , b real ( kind = dp ), allocatable :: dm10 (:,:,:) real ( kind = dp ) :: acc , ofac ofac = 2.0d0 ! RHF closed-shell occupation; UHF per spin = 1 if ( present ( occ_factor )) ofac = occ_factor allocate ( dm10 ( nbf , nbf , 3 )) do x = 1 , 3 dm10 (:,:, x ) = ofac * matmul ( mo (:, 1 : nmo ), matmul ( mo1 (:,:, x ), transpose ( mo (:, 1 : nocc )))) end do do x = 1 , 3 do y = 1 , 3 acc = 0.0d0 do b = 1 , nbf do a = 1 , nbf acc = acc + dm10 ( a , b , x ) * h01i ( b , a , y ) end do end do ! OpenQP pso_integrals stores the negative of libcint int1e_prinvxp ! (h01i); the leading 2 is the +c.c. factor of the the standard paramagnetic routine. sig ( x , y ) = - 2.0d0 * acc end do end do deallocate ( dm10 ) end subroutine para_tensor end module nmr_giao_shielding_mod","tags":"","url":"sourcefile/nmr_giao_shielding.f90.html"},{"title":"elements.F90 – OpenQP Fortran API","text":"Source Code module elements use strings , only : to_upper use iso_fortran_env , only : real64 use physical_constants , only : ANGSTROM_TO_BOHR implicit none private public get_element_id integer , parameter , public :: MAX_ELEMENT_Z = 110 !   Short elements name, Camel Case character ( len = 2 ), parameter , public :: ELEMENTS_ATOMNAME ( MAX_ELEMENT_Z ) = [ & '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' , 'Rf' , 'Db' , 'Sg' , & 'Bh' , 'Hs' , 'Mt' , 'Ds' ] !   Short elements name, UPPER CASE character ( len = 4 ), parameter , public :: ELEMENTS_SHORT_NAME ( MAX_ELEMENT_Z ) = [ & \"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  \" , & \"RF  \" , \"DB  \" , \"SG  \" , \"BH  \" , \"HS  \" , \"MT  \" , \"DS  \" ] !   Long elements name, UPPER CASE character ( len = 16 ), parameter , public :: ELEMENTS_LONG_NAME ( MAX_ELEMENT_Z ) = [ & \"HYDROGEN        \" , \"HELIUM          \" , \"LITHIUM         \" , \"BERYLLIUM       \" , & \"BORON           \" , \"CARBON          \" , \"NITROGEN        \" , \"OXYGEN          \" , & \"FLUORINE        \" , \"NEON            \" , \"SODIUM          \" , \"MAGNESIUM       \" , & \"ALUMINIUM       \" , \"SILICON         \" , \"PHOSPHORUS      \" , \"SULFUR          \" , & \"CHLORINE        \" , \"ARGON           \" , \"POTASSIUM       \" , \"CALCIUM         \" , & \"SCANDIUM        \" , \"TITANIUM        \" , \"VANADIUM        \" , \"CHROMIUM        \" , & \"MANGANESE       \" , \"IRON            \" , \"COBALT          \" , \"NICKEL          \" , & \"COPPER          \" , \"ZINC            \" , \"GALLIUM         \" , \"GERMANIUM       \" , & \"ARSENIC         \" , \"SELENIUM        \" , \"BROMINE         \" , \"KRYPTON         \" , & \"RUBIDIUM        \" , \"STRONTIUM       \" , \"YTTRIUM         \" , \"ZIRCONIUM       \" , & \"NIOBIUM         \" , \"MOLYBDENUM      \" , \"TECHNETIUM      \" , \"RUTHENIUM       \" , & \"RHODIUM         \" , \"PALLADIUM       \" , \"SILVER          \" , \"CADMIUM         \" , & \"INDIUM          \" , \"TIN             \" , \"ANTIMONY        \" , \"TELLURIUM       \" , & \"IODINE          \" , \"XENON           \" , \"CAESIUM         \" , \"BARIUM          \" , & \"LANTHANUM       \" , \"CERIUM          \" , \"PRASEODYMIUM    \" , \"NEODYMIUM       \" , & \"PROMETHIUM      \" , \"SAMARIUM        \" , \"EUROPIUM        \" , \"GADOLINIUM      \" , & \"TERBIUM         \" , \"DYSPROSIUM      \" , \"HOLMIUM         \" , \"ERBIUM          \" , & \"THULIUM         \" , \"YTTERBIUM       \" , \"LUTETIUM        \" , \"HAFNIUM         \" , & \"TANTALUM        \" , \"TUNGSTEN        \" , \"RHENIUM         \" , \"OSMIUM          \" , & \"IRIDIUM         \" , \"PLATINUM        \" , \"GOLD            \" , \"MERCURY         \" , & \"THALLIUM        \" , \"LEAD            \" , \"BISMUTH         \" , \"POLONIUM        \" , & \"ASTATINE        \" , \"RADON           \" , \"FRANCIUM        \" , \"RADIUM          \" , & \"ACTINIUM        \" , \"THORIUM         \" , \"PROTACTINIUM    \" , \"URANIUM         \" , & \"NEPTUNIUM       \" , \"PLUTONIUM       \" , \"AMERICIUM       \" , \"CURIUM          \" , & \"BERKELIUM       \" , \"CALIFORNIUM     \" , \"EINSTEINIUM     \" , \"FERMIUM         \" , & \"MENDELEVIUM     \" , \"NOBELIUM        \" , \"LAWRENCIUM      \" , \"RUTHERFORDIUM   \" , & \"DUBNIUM         \" , \"SEABORGIUM      \" , \"BOHRIUM         \" , \"HASSIUM         \" , & \"MEITNERIUM      \" , \"DARMSTADTIUM    \" ] ! M. Mantina et. al., J. Phys. Chem. A, Vol. 113, No. 19, 2009: H-Ca, Ga-Sr, In-Ba, Tl-Ra ! S. Batsanov, Inorganic Materials, Vol. 37, No. 9, 2001, pp. 871–885: Sc-Zn, Y-Cd, Hf-Hg ! S.-Z. Hu et. al., Z. Kristallogr.224(2009) 375–383: La-Lu, Ac-Am ! Cm-Ds : 2.4 real ( real64 ), parameter , public :: ELEMENTS_VDW_RADII ( MAX_ELEMENT_Z ) = ANGSTROM_TO_BOHR * [ & 1.10 , 1.40 , 1.81 , 1.53 , 1.92 , 1.70 , 1.55 , 1.52 , 1.47 , 1.54 , 2.27 , & 1.73 , 1.84 , 2.10 , 1.80 , 1.80 , 1.75 , 1.88 , 2.75 , 2.31 , 2.30 , 2.15 , & 2.05 , 2.05 , 2.05 , 2.05 , 2.00 , 2.00 , 2.00 , 2.10 , 1.87 , 2.11 , 1.85 , & 1.90 , 1.83 , 2.02 , 3.03 , 2.49 , 2.40 , 2.30 , 2.15 , 2.10 , 2.05 , 2.05 , & 2.00 , 2.05 , 2.10 , 2.20 , 1.93 , 2.17 , 2.06 , 2.06 , 1.98 , 2.16 , 3.43 , & 2.68 , 2.43 , 2.42 , 2.40 , 2.39 , 2.38 , 2.36 , 2.35 , 2.34 , 2.33 , 2.31 , & 2.30 , 2.29 , 2.27 , 2.26 , 2.24 , 2.25 , 2.20 , 2.10 , 2.05 , 2.00 , 2.00 , & 2.05 , 2.10 , 2.05 , 1.96 , 2.02 , 2.07 , 1.97 , 2.02 , 2.20 , 3.48 , 2.83 , & 2.47 , 2.45 , 2.43 , 2.41 , 2.39 , 2.37 , 2.35 , & 2.4 , 2.4 , 2.4 , 2.4 , 2.4 , 2.4 , 2.4 , 2.4 , 2.4 , 2.4 , 2.4 , 2.4 , 2.4 , 2.4 , 2.4 & ] contains integer function get_element_id ( element_name ) result ( id ) character ( len =* ), intent ( in ) :: element_name logical :: found character ( len = 16 ) :: name_upcase found = . false . name_upcase (:) = to_upper ( element_name ) do id = 1 , MAX_ELEMENT_Z if ( name_upcase == ELEMENTS_LONG_NAME ( id ) & . or . name_upcase == ELEMENTS_SHORT_NAME ( id )) then found = . true . exit end if end do if (. not . found ) id = - 1 end function end module","tags":"","url":"sourcefile/elements.f90.html"},{"title":"basis_library.F90 – OpenQP Fortran API","text":"Source Code module basis_library use , intrinsic :: iso_fortran_env , only : real64 use elements , only : MAX_ELEMENT_Z , get_element_id use strings , only : to_upper use constants , only : ANGULAR_LABEL , NUM_CART_BF use io_constants , only : IW implicit none private type , public :: atom_basis_t integer :: nshells = 0 integer :: nbfs = 0 integer :: nprims = 0 integer , allocatable :: ang (:) integer , allocatable :: ncontract (:) real ( real64 ), allocatable :: ex (:) real ( real64 ), allocatable :: cc (:) contains procedure , private :: reserve => atom_basis_reserve end type type , public :: basis_library_t type ( atom_basis_t ) :: atoms ( MAX_ELEMENT_Z ) contains procedure :: from_file => read_basis_library procedure :: calc_req_storage procedure :: echo => basis_library_echo end type contains !------------------------------------------------------------------------------- subroutine calc_req_storage ( this , z , nshell , ngauss , nbasis ) class ( basis_library_t ), target , intent ( in ) :: this integer , intent ( in ) :: z (:) integer , intent ( out ) :: nshell , ngauss , nbasis nshell = sum ( this % atoms ( z )% nshells ) nbasis = sum ( this % atoms ( z )% nbfs ) ngauss = sum ( this % atoms ( z )% nprims ) end subroutine !------------------------------------------------------------------------------- subroutine read_basis_library ( this , fname ) class ( basis_library_t ), target , intent ( inout ) :: this character ( * ), intent ( in ) :: fname integer :: iunit integer :: stat character ( len = 1024 ) :: msg open ( newunit = iunit , file = trim ( adjustl ( fname )), status = 'old' , action = 'read' , & iostat = stat , iomsg = msg ) if ( stat /= 0 ) then write ( IW , * ) 'Can''t open basis library file ''' , trim ( adjustl ( fname )), '''' write ( IW , * ) 'The error is:' write ( IW , * ) trim ( msg ) flush ( IW ) call abort end if call read_basis_library_file ( this , iunit ) close ( iunit ) end subroutine !------------------------------------------------------------------------------- subroutine read_basis_library_file ( this , iunit ) class ( basis_library_t ), target , intent ( inout ) :: this integer , intent ( in ) :: iunit type ( atom_basis_t ), pointer :: atom integer :: z integer :: ig integer :: ln integer :: state character ( 1 ) :: label integer :: ng character ( len = 1024 ) :: error integer :: iost integer :: id character ( 1024 ) :: line integer :: l integer , parameter :: & READ_ATOM = 0 , & READ_SHELL = 1 , & READ_GAUSS = 2 state = READ_ATOM ig = 0 ln = 0 do read ( unit = iunit , fmt = '(A)' , end = 100 ) line ln = ln + 1 !          Check if line is commented out if ( skip_string ( line )) cycle select case ( state ) case ( READ_ATOM ) z = get_element_id ( trim ( adjustl ( line ))) if ( z > 0 ) then state = READ_SHELL atom => this % atoms ( z ) end if case ( READ_SHELL ) if ( len_trim ( line ) == 0 ) then state = READ_ATOM ig = 0 cycle end if read ( line , * , err = 200 , iostat = iost , iomsg = error ) label , ng atom % nshells = atom % nshells + 1 call atom % reserve ( nshell = atom % nshells , ngauss = ig + ng ) l = scan ( ANGULAR_LABEL , label ) atom % ang ( atom % nshells ) = l - 1 atom % nbfs = atom % nbfs + NUM_CART_BF ( l - 1 ) atom % ncontract ( atom % nshells ) = ng atom % nprims = atom % nprims + ng if ( atom % ang ( atom % nshells ) < 0 ) then write ( IW , * ) \"Unknown basis function type: '\" , label , \"'\" goto 200 end if state = READ_GAUSS case ( READ_GAUSS ) ig = ig + 1 read ( line , fmt =* , err = 200 , iostat = iost , iomsg = error ) id , atom % ex ( ig ), atom % cc ( ig ) ng = ng - 1 if ( ng == 0 ) state = READ_SHELL end select end do 100 continue return 200 continue write ( IW , '(\"Error while reading basis set file at line \",I0,\":\")' ) ln write ( IW , '(A)' ) trim ( line ) call abort end subroutine !------------------------------------------------------------------------------- subroutine basis_library_echo ( this ) use elements , only : MAX_ELEMENT_Z , ELEMENTS_LONG_NAME class ( basis_library_t ), intent ( in ) :: this integer :: ia , sh , ig , g do ia = 1 , MAX_ELEMENT_Z associate ( at => this % atoms ( ia )) if ( at % nshells == 0 ) cycle write ( * , * ) trim ( ELEMENTS_LONG_NAME ( ia )), at % nshells , at % nprims , at % nbfs ig = 0 do sh = 1 , at % nshells write ( * , '(A1,i10)' ) ANGULAR_LABEL ( at % ang ( sh ): at % ang ( sh )), at % ncontract ( sh ) do g = 1 , at % ncontract ( sh ) ig = ig + 1 write ( * , '(i4,2ES25.15)' ) g , at % ex ( ig ), at % cc ( ig ) end do end do end associate end do end subroutine !------------------------------------------------------------------------------- subroutine atom_basis_reserve ( this , nshell , ngauss ) class ( atom_basis_t ), intent ( inout ) :: this integer , optional , intent ( in ) :: nshell , ngauss if ( present ( nshell )) then call reserve_array_int ( this % ang , nshell ) call reserve_array_int ( this % ncontract , nshell ) end if if ( present ( ngauss )) then call reserve_array_real ( this % ex , ngauss ) call reserve_array_real ( this % cc , ngauss ) end if end subroutine subroutine reserve_array_int ( a , n ) integer , intent ( in ) :: n integer , allocatable , intent ( inout ) :: a (:) integer , allocatable :: tmp (:) integer :: lda lda = 0 if ( allocated ( a )) lda = ubound ( a , 1 ) if ( n <= lda ) return allocate ( tmp ( max ( n , lda + 16 ))) if ( allocated ( a )) tmp (:) = a (:) call move_alloc ( from = tmp , to = a ) end subroutine subroutine reserve_array_real ( a , n ) integer , intent ( in ) :: n real ( real64 ), allocatable , intent ( inout ) :: a (:) real ( real64 ), allocatable :: tmp (:) integer :: lda lda = 0 if ( allocated ( a )) lda = ubound ( a , 1 ) if ( n <= lda ) return allocate ( tmp ( max ( n , lda + 16 ))) if ( allocated ( a )) tmp (: lda ) = a (:) call move_alloc ( from = tmp , to = a ) end subroutine logical function skip_string ( str ) result ( res ) character ( * ) :: str character ( * ), parameter :: TO_SKIP = '!#&$/\\' integer :: pos res = .false. pos = verify(str, ' ' ) if ( pos == 0 ) return res = scan ( TO_SKIP , str ( pos : pos )) /= 0 end function end module","tags":"","url":"sourcefile/basis_library.f90.html"},{"title":"int_rys.F90 – OpenQP Fortran API","text":"Source Code module int2e_rys use precision , only : dp use basis_tools , only : basis_set use constants , only : HARMONIC_ACTIVE , bas_mxang , bas_mxcart , num_cart_bf , cart_x , cart_y , cart_z , shells_pnrm2 use int2_pure_generated , only : int2_shell_projection_t , int2_init_shell_projection integer , parameter :: MAXCONTR = 120 type int2_rys_data_t integer :: id ( 4 ) integer :: at ( 4 ) integer :: am ( 4 ) integer :: nbf ( 4 ) integer :: nbf_cart ( 4 ) integer :: nbf_direct ( 4 ) integer :: flips ( 4 ) integer :: nroots logical :: iandj , kandl , same logical :: direct_pure = . false . ! projection tables cached per (l, pure); rebuilding them per quartet ! was a measurable overhead in the direct-pure hot loop. Allocated on ! first pure quartet rather than held as a static rank-2 component: ! a default-initialized array-of-derived component here aborted at ! runtime (\"integer overflow when calculating the amount of memory to ! allocate\") with gfortran-14/-fdefault-integer-8 on linux-x86-64 in ! the Docker CI smoke test, and the allocatable form also costs ! nothing for Cartesian-only runs. integer :: pure_flags ( 4 ) = 0 type ( int2_shell_projection_t ), allocatable :: proj_cache (:,:) real ( kind = dp ), allocatable :: gijkl (:) real ( kind = dp ), allocatable :: gnkl (:) real ( kind = dp ), allocatable :: gnm (:) real ( kind = dp ), allocatable :: dij (:,:) real ( kind = dp ), allocatable :: dkl (:,:) real ( kind = dp ), allocatable :: b00 (:) real ( kind = dp ), allocatable :: b01 (:) real ( kind = dp ), allocatable :: b10 (:) real ( kind = dp ), allocatable :: c00 (:) real ( kind = dp ), allocatable :: d00 (:) real ( kind = dp ), allocatable :: abv (:,:) real ( kind = dp ), allocatable :: PQ (:,:) real ( kind = dp ), allocatable :: PB (:,:) real ( kind = dp ), allocatable :: QD (:,:) real ( kind = dp ), allocatable :: rw (:,:) integer :: ijklxyz ( 4 , BAS_MXCART , 4 ) real ( kind = dp ) :: quartet_cutoff contains procedure :: init => gdat_init procedure :: clean => gdat_clean procedure :: set_ids => gdat_set_ids end type private public :: int2_rys_data_t public :: int2_rys_compute public :: int2_rys_compute_ordered_am public :: int2_rys_reduce_pure public :: rys_print_eri contains subroutine gdat_init ( gdat , maxang , & cutoffs , stat ) use int2_pairs , only : int2_pair_storage , int2_cutoffs_t implicit none class ( int2_rys_data_t ), intent ( inout ) :: gdat type ( int2_cutoffs_t ) :: cutoffs integer , intent ( in ) :: maxang integer , intent ( out ) :: stat integer :: mxbra , mxcart , mxrys gdat % quartet_cutoff = cutoffs % pair_cutoff_squared mxrys = ( 4 * maxang + 2 ) / 2 mxcart = maxang + 1 mxbra = 2 * mxcart - 1 allocate (& gdat % gijkl ( mxcart ** 4 * MAXCONTR * 3 ), & gdat % gnkl ( mxcart ** 2 * mxbra * MAXCONTR * 3 ), & gdat % gnm ( mxbra ** 2 * MAXCONTR * 3 ), & gdat % dij ( 3 , mxcart ** 2 * MAXCONTR ), & gdat % dkl ( 3 , mxbra * MAXCONTR ), & gdat % b00 ( mxrys * MAXCONTR ), & gdat % b01 ( mxrys * MAXCONTR ), & gdat % b10 ( mxrys * MAXCONTR ), & gdat % c00 ( mxrys * MAXCONTR * 3 ), & gdat % d00 ( mxrys * MAXCONTR * 3 ), & gdat % abv ( 6 , MAXCONTR ), & gdat % PQ ( 3 , MAXCONTR ), & gdat % PB ( 3 , MAXCONTR ), & gdat % QD ( 3 , MAXCONTR ), & gdat % rw ( mxrys * 2 , MAXCONTR ), & stat = stat ) end subroutine gdat_init subroutine gdat_clean ( gdat ) implicit none class ( int2_rys_data_t ), intent ( inout ) :: gdat if ( allocated ( gdat % gijkl )) deallocate ( gdat % gijkl ) if ( allocated ( gdat % gnkl )) deallocate ( gdat % gnkl ) if ( allocated ( gdat % gnm )) deallocate ( gdat % gnm ) if ( allocated ( gdat % dij )) deallocate ( gdat % dij ) if ( allocated ( gdat % dkl )) deallocate ( gdat % dkl ) if ( allocated ( gdat % b00 )) deallocate ( gdat % b00 ) if ( allocated ( gdat % b01 )) deallocate ( gdat % b01 ) if ( allocated ( gdat % b10 )) deallocate ( gdat % b10 ) if ( allocated ( gdat % c00 )) deallocate ( gdat % c00 ) if ( allocated ( gdat % d00 )) deallocate ( gdat % d00 ) if ( allocated ( gdat % abv )) deallocate ( gdat % abv ) if ( allocated ( gdat % PQ )) deallocate ( gdat % PQ ) if ( allocated ( gdat % PB )) deallocate ( gdat % PB ) if ( allocated ( gdat % QD )) deallocate ( gdat % QD ) if ( allocated ( gdat % rw )) deallocate ( gdat % rw ) end subroutine gdat_clean subroutine gdat_set_ids ( gdat , basis , id ) implicit none class ( int2_rys_data_t ), intent ( inout ) :: gdat type ( basis_set ), intent ( in ) :: basis integer , intent ( in ) :: id ( 4 ) integer :: am ( 4 ) ! Permute shells so L_i < L_j, L_k < L_l, L_i < L_j gdat % flips = [ 1 , 2 , 3 , 4 ] am = basis % am ( id ) if ( am ( 1 ) > am ( 2 )) then gdat % flips ( 1 : 2 ) = [ 2 , 1 ] am ( 1 : 2 ) = am ([ 2 , 1 ]) end if if ( am ( 3 ) > am ( 4 )) then gdat % flips ( 3 : 4 ) = [ 4 , 3 ] am ( 3 : 4 ) = am ([ 4 , 3 ]) end if if ( am ( 1 ) + am ( 2 ) > am ( 3 ) + am ( 4 )) then gdat % flips = gdat % flips ([ 3 , 4 , 1 , 2 ]) am = am ([ 3 , 4 , 1 , 2 ]) end if gdat % id = id ( gdat % flips ) gdat % am = am gdat % at = basis % origin ( gdat % id ) end subroutine gdat_set_ids subroutine int2_rys_compute ( ints , gdat , ppairs , zero_shq , mu2 , basis , direct_pure ) use int2_pairs , only : int2_pair_storage implicit none type ( int2_rys_data_t ), intent ( inout ) :: gdat type ( int2_pair_storage ), intent ( in ) :: ppairs real ( kind = dp ), intent ( inout ) :: ints ( * ) real ( kind = dp ), intent ( in ), optional :: mu2 type ( basis_set ), intent ( in ), optional :: basis logical , intent ( in ), optional :: direct_pure logical , intent ( out ) :: zero_shq integer :: ijg , klg , maxgg , mmax , ng integer :: nmax real ( kind = dp ) :: aa , ab , aandb1 , bb , da , db , test real ( kind = dp ) :: pfac , rho real ( kind = dp ) :: p ( 3 ), q ( 3 ) logical :: first logical :: use_direct_pure integer :: id1 , id2 , ppid_p , ppid_q , npp_p , npp_q real ( kind = dp ) :: mu2_1 ! Range-separation parameter for Erfc-attenuated integrals mu2_1 = 0 if ( present ( mu2 )) mu2_1 = 1.0d0 / mu2 !   Prepare shell block call set_shells ( gdat ) use_direct_pure = . false . if ( present ( direct_pure )) use_direct_pure = direct_pure if ( use_direct_pure . and . present ( basis )) call prepare_direct_pure ( gdat , basis ) id1 = maxval ( gdat % id ( 1 : 2 )) id2 = minval ( gdat % id ( 1 : 2 )) npp_p = ppairs % ppid ( 1 , id1 * ( id1 - 1 ) / 2 + id2 ) ppid_p = ppairs % ppid ( 2 , id1 * ( id1 - 1 ) / 2 + id2 ) id1 = maxval ( gdat % id ( 3 : 4 )) id2 = minval ( gdat % id ( 3 : 4 )) npp_q = ppairs % ppid ( 1 , id1 * ( id1 - 1 ) / 2 + id2 ) ppid_q = ppairs % ppid ( 2 , id1 * ( id1 - 1 ) / 2 + id2 ) zero_shq = npp_p * npp_q == 0 if ( zero_shq ) return nmax = gdat % am ( 1 ) + gdat % am ( 2 ) + 1 mmax = gdat % am ( 3 ) + gdat % am ( 4 ) + 1 maxgg = MAXCONTR / gdat % nroots !   Pair of k,l primitives first = . true . zero_shq = . true . ng = 0 do klg = 1 , npp_q db = ppairs % k ( ppid_q - 1 + klg ) * ppairs % ginv ( ppid_q - 1 + klg ) bb = ppairs % g ( ppid_q - 1 + klg ) q = ppairs % P (:, ppid_q - 1 + klg ) !     Pair of i,j primitives do ijg = 1 , npp_p da = ppairs % k ( ppid_p - 1 + ijg ) * ppairs % ginv ( ppid_p - 1 + ijg ) aa = ppairs % g ( ppid_p - 1 + ijg ) p = ppairs % P (:, ppid_p - 1 + ijg ) ! 2nd term is used for Erfc-attenuated integrals ! It is zero for regular integrals ab = ( aa + bb ) + aa * bb * mu2_1 pfac = da * db test = pfac * pfac if ( test < gdat % quartet_cutoff * ab ) cycle ng = ng + 1 aandb1 = 1.0_dp / ab rho = aa * bb * aandb1 gdat % abv ( 1 , ng ) = ppairs % ginv ( ppid_p - 1 + ijg ) gdat % abv ( 2 , ng ) = ppairs % ginv ( ppid_q - 1 + klg ) gdat % abv ( 3 , ng ) = rho gdat % abv ( 4 , ng ) = pfac * sqrt ( aandb1 ) gdat % abv ( 5 , ng ) = aandb1 gdat % abv ( 6 , ng ) = rho * sum (( p - q ) ** 2 ) gdat % PQ (:, ng ) = p - q if ( nmax > 1 ) gdat % pb (:, ng ) = ppairs % PB (:, ppid_p - 1 + ijg ) if ( mmax > 1 ) gdat % qd (:, ng ) = ppairs % PB (:, ppid_q - 1 + klg ) gdat % dij (:, ng ) = ppairs % PA (:, ppid_p - 1 + ijg ) - ppairs % PB (:, ppid_p - 1 + ijg ) gdat % dkl (:, ng ) = ppairs % PA (:, ppid_q - 1 + klg ) - ppairs % PB (:, ppid_q - 1 + klg ) if ( ng == maxgg ) then if ( ng /= 0 ) then if ( first ) call clear_ints ( gdat , ints ) first = . false . call compute ( gdat , ng , nmax , mmax , ints ) ng = 0 zero_shq = . false . end if end if end do end do if ( ng /= 0 ) then if ( first ) call clear_ints ( gdat , ints ) first = . false . call compute ( gdat , ng , nmax , mmax , ints ) ng = 0 zero_shq = . false . end if if ( gdat % direct_pure ) gdat % nbf = gdat % nbf_direct end subroutine int2_rys_compute subroutine int2_rys_compute_ordered_am ( ints , gdat , ppairs , ids , am , zero_shq ) use int2_pairs , only : int2_pair_storage implicit none real ( kind = dp ), intent ( inout ) :: ints ( * ) type ( int2_rys_data_t ), intent ( inout ) :: gdat type ( int2_pair_storage ), intent ( in ) :: ppairs integer , intent ( in ) :: ids ( 4 ), am ( 4 ) logical , intent ( out ) :: zero_shq gdat % id = ids gdat % am = am gdat % flips = [ 1 , 2 , 3 , 4 ] call int2_rys_compute ( ints , gdat , ppairs , zero_shq ) end subroutine int2_rys_compute_ordered_am subroutine int2_rys_reduce_pure ( basis , gdat , ints , nbf_out ) use cart2sph , only : cart2sph_eri implicit none type ( basis_set ), intent ( in ) :: basis type ( int2_rys_data_t ), intent ( in ) :: gdat real ( kind = dp ), intent ( inout ) :: ints (:) integer , intent ( out ) :: nbf_out ( 4 ) integer :: am_s ( 4 ), pure_s ( 4 ), nbf_s ( 4 ), nbf_out_s ( 4 ) nbf_out = gdat % nbf if (. not . HARMONIC_ACTIVE ) return am_s = gdat % am ([ 4 , 3 , 2 , 1 ]) pure_s = basis % harmonic ( gdat % id ([ 4 , 3 , 2 , 1 ])) if (. not . any ( pure_s == 1 . and . am_s >= 2 )) return nbf_s = gdat % nbf ([ 4 , 3 , 2 , 1 ]) call cart2sph_eri ( ints , am_s , pure_s , nbf_s , nbf_out_s ) nbf_out = nbf_out_s ([ 4 , 3 , 2 , 1 ]) end subroutine int2_rys_reduce_pure subroutine prepare_direct_pure ( gdat , basis ) implicit none type ( int2_rys_data_t ), intent ( inout ) :: gdat type ( basis_set ), intent ( in ) :: basis integer :: pure_s ( 4 ) integer :: s gdat % direct_pure = . false . if (. not . HARMONIC_ACTIVE ) return pure_s = basis % harmonic ( gdat % id ) if (. not . any ( pure_s == 1 . and . gdat % am >= 2 )) return gdat % direct_pure = . true . if (. not . allocated ( gdat % proj_cache )) then block integer :: l allocate ( gdat % proj_cache ( 0 : bas_mxang , 0 : 1 )) do l = 0 , bas_mxang call int2_init_shell_projection ( l , 0 , gdat % proj_cache ( l , 0 )) call int2_init_shell_projection ( l , 1 , gdat % proj_cache ( l , 1 )) end do end block end if do s = 1 , 4 gdat % pure_flags ( s ) = merge ( 1 , 0 , pure_s ( s ) == 1 ) gdat % nbf_direct ( s ) = gdat % proj_cache ( gdat % am ( s ), gdat % pure_flags ( s ))% nout end do end subroutine prepare_direct_pure subroutine compute ( gdat , ng , nmax , mmax , ints ) type ( int2_rys_data_t ), intent ( inout ) :: gdat integer :: nmax , mmax , ng real ( kind = dp ), intent ( inout ) :: ints ( * ) !   Compute roots and weights for quadrature call compute_rys_rw ( gdat , gdat % rw , ng ) !   Compute coefficients for recursion formulae call compute_coefficients ( gdat % b00 , gdat % b01 , gdat % b10 , & gdat % c00 , gdat % d00 , gdat % gnm , & gdat % abv , gdat % pq , gdat % pb , gdat % qd , gdat % rw , nmax , mmax , ng , gdat % nroots ) !   Compute x, y, z integrals (2 centers, 2-d ) call compute_xyz_p0q0 ( gdat % gnm , ng * gdat % nroots , nmax , mmax , & gdat % b00 , gdat % b01 , gdat % b10 , gdat % c00 , gdat % d00 ) !   Compute x, y, z integrals (4 centers, 2-d) call compute_xyz_ijkl ( gdat % gijkl , gdat % gnkl , gdat % gnm , & ng , gdat % nroots , nmax , mmax , & gdat % am ( 1 ) + 1 , gdat % am ( 2 ) + 1 , gdat % am ( 3 ) + 1 , gdat % am ( 4 ) + 1 , & gdat % dij , gdat % dkl ) !   compute integrals if ( gdat % direct_pure ) then call compute_ints_direct_pure ( gdat , ng * gdat % nroots , gdat % ijklxyz , gdat % gijkl , ints ) else call compute_ints ( gdat , ng * gdat % nroots , gdat % ijklxyz , gdat % gijkl , ints ) end if end subroutine subroutine set_shells ( gdat ) implicit none type ( int2_rys_data_t ) :: gdat integer :: ish , jsh , ksh , lsh ish = gdat % id ( 1 ) jsh = gdat % id ( 2 ) ksh = gdat % id ( 3 ) lsh = gdat % id ( 4 ) gdat % iandj = ish == jsh gdat % kandl = ksh == lsh gdat % same = ish == ksh . and . jsh == lsh gdat % direct_pure = . false . gdat % nbf = num_cart_bf ( gdat % am ) gdat % nbf_cart = gdat % nbf gdat % nbf_direct = gdat % nbf !   Set number of quadrature points gdat % nroots = ( sum ( gdat % am ) + 2 ) / 2 !   Prepare indices for pairs of (i,j) functions call prepare_xyz_ids ( gdat ) end subroutine set_shells subroutine prepare_xyz_ids ( gdat ) implicit none class ( int2_rys_data_t ), intent ( inout ) :: gdat integer :: i , nj , nk , nl , njkl , nkl nj = gdat % am ( 2 ) + 1 nk = gdat % am ( 3 ) + 1 nl = gdat % am ( 4 ) + 1 njkl = nl * nk * nj do i = 1 , gdat % nbf ( 1 ) gdat % ijklxyz ( 1 , i , 1 ) = cart_x ( i , gdat % am ( 1 )) * njkl gdat % ijklxyz ( 2 , i , 1 ) = cart_y ( i , gdat % am ( 1 )) * njkl gdat % ijklxyz ( 3 , i , 1 ) = cart_z ( i , gdat % am ( 1 )) * njkl end do nkl = nl * nk do i = 1 , gdat % nbf ( 2 ) gdat % ijklxyz ( 1 , i , 2 ) = cart_x ( i , gdat % am ( 2 )) * nkl gdat % ijklxyz ( 2 , i , 2 ) = cart_y ( i , gdat % am ( 2 )) * nkl gdat % ijklxyz ( 3 , i , 2 ) = cart_z ( i , gdat % am ( 2 )) * nkl end do !   Prepare indices for pairs of (k,l) functions do i = 1 , gdat % nbf ( 3 ) gdat % ijklxyz ( 1 , i , 3 ) = cart_x ( i , gdat % am ( 3 )) * nl gdat % ijklxyz ( 2 , i , 3 ) = cart_y ( i , gdat % am ( 3 )) * nl gdat % ijklxyz ( 3 , i , 3 ) = cart_z ( i , gdat % am ( 3 )) * nl end do do i = 1 , gdat % nbf ( 4 ) gdat % ijklxyz ( 1 , i , 4 ) = cart_x ( i , gdat % am ( 4 )) + 1 gdat % ijklxyz ( 2 , i , 4 ) = cart_y ( i , gdat % am ( 4 )) + 1 gdat % ijklxyz ( 3 , i , 4 ) = cart_z ( i , gdat % am ( 4 )) + 1 end do end subroutine subroutine compute_rys_rw ( gdat , rwv , numg ) use rys , only : rys_root_t implicit none class ( int2_rys_data_t ), intent ( inout ) :: gdat real ( kind = dp ), intent ( out ) :: rwv ( 2 , numg , * ) integer , intent ( in ) :: numg type ( rys_root_t ) :: root integer :: ng root % nroots = gdat % nroots do ng = 1 , numg root % x = gdat % abv ( 6 , ng ) call root % evaluate rwv ( 1 , ng , 1 : gdat % nroots ) = root % u ( 1 : gdat % nroots ) rwv ( 2 , ng , 1 : gdat % nroots ) = root % w ( 1 : gdat % nroots ) end do end subroutine compute_rys_rw subroutine compute_coefficients ( b00 , b01 , b10 , c00 , d00 , gnm , & abv , pq , pb , qd , rwv , nmax , mmax , numg , nroots ) implicit none real ( kind = dp ) :: b00 ( numg , * ), b01 ( numg , * ), b10 ( numg , * ) !numg*nroots real ( kind = dp ) :: c00 ( numg , nroots , * ) !numg*nroots*3 real ( kind = dp ) :: d00 ( numg , nroots , * ) !numg*nroots*3 real ( kind = dp ) :: gnm ( numg , nroots , * ) !numg*nroots*3 real ( kind = dp ) :: abv ( 6 , * ), pq ( 3 , * ), pb ( 3 , * ), qd ( 3 , * ) real ( kind = dp ) :: rwv ( 2 , numg , * ) !rwv(2,numg,nroots) integer :: mmax , nmax integer :: numg , nroots integer :: nr , ng real ( kind = dp ) :: a1 , b1 , ab1 real ( kind = dp ) :: pfac , rho , t2 , t2ar , t2br , uu , ww do nr = 1 , nroots do ng = 1 , numg a1 = abv ( 1 , ng ) b1 = abv ( 2 , ng ) rho = abv ( 3 , ng ) pfac = abv ( 4 , ng ) ab1 = abv ( 5 , ng ) uu = rwv ( 1 , ng , nr ) ww = rwv ( 2 , ng , nr ) !       G(0,0) gnm ( ng , nr , 1 ) = ww * pfac gnm ( ng , nr , 2 ) = 1.0_dp gnm ( ng , nr , 3 ) = 1.0_dp t2 = uu / ( uu + 1 ) t2ar = t2 * rho * a1 t2br = t2 * rho * b1 b00 ( ng , nr ) = 0.5_dp * ab1 * t2 b01 ( ng , nr ) = 0.5_dp * b1 * ( 1.0_dp - t2br ) b10 ( ng , nr ) = 0.5_dp * a1 * ( 1.0_dp - t2ar ) if ( mmax > 1 ) then d00 ( ng , nr , 1 ) = qd ( 1 , ng ) + t2br * pq ( 1 , ng ) d00 ( ng , nr , 2 ) = qd ( 2 , ng ) + t2br * pq ( 2 , ng ) d00 ( ng , nr , 3 ) = qd ( 3 , ng ) + t2br * pq ( 3 , ng ) end if if ( nmax > 1 ) then c00 ( ng , nr , 1 ) = pb ( 1 , ng ) - t2ar * pq ( 1 , ng ) c00 ( ng , nr , 2 ) = pb ( 2 , ng ) - t2ar * pq ( 2 , ng ) c00 ( ng , nr , 3 ) = pb ( 3 , ng ) - t2ar * pq ( 3 , ng ) end if end do end do end subroutine compute_coefficients subroutine compute_xyz_p0q0 ( gnm , ng , nmax , mmax , b00 , b01 , b10 , c00 , d00 ) implicit none real ( kind = dp ) :: gnm ( ng , 3 , nmax , * ) real ( kind = dp ) :: c00 ( ng , * ), d00 ( ng , * ) real ( kind = dp ) :: b00 ( * ), b01 ( * ), b10 ( * ) integer :: ng , nmax , mmax integer :: m , n , xyz if ( max ( nmax , mmax ) == 1 ) return if ( nmax > 1 ) then !     g(1,0) = c00 * g(0,0) gnm (: ng , 1 : 3 , 2 , 1 ) = c00 (: ng , 1 : 3 ) * gnm (: ng , 1 : 3 , 1 , 1 ) end if if ( mmax > 1 ) then !     g(0,1) = d00 * g(0,0) gnm (: ng , 1 : 3 , 1 , 2 ) = d00 (: ng , 1 : 3 ) * gnm (: ng , 1 : 3 , 1 , 1 ) if ( nmax > 1 ) then !       g(1,1) = b00 * g(0,0) + d00 * g(1,0) do xyz = 1 , 3 gnm (: ng , xyz , 2 , 2 ) = b00 (: ng ) * gnm (: ng , xyz , 1 , 1 ) & + d00 (: ng , xyz ) * gnm (: ng , xyz , 2 , 1 ) end do end if end if if ( nmax > 2 ) then !     g(n+1,0) = n * b10 * g(n-1,0) + c00 * g(n,0) do n = 2 , nmax - 1 do xyz = 1 , 3 gnm (: ng , xyz , n + 1 , 1 ) = ( n - 1 ) * b10 (: ng ) * gnm (: ng , xyz , n - 1 , 1 ) & + c00 (: ng , xyz ) * gnm (: ng , xyz , n , 1 ) end do end do if ( mmax > 1 ) then !       g(n,1) = n * b00 * g(n-1,0) + d00 * g(n,0) do n = 2 , nmax - 1 do xyz = 1 , 3 gnm (: ng , xyz , n + 1 , 2 ) = n * b00 (: ng ) * gnm (: ng , xyz , n , 1 ) & + d00 (: ng , xyz ) * gnm (: ng , xyz , n + 1 , 1 ) end do end do end if end if if ( mmax < 3 ) return !   g(0,m+1) = m * b01 * g(0,m-1) + d00 * g(o,m) do m = 2 , mmax - 1 do xyz = 1 , 3 gnm (: ng , xyz , 1 , m + 1 ) = ( m - 1 ) * b01 (: ng ) * gnm (: ng , xyz , 1 , m - 1 ) & + d00 (: ng , xyz ) * gnm (: ng , xyz , 1 , m ) end do end do if ( nmax < 2 ) return !   g(1,m) = m * b00 * g(0,m-1) + c00 * g(0,m) do m = 2 , mmax - 1 do xyz = 1 , 3 gnm (: ng , xyz , 2 , m + 1 ) = m * b00 (: ng ) * gnm (: ng , xyz , 1 , m ) & + c00 (: ng , xyz ) * gnm (: ng , xyz , 1 , m + 1 ) end do end do if ( nmax < 3 ) return !   g(n+1,m) = n * b10 * g(n-1,m  ) !            +     c00 * g(n  ,m  ) !            + m * b00 * g(n  ,m-1) do m = 2 , mmax - 1 do n = 2 , nmax - 1 do xyz = 1 , 3 gnm (:, xyz , n + 1 , m + 1 ) = ( n - 1 ) * b10 (: ng ) * gnm (: ng , xyz , n - 1 , m + 1 ) & + c00 (: ng , xyz ) * gnm (: ng , xyz , n , m + 1 ) & + m * b00 (: ng ) * gnm (: ng , xyz , n , m ) end do end do end do end subroutine compute_xyz_p0q0 subroutine compute_xyz_ijkl ( ijkl , gnkl , gnm , ng , nr , & nmax , mmax , nimax , njmax , nkmax , nlmax , dij , dkl ) implicit none real ( kind = dp ) :: ijkl ( ng , nr , 3 , nlmax , nkmax , njmax , * ) real ( kind = dp ) :: gnkl ( ng , nr , 3 , nlmax , nkmax , * ) real ( kind = dp ) :: gnm ( ng , nr , 3 , nmax , * ) ! gnm(ng,nmax,mmax) real ( kind = dp ) :: dij ( 3 , * ) ! dij(ng) real ( kind = dp ) :: dkl ( 3 , * ) ! dkl(ng) integer :: ng , nr , nmax , mmax , nimax , njmax , nkmax , nlmax integer :: ni , nk , nl , ig , m1 , n1 , xyz !   g(n,k,l) do nk = 1 , nkmax do nl = 1 , nlmax gnkl (:,:,:, nl , nk ,: nmax ) = gnm (:,:,:,:, nl ) end do if ( nk == nkmax ) exit m1 = mmax - nk do xyz = 1 , 3 do ig = 1 , ng gnm ( ig ,:, xyz ,:, 1 : m1 ) = dkl ( xyz , ig ) * gnm ( ig ,:, xyz ,:, 1 : m1 ) & + gnm ( ig ,:, xyz ,:, 2 : m1 + 1 ) end do end do end do !   g(i,j,k,l) do ni = 1 , nimax ijkl (:,:,:,:,:, 1 : njmax , ni ) = gnkl (:,:,:,:,:, 1 : njmax ) if ( ni == nimax ) exit n1 = nmax - ni do xyz = 1 , 3 do ig = 1 , ng gnkl ( ig ,:, xyz ,:,:, 1 : n1 ) = dij ( xyz , ig ) * gnkl ( ig ,:, xyz ,:,:, 1 : n1 ) & + gnkl ( ig ,:, xyz ,:,:, 2 : n1 + 1 ) end do end do end do end subroutine compute_xyz_ijkl subroutine clear_ints ( gdat , ints ) implicit none type ( int2_rys_data_t ) :: gdat real ( kind = dp ) :: ints ( * ) if ( gdat % direct_pure ) then ints ( 1 : product ( gdat % nbf_direct )) = 0 else ints ( 1 : product ( gdat % nbf )) = 0 end if end subroutine clear_ints subroutine compute_ints ( gdat , ngnr , ijklxyz , g0 , ints ) implicit none type ( int2_rys_data_t ) :: gdat integer :: ngnr integer :: ijklxyz (:,:,:) real ( kind = dp ) :: g0 ( ngnr , 3 , * ) real ( kind = dp ), target :: ints ( * ) integer :: i , j , k , l integer :: nx , ny , nz real ( kind = dp ), pointer :: p (:,:,:,:) p ( 1 : gdat % nbf ( 4 ), 1 : gdat % nbf ( 3 ), 1 : gdat % nbf ( 2 ), 1 : gdat % nbf ( 1 )) => ints ( 1 : product ( gdat % nbf )) do i = 1 , gdat % nbf ( 1 ) do j = 1 , gdat % nbf ( 2 ) do k = 1 , gdat % nbf ( 3 ) do l = 1 , gdat % nbf ( 4 ) nx = ijklxyz ( 1 , i , 1 ) + ijklxyz ( 1 , j , 2 ) + ijklxyz ( 1 , k , 3 ) + ijklxyz ( 1 , l , 4 ) ny = ijklxyz ( 2 , i , 1 ) + ijklxyz ( 2 , j , 2 ) + ijklxyz ( 2 , k , 3 ) + ijklxyz ( 2 , l , 4 ) nz = ijklxyz ( 3 , i , 1 ) + ijklxyz ( 3 , j , 2 ) + ijklxyz ( 3 , k , 3 ) + ijklxyz ( 3 , l , 4 ) associate ( x => g0 (:, 1 , nx ) & , y => g0 (:, 2 , ny ) & , z => g0 (:, 3 , nz ) & ) p ( l , k , j , i ) = p ( l , k , j , i ) + sum ( x * y * z ) end associate end do end do end do end do end subroutine compute_ints subroutine compute_ints_direct_pure ( gdat , ngnr , ijklxyz , g0 , ints ) implicit none type ( int2_rys_data_t ) :: gdat integer :: ngnr integer :: ijklxyz (:,:,:) real ( kind = dp ) :: g0 ( ngnr , 3 , * ) real ( kind = dp ), target :: ints ( * ) integer :: i , j , k , l integer :: nx , ny , nz integer :: ti , tj , tk , tl integer :: oi , oj , ok , ol real ( kind = dp ) :: val , vi , vij , vijk real ( kind = dp ), pointer :: p (:,:,:,:) p ( 1 : gdat % nbf_direct ( 4 ), 1 : gdat % nbf_direct ( 3 ), 1 : gdat % nbf_direct ( 2 ), 1 : gdat % nbf_direct ( 1 )) & => ints ( 1 : product ( gdat % nbf_direct )) associate ( pr1 => gdat % proj_cache ( gdat % am ( 1 ), gdat % pure_flags ( 1 )) & , pr2 => gdat % proj_cache ( gdat % am ( 2 ), gdat % pure_flags ( 2 )) & , pr3 => gdat % proj_cache ( gdat % am ( 3 ), gdat % pure_flags ( 3 )) & , pr4 => gdat % proj_cache ( gdat % am ( 4 ), gdat % pure_flags ( 4 )) & ) do i = 1 , gdat % nbf_cart ( 1 ) do j = 1 , gdat % nbf_cart ( 2 ) do k = 1 , gdat % nbf_cart ( 3 ) do l = 1 , gdat % nbf_cart ( 4 ) nx = ijklxyz ( 1 , i , 1 ) + ijklxyz ( 1 , j , 2 ) + ijklxyz ( 1 , k , 3 ) + ijklxyz ( 1 , l , 4 ) ny = ijklxyz ( 2 , i , 1 ) + ijklxyz ( 2 , j , 2 ) + ijklxyz ( 2 , k , 3 ) + ijklxyz ( 2 , l , 4 ) nz = ijklxyz ( 3 , i , 1 ) + ijklxyz ( 3 , j , 2 ) + ijklxyz ( 3 , k , 3 ) + ijklxyz ( 3 , l , 4 ) associate ( x => g0 (:, 1 , nx ) & , y => g0 (:, 2 , ny ) & , z => g0 (:, 3 , nz ) & ) val = sum ( x * y * z ) & * shells_pnrm2 ( i , gdat % am ( 1 )) & * shells_pnrm2 ( j , gdat % am ( 2 )) & * shells_pnrm2 ( k , gdat % am ( 3 )) & * shells_pnrm2 ( l , gdat % am ( 4 )) end associate if ( val == 0.0_dp ) cycle do ti = 1 , pr1 % nterm ( i ) oi = pr1 % out_idx ( ti , i ) vi = val * pr1 % coeff ( ti , i ) do tj = 1 , pr2 % nterm ( j ) oj = pr2 % out_idx ( tj , j ) vij = vi * pr2 % coeff ( tj , j ) do tk = 1 , pr3 % nterm ( k ) ok = pr3 % out_idx ( tk , k ) vijk = vij * pr3 % coeff ( tk , k ) do tl = 1 , pr4 % nterm ( l ) ol = pr4 % out_idx ( tl , l ) p ( ol , ok , oj , oi ) = p ( ol , ok , oj , oi ) + vijk * pr4 % coeff ( tl , l ) end do end do end do end do end do end do end do end do end associate end subroutine compute_ints_direct_pure subroutine rys_print_eri ( gdat , ints ) use constants , only : shells_pnrm2 implicit none type ( int2_rys_data_t ), intent ( in ) :: gdat real ( kind = dp ), intent ( in ) :: ints (:,:,:,:) integer :: n ( 4 ), n0 ( 4 ), na , nb , nc , nd integer :: am ( 4 ), am0 ( 4 ) integer :: ids ( 4 ), inv ( 4 ) real ( kind = dp ), pointer :: pnorma (:), pnormb (:), pnormc (:), pnormd (:) am = gdat % am n = ( am + 1 ) * ( am + 2 ) / 2 inv ( gdat % flips ) = [ 1 , 2 , 3 , 4 ] am0 = am ( inv ) n0 = ( am0 + 1 ) * ( am0 + 2 ) / 2 pnorma => shells_pnrm2 (:, am0 ( 1 )) pnormb => shells_pnrm2 (:, am0 ( 2 )) pnormc => shells_pnrm2 (:, am0 ( 3 )) pnormd => shells_pnrm2 (:, am0 ( 4 )) do na = 1 , n0 ( 1 ) do nb = 1 , n0 ( 2 ) do nc = 1 , n0 ( 3 ) do nd = 1 , n0 ( 4 ) ids = [ na , nb , nc , nd ] ids = ids ( gdat % flips ) write ( * , \"(a6, 2i3, a, 2i3, a, es30.15)\" ) & \"elem (\" , na , nb , \" |\" , nc , nd , \") = \" , & ints ( ids ( 4 ), ids ( 3 ), ids ( 2 ), ids ( 1 )) * & pnorma ( na ) * pnormb ( nb ) * pnormc ( nc ) * pnormd ( nd ) end do end do end do end do end subroutine end module int2e_rys","tags":"","url":"sourcefile/int_rys.f90.html"},{"title":"minres.F90 – OpenQP Fortran API","text":"Source Code ! Preconditioned MINRES for symmetric (possibly indefinite) A with an SPD ! preconditioner M.  Paige & Saunders (1975) Lanczos + Givens formulation, ! same module/API shape as pcg_mod so it can slot into the z-vector selection. ! ! Unlike CG/PCG, MINRES does NOT require A to be positive-definite: it minimizes ! the residual over the Krylov space and stays stable on indefinite systems ! (e.g. near singlet/triplet instabilities) at CG-like 3-term-recurrence cost. module minres_mod use precision , only : dp use iso_c_binding , only : c_ptr , c_loc , c_null_ptr use , intrinsic :: ieee_arithmetic , only : ieee_is_finite implicit none private public MINRES_CONVERGED , MINRES_OK , MINRES_NOT_INITIALIZED public MINRES_BAD_ARGUMENT , MINRES_BREAKDOWN public minres_matvec , minres_t , minres_optimize integer , parameter :: MINRES_CONVERGED = - 1 integer , parameter :: MINRES_OK = 0 integer , parameter :: MINRES_NOT_INITIALIZED = 1 integer , parameter :: MINRES_BAD_ARGUMENT = 2 integer , parameter :: MINRES_BREAKDOWN = 3 real ( kind = dp ), parameter :: MINRES_DENOMINATOR_FLOOR = 1.0d-24 interface subroutine minres_matvec ( y , x , dat ) import real ( kind = dp ) :: x (:) real ( kind = dp ) :: y (:) type ( c_ptr ) :: dat end subroutine end interface !> @brief MINRES solver state for A x = b (A symmetric, M SPD). type :: minres_t logical :: initialized = . false . integer ( kind = 8 ) :: errcode = 0 ! Krylov / Lanczos work vectors real ( kind = dp ), allocatable :: b (:), x (:) real ( kind = dp ), allocatable :: r1 (:), r2 (:), y (:), v (:), av (:) real ( kind = dp ), allocatable :: w (:), w1 (:), w2 (:) ! Lanczos / Givens scalars real ( kind = dp ) :: beta1 = 0.0_dp , beta = 0.0_dp , oldb = 0.0_dp real ( kind = dp ) :: dbar = 0.0_dp , epsln = 0.0_dp , phibar = 0.0_dp real ( kind = dp ) :: cs = - 1.0_dp , sn = 0.0_dp real ( kind = dp ) :: error = huge ( 1.0_dp ), tol = 0.0_dp integer :: iter = 0 procedure ( minres_matvec ), nopass , pointer :: precond => null () procedure ( minres_matvec ), nopass , pointer :: update => null () type ( c_ptr ) :: dat = c_null_ptr contains procedure :: init => minres_init procedure :: clean => minres_clean procedure :: step => minres_step end type contains !################################################################# logical function safe_denominator ( value ) real ( kind = dp ), intent ( in ) :: value safe_denominator = ieee_is_finite ( value ) . and . abs ( value ) >= MINRES_DENOMINATOR_FLOOR end function safe_denominator !################################################################# subroutine minres_init ( this , b , update , precond , dat , x0 , tol ) class ( minres_t ), intent ( inout ) :: this real ( kind = dp ), intent ( in ) :: b (:) procedure ( minres_matvec ) :: update , precond real ( kind = dp ), optional , intent ( in ) :: x0 (:) real ( kind = dp ), optional , intent ( in ) :: tol type ( * ), target :: dat integer :: n if ( size ( b ) <= 0 ) then this % errcode = MINRES_BAD_ARGUMENT return end if if ( present ( x0 )) then if ( size ( x0 ) /= size ( b )) then this % errcode = MINRES_BAD_ARGUMENT return end if end if if (. not . all ( ieee_is_finite ( b ))) then this % errcode = MINRES_BREAKDOWN return end if n = size ( b ) allocate ( this % b ( n ), this % x ( n ), this % r1 ( n ), this % r2 ( n ), this % y ( n ), & this % v ( n ), this % av ( n ), this % w ( n ), this % w1 ( n ), this % w2 ( n ), & source = 0.0_dp ) this % precond => precond this % update => update this % b = b if ( present ( x0 )) this % x = x0 if ( present ( tol )) this % tol = tol this % dat = c_loc ( dat ) ! r1 = b - A x call this % update ( this % av , this % x , this % dat ) if (. not . all ( ieee_is_finite ( this % av ))) then this % errcode = MINRES_BREAKDOWN return end if this % r1 = this % b - this % av this % r2 = this % r1 ! y = M&#94;-1 r1 ; beta1 = sqrt(r1 . y)  (>0 since M SPD) call this % precond ( this % y , this % r1 , this % dat ) if (. not . all ( ieee_is_finite ( this % y ))) then this % errcode = MINRES_BREAKDOWN return end if this % beta1 = dot_product ( this % r1 , this % y ) if (. not . ieee_is_finite ( this % beta1 ) . or . this % beta1 < 0.0_dp ) then this % errcode = MINRES_BREAKDOWN return end if this % beta1 = sqrt ( this % beta1 ) this % beta = this % beta1 this % oldb = 0.0_dp this % dbar = 0.0_dp this % epsln = 0.0_dp this % phibar = this % beta1 this % cs = - 1.0_dp this % sn = 0.0_dp this % iter = 0 this % w = 0.0_dp this % w1 = 0.0_dp this % w2 = 0.0_dp this % error = this % beta1 this % initialized = . true . if ( this % beta1 <= this % tol ) this % errcode = MINRES_CONVERGED end subroutine !################################################################# subroutine minres_clean ( this ) class ( minres_t ), intent ( inout ) :: this if ( allocated ( this % b )) deallocate ( this % b ) if ( allocated ( this % x )) deallocate ( this % x ) if ( allocated ( this % r1 )) deallocate ( this % r1 ) if ( allocated ( this % r2 )) deallocate ( this % r2 ) if ( allocated ( this % y )) deallocate ( this % y ) if ( allocated ( this % v )) deallocate ( this % v ) if ( allocated ( this % av )) deallocate ( this % av ) if ( allocated ( this % w )) deallocate ( this % w ) if ( allocated ( this % w1 )) deallocate ( this % w1 ) if ( allocated ( this % w2 )) deallocate ( this % w2 ) nullify ( this % precond ); nullify ( this % update ) this % dat = c_null_ptr this % initialized = . false . this % errcode = 0 this % error = huge ( 1.0_dp ) this % tol = 0.0_dp this % iter = 0 end subroutine !################################################################# subroutine minres_step ( this ) class ( minres_t ), intent ( inout ) :: this real ( kind = dp ) :: s , alpha , gamma , delta , gbar , oldeps , phi , denom if (. not . this % initialized ) then this % errcode = MINRES_NOT_INITIALIZED return end if associate ( x => this % x , r1 => this % r1 , r2 => this % r2 , y => this % y , & v => this % v , av => this % av , w => this % w , w1 => this % w1 , w2 => this % w2 ) this % iter = this % iter + 1 ! --- Lanczos step: generate next vector ------------------------------ if (. not . safe_denominator ( this % beta )) then this % errcode = MINRES_BREAKDOWN return end if s = 1.0_dp / this % beta v = s * y call this % update ( av , v , this % dat ) ! av = A v y = av if ( this % iter >= 2 ) y = y - ( this % beta / this % oldb ) * r1 alpha = dot_product ( v , y ) y = y - ( alpha / this % beta ) * r2 r1 = r2 r2 = y call this % precond ( y , r2 , this % dat ) ! y = M&#94;-1 r2 this % oldb = this % beta this % beta = dot_product ( r2 , y ) if (. not . ieee_is_finite ( this % beta ) . or . this % beta < 0.0_dp ) then this % errcode = MINRES_BREAKDOWN return end if this % beta = sqrt ( this % beta ) ! --- apply previous Givens rotation ---------------------------------- oldeps = this % epsln delta = this % cs * this % dbar + this % sn * alpha gbar = this % sn * this % dbar - this % cs * alpha this % epsln = this % sn * this % beta this % dbar = - this % cs * this % beta ! --- compute and apply new Givens rotation --------------------------- gamma = sqrt ( gbar * gbar + this % beta * this % beta ) if (. not . safe_denominator ( gamma )) then this % errcode = MINRES_BREAKDOWN return end if this % cs = gbar / gamma this % sn = this % beta / gamma phi = this % cs * this % phibar this % phibar = this % sn * this % phibar ! --- update solution ------------------------------------------------- denom = 1.0_dp / gamma w1 = w2 w2 = w w = ( v - oldeps * w1 - delta * w2 ) * denom x = x + phi * w this % error = abs ( this % phibar ) if (. not . ieee_is_finite ( this % error )) then this % errcode = MINRES_BREAKDOWN return end if if ( this % error <= this % tol ) then if (. not . all ( ieee_is_finite ( x ))) then this % errcode = MINRES_BREAKDOWN return end if this % errcode = MINRES_CONVERGED end if end associate end subroutine !################################################################# subroutine minres_optimize ( b , update , precond , dat , mxit , x0 , tol , err , iters ) real ( kind = dp ), intent ( inout ) :: b (:) procedure ( minres_matvec ) :: update , precond type ( * ), intent ( in ) :: dat integer , intent ( in ) :: mxit real ( kind = dp ), optional , intent ( in ) :: x0 (:) real ( kind = dp ), intent ( in ) :: tol real ( kind = dp ), optional , intent ( out ) :: err integer , optional , intent ( out ) :: iters type ( minres_t ) :: m integer :: it if ( present ( iters )) iters = 0 call m % init ( b = b , update = update , precond = precond , dat = dat , x0 = x0 , tol = tol ) select case ( m % errcode ) case ( MINRES_OK ) do it = 1 , mxit if ( present ( iters )) iters = it call m % step () if ( m % errcode /= MINRES_OK ) exit end do case ( MINRES_CONVERGED ) ! initial guess already solves the system end select if ( m % errcode == MINRES_CONVERGED . or . m % errcode == MINRES_OK ) b = m % x if ( present ( err )) err = m % error call m % clean () end subroutine end module minres_mod","tags":"","url":"sourcefile/minres.f90.html"},{"title":"dft_xclib.F90 – OpenQP Fortran API","text":"Source Code module mod_dft_xclib use precision , only : fp use functionals , only : functional_t implicit none private integer , public , parameter :: XCLIB_LIBXC = 0 ! External LIBXC library integer , parameter :: NDENS_XC = 18 + 10 ! see tddfun, up to 2nd derivatives nxdim(2)=18, ncdim(2)=35 ! E_XC and E_CORR are separate ! two additional arrays are needed for EX0 and EC0 integer , parameter :: NDENS_TD = 18 + 18 + 35 + 2 ! LibXC, same, but E_XC and E_CORR are summed up integer , parameter :: NDENS_LXC = 18 + 35 real ( kind = fp ), parameter :: & ZERO = 0.0D+00 , TWO = 2.0D+00 , HALF = 0.5D+00 ! indices of xc arrays type , public :: xc_pack_t integer :: & ra = 1 , rb = 2 , & ga = 1 , gc = 2 , gb = 3 , & ta = 1 , tb = 2 , & rara = 1 , rarb = 2 , rbrb = 3 , & raga = 1 , ragc = 2 , ragb = 3 , rbga = 4 , rbgc = 5 , rbgb = 6 , & rata = 1 , ratb = 2 , rbta = 3 , rbtb = 4 , & gaga = 1 , gagc = 2 , gagb = 3 , gcgc = 4 , gbgc = 5 , gbgb = 6 , & gata = 1 , gatb = 2 , gcta = 3 , gctb = 4 , gbta = 5 , gbtb = 6 , & tata = 1 , tatb = 2 , tbtb = 3 , & rarara = 1 , rararb = 2 , rarbrb = 3 , rbrbrb = 4 , & gagaga = 1 , gagagc = 2 , gagagb = 3 , gagcgc = 4 , gagbgc = 5 , & gagbgb = 6 , gcgcgc = 7 , gbgcgc = 8 , gbgbgc = 9 , gbgbgb = 10 , & raraga = 1 , raragc = 2 , raragb = 3 , rarbga = 4 , rarbgc = 5 , & rarbgb = 6 , rbrbga = 7 , rbrbgc = 8 , rbrbgb = 9 , & ragaga = 1 , ragagc = 2 , ragagb = 3 , ragcgc = 4 , ragbgc = 5 , ragbgb = 6 , & rbgaga = 7 , rbgagc = 8 , rbgagb = 9 , rbgcgc = 10 , rbgbgc = 11 , rbgbgb = 12 , & tatata = 1 , tatatb = 2 , tatbtb = 3 , tbtbtb = 4 , & rarata = 1 , raratb = 2 , rarbta = 3 , rarbtb = 4 , rbrbta = 5 , rbrbtb = 6 , & ratata = 1 , ratatb = 2 , ratbtb = 3 , rbtata = 4 , rbtatb = 5 , rbtbtb = 6 , & ragata = 1 , ragatb = 2 , ragcta = 3 , ragctb = 4 , ragbta = 5 , ragbtb = 6 , & rbgata = 7 , rbgatb = 8 , rbgcta = 9 , rbgctb = 10 , rbgbta = 11 , rbgbtb = 12 , & gagata = 1 , gagatb = 2 , gagcta = 3 , gagctb = 4 , gagbta = 5 , gagbtb = 6 , & gcgcta = 7 , gcgctb = 8 , gbgcta = 9 , gbgctb = 10 , gbgbta = 11 , gbgbtb = 12 , & gatata = 1 , gatatb = 2 , gatbtb = 3 , gctata = 4 , gctatb = 5 , gctbtb = 6 , & gbtata = 7 , gbtatb = 8 , gbtbtb = 9 end type type , abstract , public :: xc_lib_t logical :: reqSigma = . FALSE . !< needs density gradients logical :: reqTau = . FALSE . !< needs k.e. density gradients logical :: reqLapl = . FALSE . !< needs laplacian of the density logical :: reqBeta = . FALSE . !< UHF flag integer :: maxPts = 0 integer :: numPts = 0 integer :: nDer = 0 !        integer :: funTyp    = 0   !< 0 - LDA, 1 - GGA, 2 - MGGA real ( kind = fp ) :: E_xc = 0.0 real ( kind = fp ) :: E_exch = 0.0 real ( kind = fp ) :: E_corr = 0.0 logical :: providesEXC = . FALSE . !< Can get E_xc logical :: providesEX = . FALSE . !< Can get E_exch logical :: providesEC = . FALSE . !< Can get E_corr !       Library id integer :: xclibID = XCLIB_LIBXC type ( xc_pack_t ) :: ids real ( kind = fp ), allocatable :: memory_ (:) real ( kind = fp ), contiguous , pointer :: & !           Input data rho (:,:) => NULL () & !< density , drho (:,:) => NULL () & !< gradient density , sig (:,:) => NULL () & !< contracted density gradient , tau (:,:) => NULL () & !< K.E. density , lapl (:,:) => NULL () & !< Laplacian of the density !           Output data , exc (:) => NULL () & !< E(XC) , d1dr (:,:) => NULL () & !< E(XC) LDA values , d1ds (:,:) => NULL () & !< E(XC) GGA values , d1dt (:,:) => NULL () & !< E(XC) MGGA values , d1dl (:,:) => NULL () & !< E(XC) Laplacian , d2r2 (:,:) => NULL () & !< second derivatives of functional vs rho&#94;2 , d2s2 (:,:) => NULL () & !< second derivatives of functional vs sigma&#94;2 , d2t2 (:,:) => NULL () & !< second derivatives of functional vs tau&#94;2 , d2rs (:,:) => NULL () & !< second derivatives of functional vs rho and sigma , d2rt (:,:) => NULL () & !< second derivatives of functional vs rho and tau , d2st (:,:) => NULL () & !< second derivatives of functional vs sigma and tau , d2rl (:,:) => NULL () & !< second derivatives of functional vs rho and lapl , d2sl (:,:) => NULL () & !< second derivatives of functional vs sigma and lapl , d2tl (:,:) => NULL () & !< second derivatives of functional vs tau and lapl , d2l2 (:,:) => NULL () & !< second derivatives of functional vs lapl&#94;2 , d3r3 (:,:) => NULL () & !< third derivatives of functional vs rho&#94;3 , d3r2s (:,:) => NULL () & !< third derivatives of functional vs rho&#94;2 and sigma , d3rs2 (:,:) => NULL () & !< third derivatives of functional vs rho and sigma&#94;2 , d3s3 (:,:) => NULL () & !< third derivatives of functional vs sigma&#94;3 , d3t3 (:,:) => NULL () & !< third derivatives of functional vs tau&#94;3 , d3r2t (:,:) => NULL () & !< third derivatives of functional vs rho&#94;2 and tau , d3s2t (:,:) => NULL () & !< third derivatives of functional vs sigma&#94;2 and tau , d3rt2 (:,:) => NULL () & !< third derivatives of functional vs rho and tau&#94;2 , d3st2 (:,:) => NULL () & !< third derivatives of functional vs sigma and tau&#94;2 , d3rst (:,:) => NULL () & !< third derivatives of functional vs rho, sigma and tau , d3r2l (:,:) => NULL () & !< , d3rl2 (:,:) => NULL () & !< , d3rsl (:,:) => NULL () & !< , d3rtl (:,:) => NULL () & !< , d3s2l (:,:) => NULL () & !< , d3sl2 (:,:) => NULL () & !< , d3stl (:,:) => NULL () & !< , d3t2l (:,:) => NULL () & !< , d3tl2 (:,:) => NULL () & !< , d3l3 (:,:) => NULL () contains procedure ( init_xc_lib ), deferred :: init procedure ( compute_xc_lib ), deferred :: compute procedure ( setPts_xc_lib ), deferred :: setPts procedure :: clean procedure :: scalexc procedure , non_overridable :: echo procedure , non_overridable :: getEnergy procedure , non_overridable :: resetEnergy end type xc_lib_t abstract interface subroutine init_xc_lib ( self , reqSigma , reqTau , reqLapl , reqBeta , maxPts , nDer ) import class ( xc_lib_t ) :: self logical , intent ( in ) :: reqSigma , reqTau , reqLapl , reqBeta integer , intent ( in ) :: maxPts , nDer end subroutine subroutine setPts_xc_lib ( self , numPts ) import class ( xc_lib_t ), target :: self integer , intent ( in ) :: numPts end subroutine subroutine compute_xc_lib ( self , functional , wts ) import class ( xc_lib_t ) :: self class ( functional_t ) :: functional real ( kind = fp ), intent ( in ) :: wts (:) end subroutine end interface contains !> @brief Print parameters of the xc_engine_t instance !> @author Vladimir Mironov subroutine echo ( self ) class ( xc_lib_t ) :: self write ( * , * ) 'reqSigma =' , self % reqSigma write ( * , * ) 'reqTau   =' , self % reqTau write ( * , * ) 'reqBeta  =' , self % reqBeta write ( * , * ) 'maxPts   =' , self % maxPts write ( * , * ) 'numPts   =' , self % numPts write ( * , * ) 'nDer     =' , self % nDer write ( * , * ) 'xclibID  =' , self % xclibID end subroutine !> @brief Get debug statistics !> @author Vladimir Mironov subroutine getEnergy ( self , E_xc , E_exch , E_corr ) class ( xc_lib_t ) :: self real ( kind = fp ), intent ( out ) :: & E_xc , E_exch , E_corr E_xc = self % E_xc E_exch = self % E_exch E_corr = self % E_corr end subroutine !> @brief Set debug statistics !> @author Vladimir Mironov subroutine resetEnergy ( self ) class ( xc_lib_t ) :: self self % E_exch = 0.0 self % E_corr = 0.0 end subroutine !> @brief Cleanup !> @author Vladimir Mironov subroutine clean ( self ) class ( xc_lib_t ) :: self if ( allocated ( self % memory_ )) deallocate ( self % memory_ ) self % rho => NULL () self % sig => NULL () self % tau => NULL () self % lapl => NULL () self % exc => NULL () self % d1dr => NULL () self % d1ds => NULL () self % d1dt => NULL () self % d1dl => NULL () self % d2r2 => NULL () self % d2s2 => NULL () self % d2t2 => NULL () self % d2rs => NULL () self % d2rt => NULL () self % d2st => NULL () self % d2rl => NULL () self % d2sl => NULL () self % d2tl => NULL () self % d2l2 => NULL () self % d3r3 => NULL () self % d3r2s => NULL () self % d3rs2 => NULL () self % d3s3 => NULL () self % d3t3 => NULL () self % d3r2t => NULL () self % d3s2t => NULL () self % d3rt2 => NULL () self % d3st2 => NULL () self % d3rst => NULL () self % d3r2l => NULL () self % d3rl2 => NULL () self % d3rsl => NULL () self % d3rtl => NULL () self % d3s2l => NULL () self % d3sl2 => NULL () self % d3stl => NULL () self % d3t2l => NULL () self % d3tl2 => NULL () self % d3l3 => NULL () end subroutine !> @brief Scale XC values by grid weights !> @author Vladimir Mironov subroutine scalexc ( self , wts ) class ( xc_lib_t ) :: self real ( kind = fp ) :: wts (:) call scale_2d ( self % d1dr , wts ) if ( self % reqSigma ) then call scale_2d ( self % d1ds , wts ) end if if ( self % reqTau ) then call scale_2d ( self % d1dt , wts ) end if if ( self % nDer < 2 ) return call scale_2d ( self % d2r2 , wts ) if ( self % reqSigma ) then call scale_2d ( self % d2s2 , wts ) call scale_2d ( self % d2rs , wts ) end if if ( self % reqTau ) then call scale_2d ( self % d2t2 , wts ) call scale_2d ( self % d2rt , wts ) call scale_2d ( self % d2st , wts ) end if if ( self % nDer < 3 ) return call scale_2d ( self % d3r3 , wts ) if ( self % reqSigma ) then call scale_2d ( self % d3r2s , wts ) call scale_2d ( self % d3rs2 , wts ) call scale_2d ( self % d3s3 , wts ) end if if ( self % reqTau ) then call scale_2d ( self % d3r2t , wts ) call scale_2d ( self % d3rst , wts ) call scale_2d ( self % d3rt2 , wts ) call scale_2d ( self % d3s2t , wts ) call scale_2d ( self % d3st2 , wts ) call scale_2d ( self % d3t3 , wts ) end if end subroutine !> @brief Scale 2d array along 1st dimension by a given !>  vector of weights subroutine scale_2d ( array , weights ) real ( kind = fp ), intent ( inout ) :: array (:,:) real ( kind = fp ), intent ( in ) :: weights (:) integer :: i do i = lbound ( array , 1 ), ubound ( array , 1 ) array ( i ,:) = array ( i ,:) * weights end do end subroutine end module","tags":"","url":"sourcefile/dft_xclib.f90.html"},{"title":"dft_incdft.F90 – OpenQP Fortran API","text":"Source Code !> @brief Incremental DFT (IncDFT): reuse the exchange-correlation Fock/energy !>        across SCF iterations where the density is no longer changing. !> !> @details OpenQP already builds the J/K (HF Coulomb/exchange) part of the Fock !>   matrix incrementally from the density change (scf.F90 dold/fold), but the XC !>   matrix is rebuilt from the full density on every iteration. As the SCF !>   converges the density change dP sparsifies and the XC contribution stops !>   changing, so rebuilding it is wasted quadrature. !> !>   XC is NONLINEAR in the density, so the reused matrix is an APPROXIMATION !>   that must be refreshed. This module reuses the most recent full XC build !>   (V_xc[D_ref], E_xc[D_ref]) only inside a controlled \"late-SCF\" window of the !>   DIIS error, with a periodic forced full rebuild (drift hygiene, mirroring !>   the J/K incremental reset cadence) and -- crucially -- a return to FULL XC !>   builds once the error drops below `incdft_stop`, so the converged density is !>   the true fixed point of the exact Fock and the converged energy/gradient are !>   unchanged from the non-incremental baseline. !> !>   Opt-in via env OQP_XC_INCDFT (default off). Complementary to the Phi cache !>   (Opt 1): the Phi cache removes the geometry-only collocation cost from every !>   XC build, while IncDFT skips the density-driven XC work entirely on reused !>   iterations. !> !> @author Claude (Anthropic), 2026 module mod_dft_incdft use precision , only : fp implicit none private !> @brief Stored reference XC contribution from the last full build type , public :: incdft_t logical :: valid = . false . integer :: ntri = 0 !< packed matrix length nbf*(nbf+1)/2 integer :: nf = 0 !< number of spin blocks real ( fp ), allocatable :: vxc (:,:) !< packed XC Fock (ntri, nf) real ( fp ) :: eexc = 0.0_fp real ( fp ) :: totele = 0.0_fp real ( fp ) :: totkin = 0.0_fp integer :: reuse_run = 0 !< consecutive reuses since the last full build integer :: n_full = 0 !< full XC builds this SCF (diagnostic) integer :: n_reuse = 0 !< reused XC builds this SCF (diagnostic) contains procedure :: free end type type ( incdft_t ), public , save :: g_xc_ref ! Reuse-window controls (env-overridable; see incdft_load_controls) real ( fp ), public :: incdft_start = 3.0e-2_fp !< start reusing below this DIIS error real ( fp ), public :: incdft_stop = 1.0e-4_fp !< stop reusing below this (force exact final) integer , public :: incdft_refresh = 5 !< forced full rebuild every N reuses integer , public :: incdft_min_iter = 2 !< never reuse before this iteration public :: incdft_env_enabled public :: incdft_should_reuse public :: incdft_reset public :: incdft_store contains !> @brief Is IncDFT enabled via the environment? (cached after first read) function incdft_env_enabled () result ( en ) logical :: en logical , save :: known = . false . logical , save :: value = . false . character ( len = 32 ) :: s integer :: st , ln if (. not . known ) then call get_environment_variable ( 'OQP_XC_INCDFT' , s , length = ln , status = st ) if ( st == 0 . and . ln > 0 ) then s = adjustl ( s ) value = ( trim ( s ) == '1' . or . trim ( s ) == 'true' . or . trim ( s ) == 'TRUE' & . or . trim ( s ) == 'on' . or . trim ( s ) == 'ON' . or . trim ( s ) == 'yes' & . or . trim ( s ) == 'YES' . or . trim ( s ) == 'T' . or . trim ( s ) == 't' ) end if call incdft_load_controls () known = . true . end if en = value end function !> @brief Optional env overrides for the reuse window (advanced/tuning). subroutine incdft_load_controls () character ( len = 32 ) :: s integer :: st , ln real ( fp ) :: v integer :: iv call get_environment_variable ( 'OQP_XC_INCDFT_START' , s , length = ln , status = st ) if ( st == 0 . and . ln > 0 ) then read ( s , * , iostat = st ) v if ( st == 0 . and . v > 0.0_fp ) incdft_start = v end if call get_environment_variable ( 'OQP_XC_INCDFT_STOP' , s , length = ln , status = st ) if ( st == 0 . and . ln > 0 ) then read ( s , * , iostat = st ) v if ( st == 0 . and . v > 0.0_fp ) incdft_stop = v end if call get_environment_variable ( 'OQP_XC_INCDFT_REFRESH' , s , length = ln , status = st ) if ( st == 0 . and . ln > 0 ) then read ( s , * , iostat = st ) iv if ( st == 0 . and . iv >= 1 ) incdft_refresh = iv end if end subroutine !> @brief Clear the reference store (call at SCF entry / geometry change). subroutine incdft_reset () call g_xc_ref % free () g_xc_ref % reuse_run = 0 g_xc_ref % n_full = 0 g_xc_ref % n_reuse = 0 end subroutine !> @brief Decide whether this iteration may reuse the stored XC matrix. !> @param[in] diis_error  current DIIS error (proxy for closeness to convergence) !> @param[in] iter        SCF iteration index !> @details Reuse only inside the window [incdft_stop, incdft_start): far from !>   convergence the XC changes too much; very close to convergence we force full !>   builds so the fixed point is exact. A periodic forced rebuild bounds drift. function incdft_should_reuse ( diis_error , iter ) result ( reuse ) real ( fp ), intent ( in ) :: diis_error integer , intent ( in ) :: iter logical :: reuse reuse = . false . if (. not . g_xc_ref % valid ) return ! need a full reference first if ( iter < incdft_min_iter ) return if ( diis_error >= incdft_start ) return ! too far from convergence if ( diis_error < incdft_stop ) return ! too close -> exact final builds if ( g_xc_ref % reuse_run >= incdft_refresh ) return ! periodic forced rebuild reuse = . true . end function !> @brief Store the result of a full XC build as the new reference. subroutine incdft_store ( vxc , eexc , totele , totkin ) real ( fp ), intent ( in ) :: vxc (:,:) real ( fp ), intent ( in ) :: eexc , totele , totkin if ( allocated ( g_xc_ref % vxc )) then if ( size ( g_xc_ref % vxc , 1 ) /= size ( vxc , 1 ) . or . size ( g_xc_ref % vxc , 2 ) /= size ( vxc , 2 )) & deallocate ( g_xc_ref % vxc ) end if if (. not . allocated ( g_xc_ref % vxc )) allocate ( g_xc_ref % vxc ( size ( vxc , 1 ), size ( vxc , 2 ))) g_xc_ref % vxc = vxc g_xc_ref % ntri = size ( vxc , 1 ) g_xc_ref % nf = size ( vxc , 2 ) g_xc_ref % eexc = eexc g_xc_ref % totele = totele g_xc_ref % totkin = totkin g_xc_ref % valid = . true . g_xc_ref % reuse_run = 0 g_xc_ref % n_full = g_xc_ref % n_full + 1 end subroutine subroutine free ( self ) class ( incdft_t ), intent ( inout ) :: self if ( allocated ( self % vxc )) deallocate ( self % vxc ) self % valid = . false . self % ntri = 0 self % nf = 0 end subroutine end module mod_dft_incdft","tags":"","url":"sourcefile/dft_incdft.f90.html"},{"title":"get_basis_overlap.F90 – OpenQP Fortran API","text":"Source Code !> @brief Module for calculating Atomic Orbital (AO) overlap between different geometries !> !> @details This module provides functionality to compute overlap between !>    basis sets (Atomic Orbitals) of two different geometries. It includes !>    calculations for AO overlap and then Molecular Orbital (MO) overlap. !> !> @note The matrices mol.data[\"OQP::xyz_old\"], !>                    mol.data[\"OQP::xyz\"], !>                    mol.data[\"OQP::VEC_MO_A_old\"], !>                    mol.data[\"OQP::VEC_MO_A\"], !>                    mol.data[\"OQP::E_MO_A_old\"], !>                    mol.data[\"OQP::E_MO_A\"] !>       must be defined in advance before running this program. !>       Output AO overlap will be written to !>                    mol.data[\"OQP::overlap_ao_non_orthogonal\"] !>       Output MO overlap will be written to !>                    mol.data[\"OQP::overlap_mo_non_orthogonal\"] !> !> @data Aug 2024 !> !> @author Konstantin Komarov !> module get_structures_ao_overlap_mod implicit none character ( len =* ), parameter :: module_name = \"get_structures_ao_overlap_mod\" public get_structures_ao_overlap contains !> @brief C-interoperable wrapper for get_states_overlap !> !> @param[in] c_handle   C handle for the information structure !> subroutine get_structures_ao_overlap_C ( c_handle ) bind ( C , name = \"get_structures_ao_overlap\" ) use c_interop , only : oqp_handle_t , oqp_handle_get_info use types , only : information type ( oqp_handle_t ) :: c_handle type ( information ), pointer :: inf inf => oqp_handle_get_info ( c_handle ) call get_structures_ao_overlap ( inf ) end subroutine get_structures_ao_overlap_c !> @brief Calculate AO overlap between two different geometries !> @param[in,out] infos Information structure containing all necessary data !> !> This subroutine calculates the overlap between basis sets (Atomic Orbitals) !> of two different geometries. It computes both AO and derived MO overlaps !> and stores the results in the infos structure. !> !> @note Output AO overlap is written to mol.data[\"OQP::overlap_ao_non_orthogonal\"] !>       Output MO overlap is written to mol.data[\"OQP::overlap_mo_non_orthogonal\"] !>       Current geometry (xyz) is taken from mol.data[\"OQP::xyz\"] !>       Current MO coefficients (mo_a) are taken from mol.data[\"OQP::VEC_MO_A\"] !>       Current MO energies (e_a) are taken from mol.data[\"OQP::E_MO_A\"] !>       Old geometry (xyz_old) is taken from mol.data[\"OQP::xyz_old\"] !>       Old MO coefficients (mo_a_old) are taken from mol.data[\"OQP::VEC_MO_A_old\"] !>       Old MO energies (e_a_old) are taken from mol.data[\"OQP::E_MO_A_old\"] !> subroutine get_structures_ao_overlap ( infos ) use precision , only : dp use io_constants , only : iw use oqp_tagarray_driver use types , only : information use strings , only : Cstring , fstring use basis_tools , only : basis_set use atomic_structure_m , only : atomic_structure use messages , only : show_message , with_abort use int1 , only : basis_overlap use constants , only : tol_int use util , only : measure_time implicit none character ( len =* ), parameter :: subroutine_name = \"get_structures_ao_overlap\" !> Information structure containing all necessary data type ( information ), target , intent ( inout ) :: infos type ( basis_set ), pointer :: basis type ( basis_set ), allocatable :: basis_old type ( atomic_structure ), allocatable , target :: atoms_old integer :: i , nbf ! Tagarray definitions and data pointers character ( len =* ), parameter :: tags_general ( * ) = ( / character ( len = 80 ) :: & OQP_XYZ_old , OQP_VEC_MO_A , OQP_E_MO_A , OQP_VEC_MO_A_old , OQP_E_MO_A_old / ) character ( len =* ), parameter :: tags_alloc ( * ) = ( / character ( len = 80 ) :: & OQP_overlap_mo , OQP_overlap_ao / ) real ( kind = dp ), pointer :: xyz_old (:,:), overlap_ao_out (:,:), overlap_mo_out (:,:), & mo_a (:,:), mo_a_old (:,:), e_a (:), e_a_old (:) ! Open log file open ( unit = IW , file = infos % log_filename , position = \"append\" ) ! Initialize basis sets and atomic structures allocate ( basis_old , source = infos % basis ) allocate ( atoms_old , source = infos % atoms ) basis => infos % basis basis % atoms => infos % atoms nbf = basis % nbf ! Allocate and prepare data for output call infos % dat % alloc_or_die ( OQP_overlap_mo , ( / nbf , nbf / ), overlap_mo_out , description = OQP_overlap_mo_comment ) call infos % dat % alloc_or_die ( OQP_overlap_ao , ( / nbf , nbf / ), overlap_ao_out , description = OQP_overlap_ao_comment ) ! Load data from python level call data_has_tags ( infos % dat , tags_general , module_name , subroutine_name , with_abort ) call tagarray_get_data ( infos % dat , OQP_xyz_old , xyz_old ) call tagarray_get_data ( infos % dat , OQP_VEC_MO_A , mo_a ) call tagarray_get_data ( infos % dat , OQP_E_MO_A , e_a ) call tagarray_get_data ( infos % dat , OQP_VEC_MO_A_old , mo_a_old ) call tagarray_get_data ( infos % dat , OQP_E_MO_A_old , e_a_old ) ! Apply old geometry to old basis atoms_old % xyz = xyz_old basis_old % atoms => atoms_old call print_geo ( basis_old , \"Previous geometry\" ) call print_geo ( basis , \" Current geometry\" ) overlap_ao_out = 0.0_dp overlap_mo_out = 0.0_dp ! Calculate AO overlap between old and new basis sets call basis_overlap ( overlap_ao_out , basis , basis_old , tol = log ( 1 0.0_dp ) * tol_int ) ! Normalize AO overlap do i = 1 , nbf overlap_ao_out (:, i ) = overlap_ao_out (:, i ) * basis % bfnrm ( i ) * basis_old % bfnrm (:) end do ! Calculate MO overlap: <old(I)|new(J')> = transpose[Cold(AI)] . <old(A)|new(A')> . Cnew(A'J') call mo_overlap ( overlap_mo_out , mo_a , mo_a_old , overlap_ao_out , nbf ) ! Output results: overlap between old and current MOs call print_results ( overlap_mo_out , e_a , e_a_old , nbf , & int ( infos % mol_prop % nelec_a ), iw ) !   Print timings call measure_time ( print_total = 1 , log_unit = iw ) call flush ( iw ) close ( iw ) end subroutine get_structures_ao_overlap !> @brief Calculate Molecular Orbital (MO) overlap between two geometries !> !> This subroutine computes the overlap between Molecular Orbitals of two different !> geometries, given their MO coefficients and the Atomic Orbital (AO) overlap. !> !> @param[out] overlap_mo  Resulting MO overlap matrix !> @param[in]  mo_a        MO coefficients obtained at the current geometry !> @param[in]  mo_a_old    MO coefficients obtained at the old geometry !> @param[in]  overlap_ao  AO overlap matrix between the two geometries !> @param[in]  nbf         Number of basis functions !> !> @note The MO overlap is calculated as: !>       overlap_mo = transpose(mo_a_old) . overlap_ao . mo_a !> subroutine mo_overlap ( overlap_mo , mo_a , mo_a_old , overlap_ao , nbf ) use precision , only : dp implicit none real ( kind = dp ), intent ( out ), dimension (:,:) :: overlap_mo real ( kind = dp ), intent ( in ), dimension (:,:) :: mo_a real ( kind = dp ), intent ( in ), dimension (:,:) :: mo_a_old real ( kind = dp ), intent ( in ), dimension (:,:) :: overlap_ao integer :: nbf real ( kind = dp ), allocatable , dimension (:,:) :: scr integer :: i allocate ( scr ( nbf , nbf ), source = 0.0_dp ) call dgemm ( 't' , 'n' , nbf , nbf , nbf , & 1.0_dp , mo_a_old , nbf , & overlap_ao , nbf , & 0.0_dp , scr , nbf ) call dgemm ( 'n' , 'n' , nbf , nbf , nbf , & 1.0_dp , scr , nbf , & mo_a , nbf , & 0.0_dp , overlap_mo , nbf ) ! Normalize MO overlap do i = 1 , nbf overlap_mo (:, i ) = overlap_mo (:, i ) / norm2 ( overlap_mo (:, i )) end do end subroutine mo_overlap !> @brief Print results of MO overlap between two geometries !> !> This subroutine prints the results of Molecular Orbital (MO) overlap !> calculations between two geometries, including energy comparisons !> and overlap values. !> !> @param[in] overlap_mo  MO overlap matrix !> @param[in] e           MO energies of the current geometry (in Hartree) !> @param[in] e_old       MO energies of the old geometry (in Hartree) !> @param[in] nbf         Number of basis functions !> @param[in] iw          Output unit number for writing results !> !> @note The subroutine prints a table showing: !>       - Corresponding overlap between old and new MOs !>       - Energies of corresponding MOs in eV !>       - Diagonal and maximum overlap values !>       - Warnings for low overlap or rearranged orbitals !> subroutine print_results ( overlap_mo , e , e_old , nbf , na , iw ) use precision , only : dp use physical_constants , only : ev2htree implicit none real ( kind = dp ), intent ( in ) :: overlap_mo (:,:) real ( kind = dp ), intent ( in ) :: e (:) real ( kind = dp ), intent ( in ) :: e_old (:) integer , intent ( in ) :: nbf , na , iw integer :: i , loc real ( kind = dp ) :: tmp , tmp2 , tmp_abs write ( iw , fmt = \"(/16X,39('=')/16X,a/16X,39('='))\" ) & 'Overlap MOs between geometries computed' write ( iw , fmt = '(/,x,65(\"-\"),/,1x,a,/,x,65(\"-\"))' ) & \"Maximum Overlap (MaxO) between MOs_old(A) and MOs(B). Delta = A-B\" write ( iw , fmt = '(x,a,1x,a,2x,a,2x,a,2x,a,2x,a)' ) & 'A_i <- B(MaxO)' , 'A_i, eV' , 'Delta, eV' , 'B_i, eV' , & 'B_i A_i Overlap' , 'MaxO' do i = 1 , nbf tmp_abs = maxval ( abs ( overlap_mo (: nbf , i ))) loc = maxloc ( abs ( overlap_mo (: nbf , i )), dim = 1 ) tmp = overlap_mo ( loc , i ) tmp2 = overlap_mo ( i , i ) write ( iw , advance = 'no' , fmt = '(x,i3,3x,i4,3x,f9.3,x,f9.5,x,f9.3,x,2f12.6)' ) & i , loc , e_old ( i ) * ev2htree ,( e_old ( i ) - e ( i )) * ev2htree , e ( i ) * ev2htree , & tmp2 , tmp if ( i == na - 1 ) write ( iw , advance = 'no' , fmt = '(2x,a)' ) ' HOMO' if ( i == na ) write ( iw , advance = 'no' , fmt = '(2x,a)' ) ' LUMO' if ( i /= loc . and . tmp_abs < 0.9_dp ) then write ( iw , fmt = '(2x,a)' ) ' rearranged, WARNING' elseif ( i == loc . and . tmp_abs < 0.9_dp ) then write ( iw , fmt = '(2x,a)' ) ' WARNING' elseif ( i /= loc . and . tmp_abs > 0.9_dp ) then write ( iw , fmt = '(2x,a)' ) ' rearranged' else write ( iw , * ) end if end do write ( iw , * ) end subroutine print_results !> @brief Print geometry information !> !> @param[in] basis   The basis class containing geometry information !> @param[in] text    A descriptive text for the geometry output !> subroutine print_geo ( basis , text ) use io_constants , only : iw use basis_tools , only : basis_set use physical_constants , only : bohr_to_angstrom implicit none type ( basis_set ), intent ( in ) :: basis character ( len =* ), intent ( in ) :: text integer :: i write ( iw , fmt = \"(& &/26X,17('=')& &/26X,a& &/26X,17('=')& &/8X,'Atom     Znuc',11X,'X',14X,'Y',14X,'Z'& &/6X,62('-'))\" ) text do i = 1 , size ( basis % atoms % zn (:)) write ( iw , '(7x,i4,5x,f4.1,3(x,f15.9))' ) & i , basis % atoms % zn ( i ), basis % atoms % xyz ( 1 : 3 , i ) * bohr_to_angstrom end do end subroutine print_geo end module get_structures_ao_overlap_mod","tags":"","url":"sourcefile/get_basis_overlap.f90.html"},{"title":"physical_constants.F90 – OpenQP Fortran API","text":"Source Code module physical_constants use , intrinsic :: iso_fortran_env , only : real64 implicit none private real ( real64 ), public , parameter :: ELECTRON_CHARGE = 1.602176634d-19 !   Recent (2018) NIST CODATA values (SI) real ( real64 ), public , parameter :: BOHR_RADIUS = 5.29177210903d-11 real ( real64 ), public , parameter :: ANGSTROM = 1.00000000000d-10 real ( real64 ), public , parameter :: NANOMETER = 1.00000000000d-09 real ( real64 ), public , parameter :: HARTREE = 4.3597447222071d-18 real ( real64 ), public , parameter :: ELECTRONVOLT = 1.602176634d-19 real ( real64 ), public , parameter :: JOULE = 1.0d+00 real ( real64 ), public , parameter :: CALORIE = 4.184d+00 real ( real64 ), public , parameter :: STATC = 1.0d0 / 299792458 0.0d0 real ( real64 ), public , parameter :: CENTIMETER = 1.0d-02 real ( real64 ), public , parameter :: DEBYE = 1.0d-10 * STATC * ANGSTROM real ( real64 ), public , parameter :: BUCKINGHAM = DEBYE * ANGSTROM real ( real64 ), public , parameter :: CGS_OCT = BUCKINGHAM * ANGSTROM real ( real64 ), public , parameter :: UNITS_DIPOLE = ELECTRON_CHARGE * BOHR_RADIUS real ( real64 ), public , parameter :: UNITS_QUADRUPOLE = UNITS_DIPOLE * BOHR_RADIUS real ( real64 ), public , parameter :: UNITS_OCTOPOLE = UNITS_QUADRUPOLE * BOHR_RADIUS real ( real64 ), public , parameter :: K_BOLTZMANN = 1.380649d-23 real ( real64 ), public , parameter :: N_AVOGADRO = 6.02214076d+23 real ( real64 ), public , parameter :: FINE_STRUCTURE = 7.2973525693d-3 !   Internal default units are atomic units (length: Bohr, energy: Hartree) !   Units of length real ( real64 ), public , parameter :: UNITS_BOHR = 1.0d0 real ( real64 ), public , parameter :: UNITS_ANGSTROM = ANGSTROM / BOHR_RADIUS real ( real64 ), public , parameter :: UNITS_NM = NANOMETER / BOHR_RADIUS !   Units of energy real ( real64 ), public , parameter :: UNITS_HARTREE = 1.0d0 real ( real64 ), public , parameter :: UNITS_EV = ELECTRONVOLT / HARTREE real ( real64 ), public , parameter :: UNITS_KCALMOL = ( 1000 * CALORIE / N_AVOGADRO ) / HARTREE real ( real64 ), public , parameter :: UNITS_KJMOL = ( 1000 * JOULE / N_AVOGADRO ) / HARTREE real ( real64 ), public , parameter :: HA_TO_WAVENUM = 21947 4.6313708d0 !   Common conversion constants real ( real64 ), public , parameter :: BOHR_TO_ANGSTROM = UNITS_BOHR / UNITS_ANGSTROM real ( real64 ), public , parameter :: ANGSTROM_TO_BOHR = UNITS_ANGSTROM / UNITS_BOHR !  Electric moments real ( real64 ), public , parameter :: AU_TO_DEBYE = UNITS_DIPOLE / DEBYE real ( real64 ), public , parameter :: AU_TO_BUCK = UNITS_QUADRUPOLE / BUCKINGHAM real ( real64 ), public , parameter :: AU_TO_OCT = UNITS_OCTOPOLE / CGS_OCT !   COMPATIBILITY: real ( real64 ), public , parameter :: AU2ANG = BOHR_TO_ANGSTROM real ( real64 ), public , parameter :: EV2HTREE = HARTREE / ELECTRONVOLT end module","tags":"","url":"sourcefile/physical_constants.f90.html"},{"title":"hf_gradient.F90 – OpenQP Fortran API","text":"Source Code module hf_gradient_mod use precision , only : dp use grd2 , only : grd2_driver , grd2_compute_data_t use basis_tools , only : basis_set , bas_norm_matrix , build_cart_density use constants , only : HARMONIC_ACTIVE , NUM_CART_BF use types , only : information implicit none character ( len =* ), parameter :: module_name = \"hf_gradient_mod\" !############################################################################### type , extends ( grd2_compute_data_t ), abstract :: grd2_hf_compute_data_t real ( kind = dp ), pointer :: da (:) => null () real ( kind = dp ), pointer :: db (:) => null () real ( kind = dp ), allocatable :: d2a (:,:), d2b (:,:) ! Cartesian-effective (bfnrm-folded) densities + Cartesian offsets, built ! by build_cart and used by get_density under HARMONIC_ACTIVE. real ( kind = dp ), allocatable :: d2a_cart (:,:), d2b_cart (:,:) integer , allocatable :: cart_off (:) integer :: nbf_cart = 0 integer :: nbf = 0 contains procedure :: build_cart => grd2_hf_build_cart end type !############################################################################### type , extends ( grd2_hf_compute_data_t ) :: grd2_rhf_compute_data_t contains procedure :: init => grd2_rhf_compute_data_t_init procedure :: clean => grd2_rhf_compute_data_t_clean procedure :: get_density => grd2_rhf_compute_data_t_get_density end type !############################################################################### type , extends ( grd2_hf_compute_data_t ) :: grd2_uhf_compute_data_t contains procedure :: init => grd2_uhf_compute_data_t_init procedure :: clean => grd2_uhf_compute_data_t_clean procedure :: get_density => grd2_uhf_compute_data_t_get_density end type !############################################################################### private public hf_gradient public grd2_rhf_compute_data_t public grd2_uhf_compute_data_t !############################################################################### contains !############################################################################### subroutine hf_gradient_C ( c_handle ) bind ( C , name = \"hf_gradient\" ) use c_interop , only : oqp_handle_t , oqp_handle_get_info use types , only : information type ( oqp_handle_t ) :: c_handle type ( information ), pointer :: inf inf => oqp_handle_get_info ( c_handle ) call hf_gradient ( inf ) end subroutine hf_gradient_C !############################################################################### subroutine hf_gradient ( infos ) use io_constants , only : iw use grd1 , only : print_gradient use dft , only : dft_initialize , dftclean , dftder use strings , only : Cstring , fstring use mod_dft_molgrid , only : dft_grid_t use util , only : measure_time use printing , only : print_module_info implicit none type ( information ), target , intent ( inout ) :: infos type ( basis_Set ), pointer :: basis logical :: dft type ( dft_grid_t ) :: molGrid !   3. LOG: Write: Main output file open ( unit = IW , file = infos % log_filename , position = \"append\" ) ! call print_module_info ( 'HF_DFT_Gradient' , 'Computing Gradient of HF/DFT' ) dft = infos % control % hamilton == 20 !   Load basis set basis => infos % basis basis % atoms => infos % atoms !   Compute 1e gradient write ( iw , \"(/' ..... Beginning Gradient Calculation...'/)\" ) call flush ( iw ) call hf_1e_grad ( infos , basis ) write ( iw , \"(' ..... End Of 1-Eelectron Gradient ......')\" ) call measure_time ( print_total = 1 , log_unit = iw ) call flush ( iw ) !   Calculate DFT contribution if ( dft ) then write ( iw , \"(/' ..... Gradient XC terms...'/)\" ) call dft_initialize ( infos , basis , molGrid , verbose = . true .) call dftder ( basis , infos , molGrid ) call dftclean ( infos ) write ( iw , \"(' ..... End of gradient XC terms......')\" ) call measure_time ( print_total = 1 , log_unit = iw ) call flush ( iw ) end if !   Compute 2e gradient call hf_2e_grad ( basis , infos ) write ( iw , fmt = \"(' ...... End Of 2-Electron Gradient ......')\" ) call measure_time ( print_total = 1 , log_unit = iw ) call flush ( iw ) !   Print out gradient call print_gradient ( infos ) !   Print timings call measure_time ( print_total = 1 , log_unit = iw ) close ( iw ) end subroutine hf_gradient !------------------------------------------------------------------------------- subroutine hf_1e_grad ( infos , basis ) use types , only : information use oqp_tagarray_driver use basis_tools , only : basis_set use util , only : measure_time use messages , only : show_message , WITH_ABORT use constants , only : tol_int use grd1 , only : eijden , grad_nn , grad_ee_overlap , & grad_ee_kinetic , grad_en_hellman_feynman , & grad_en_pulay , grad_1e_ecp use qmmm_mod , only : grad_esp_qmmm implicit none character ( len =* ), parameter :: subroutine_name = \"hf_1e_grad\" type ( information ), intent ( inout ) :: infos type ( basis_set ), intent ( inout ) :: basis real ( kind = dp ), allocatable :: dens (:) real ( kind = dp ) :: tol integer :: nbf , nbf_tri , ok integer ( 4 ) :: status real ( kind = dp ), pointer :: dmat_a (:), dmat_b (:) nbf = basis % nbf nbf_tri = nbf * ( nbf + 1 ) / 2 tol = tol_int * log ( 1 0.0_dp ) !   initial memory allocation allocate ( dens ( nbf_tri ), source = 0.0_dp , stat = ok ) if ( ok /= 0 ) call show_message ( 'Cannot allocate memory' , WITH_ABORT ) call tagarray_get_data ( infos % dat , OQP_DM_A , dmat_a , status ) call check_status ( status , module_name , subroutine_name , OQP_DM_A ) if ( infos % control % scftype >= 2 ) then call tagarray_get_data ( infos % dat , OQP_DM_B , dmat_b , status ) call check_status ( status , module_name , subroutine_name , OQP_DM_B ) endif associate ( grad => infos % atoms % grad , & xyz => infos % atoms % xyz , & zn => infos % atoms % zn - infos % basis % ecp_zn_num ) !     Zero out gradient grad = 0.0d0 !     Nuclear repulsion force call grad_nn ( infos % atoms , infos % basis % ecp_zn_num ) !     Obtain Lagrangian matrix (`dens`) call eijden ( dens , nbf , infos ) !     Overlap gradient call grad_ee_overlap ( basis , dens , grad , logtol = tol ) !     Compute total density matrix, discard Lagrangian dens = dmat_a if ( infos % control % scftype >= 2 ) dens = dens + dmat_b !     Kinetic gradient call grad_ee_kinetic ( basis , dens , grad , logtol = tol ) !     Hellmann-Feynman force call grad_en_hellman_feynman ( basis , xyz , zn , dens , grad , logtol = tol ) !     Pulay force call grad_en_pulay ( basis , xyz , zn , dens , grad , logtol = tol ) !     Effective core potential gradient call grad_1e_ecp ( infos , basis , xyz , dens , grad , logtol = tol ) !     QM/MM force !      if(infos%control%qmmm_flag) call grad_esp_qmmm(infos, dens, grad,logtol=tol) end associate end subroutine !############################################################################### !> @brief The driver for the two electron gradient subroutine hf_2e_grad ( basis , infos ) use basis_tools , only : basis_set use precision , only : dp use oqp_tagarray_driver use messages , only : show_message , WITH_ABORT use types , only : information implicit none character ( len =* ), parameter :: subroutine_name = \"hf_2e_grad\" type ( information ), target , intent ( inout ) :: infos type ( basis_set ) :: basis logical :: urohf real ( kind = dp ) :: hfscale integer :: ok real ( kind = dp ), allocatable :: de (:,:) class ( grd2_compute_data_t ), allocatable :: gcomp ! tagarray real ( kind = dp ), contiguous , pointer :: dmat_a (:), dmat_b (:) integer ( 4 ) :: status urohf = infos % control % scftype >= 2 hfscale = 1.0d0 if ( infos % control % hamilton . ge . 20 ) hfscale = infos % dft % hfscale allocate ( de ( 3 , ubound ( infos % atoms % zn , 1 )), & source = 0.0d0 , & stat = ok ) if ( ok /= 0 ) call show_message ( 'cannot allocate memory' , WITH_ABORT ) if ( urohf ) then call tagarray_get_data ( infos % dat , OQP_DM_A , dmat_a , status ) call check_status ( status , module_name , subroutine_name , OQP_DM_A ) call tagarray_get_data ( infos % dat , OQP_DM_B , dmat_b , status ) call check_status ( status , module_name , subroutine_name , OQP_DM_B ) gcomp = & grd2_uhf_compute_data_t ( da = dmat_a & , db = dmat_b & , hfscale = hfscale & , nbf = basis % nbf & ) else call tagarray_get_data ( infos % dat , OQP_DM_A , dmat_a , status ) call check_status ( status , module_name , subroutine_name , OQP_DM_A ) gcomp = & grd2_rhf_compute_data_t ( da = dmat_a & , hfscale = hfscale & , nbf = basis % nbf & ) end if call gcomp % init () select type ( gcomp ) class is ( grd2_hf_compute_data_t ) call gcomp % build_cart ( basis ) end select call grd2_driver ( infos , basis , de , gcomp ) infos % atoms % grad = infos % atoms % grad + de call gcomp % clean () end subroutine !############################################################################### !> @brief Build Cartesian-effective (bfnrm-folded) densities + Cartesian !>        offsets for the 2e gradient under HARMONIC_ACTIVE. The 2-particle !>        density factorizes, so get_density uses the SAME formula on the !>        expanded density (no separate bfnrm factor). subroutine grd2_hf_build_cart ( this , basis ) class ( grd2_hf_compute_data_t ), intent ( inout ) :: this type ( basis_set ), intent ( in ) :: basis real ( kind = dp ), allocatable :: tmp (:,:) integer , allocatable :: dummy_off (:) integer :: ncb if (. not . HARMONIC_ACTIVE ) return tmp = this % d2a call bas_norm_matrix ( tmp , basis % bfnrm , basis % nbf ) call build_cart_density ( basis , tmp , this % d2a_cart , this % cart_off , this % nbf_cart ) if ( allocated ( this % d2b )) then tmp = this % d2b call bas_norm_matrix ( tmp , basis % bfnrm , basis % nbf ) call build_cart_density ( basis , tmp , this % d2b_cart , dummy_off , ncb ) end if end subroutine grd2_hf_build_cart !############################################################################### subroutine grd2_rhf_compute_data_t_init ( this ) use messages , only : show_message , WITH_ABORT use mathlib , only : unpack_matrix implicit none class ( grd2_rhf_compute_data_t ), target , intent ( inout ) :: this integer :: iok call this % clean () allocate ( this % d2a ( this % nbf , this % nbf ), stat = iok , source = 0.0d0 ) if ( iok /= 0 ) call show_message ( 'cannot allocate memory' , WITH_ABORT ) call unpack_matrix ( this % da , this % d2a ) end subroutine !############################################################################### subroutine grd2_uhf_compute_data_t_init ( this ) use messages , only : show_message , WITH_ABORT use mathlib , only : unpack_matrix implicit none class ( grd2_uhf_compute_data_t ), target , intent ( inout ) :: this integer :: iok call this % clean () allocate ( this % d2a ( this % nbf , this % nbf ), this % d2b ( this % nbf , this % nbf ), stat = iok , source = 0.0d0 ) if ( iok /= 0 ) call show_message ( 'cannot allocate memory' , WITH_ABORT ) call unpack_matrix ( this % da , this % d2a ) call unpack_matrix ( this % db , this % d2b ) this % d2a = this % d2a + this % d2b this % d2b = this % d2a - 2 * this % d2b end subroutine !############################################################################### subroutine grd2_rhf_compute_data_t_clean ( this ) implicit none class ( grd2_rhf_compute_data_t ), target , intent ( inout ) :: this if ( allocated ( this % d2a )) deallocate ( this % d2a ) end subroutine !############################################################################### subroutine grd2_uhf_compute_data_t_clean ( this ) implicit none class ( grd2_uhf_compute_data_t ), target , intent ( inout ) :: this if ( allocated ( this % d2a )) deallocate ( this % d2a ) if ( allocated ( this % d2b )) deallocate ( this % d2b ) end subroutine !############################################################################### !> @brief This routine forms the product of density !>        matrices for use in forming the two electron !>        gradient. Valid for closed and open shell SCF. !> @note  dabmax is computed from the unnormalized density products (the !>        historic screening convention); the basis normalization enters only !>        the stored block, through norm factors hoisted out of the inner !>        loops. subroutine grd2_rhf_compute_data_t_get_density ( this , basis , id , dab , dabmax ) implicit none class ( grd2_rhf_compute_data_t ), target , intent ( inout ) :: this type ( basis_set ), intent ( in ) :: basis integer , intent ( in ) :: id ( 4 ) real ( kind = dp ), target , intent ( out ) :: dab ( * ) real ( kind = dp ), intent ( out ) :: dabmax real ( kind = dp ) :: coulfact , xcfact , df1 , dq1 , bfn logical :: do_exchange integer :: i , j , k , l integer :: loc ( 4 ) integer :: nbf ( 4 ) real ( kind = dp ), pointer :: ab (:,:,:,:) real ( kind = dp ), pointer :: d2a (:,:) integer :: i1 , j1 , k1 , l1 logical :: usecart coulfact = 4 * this % coulscale xcfact = this % hfscale do_exchange = xcfact /= 0.0_dp ! Under HARMONIC_ACTIVE the derivative ERIs are Cartesian, so contract ! against the Cartesian-effective density with Cartesian offsets; the ! bfnrm factor is already folded into d2a_cart. Otherwise use the ! spherical/Cartesian density with shell offsets and apply bfnrm. usecart = HARMONIC_ACTIVE if ( usecart ) then d2a => this % d2a_cart loc = this % cart_off ( id ) - 1 nbf = NUM_CART_BF ( basis % am ( id )) else d2a => this % d2a loc = basis % ao_offset ( id ) - 1 nbf = basis % naos ( id ) end if dabmax = 0 ab ( 1 : nbf ( 4 ), 1 : nbf ( 3 ), 1 : nbf ( 2 ), 1 : nbf ( 1 )) => dab ( 1 : product ( nbf )) do i = 1 , nbf ( 1 ) i1 = loc ( 1 ) + i do j = 1 , nbf ( 2 ) j1 = loc ( 2 ) + j do k = 1 , nbf ( 3 ) k1 = loc ( 3 ) + k do l = 1 , nbf ( 4 ) l1 = loc ( 4 ) + l df1 = coulfact * d2a ( i1 , j1 ) * d2a ( k1 , l1 ) if ( do_exchange ) then dq1 = d2a ( i1 , k1 ) * d2a ( j1 , l1 ) & + d2a ( i1 , l1 ) * d2a ( j1 , k1 ) df1 = df1 - xcfact * dq1 end if dabmax = max ( dabmax , abs ( df1 )) bfn = 1.0_dp if (. not . usecart ) bfn = product ( basis % bfnrm ([ i1 , j1 , k1 , l1 ])) ab ( l , k , j , i ) = df1 * bfn end do end do end do end do end subroutine grd2_rhf_compute_data_t_get_density !############################################################################### !> @brief This routine forms the product of density !>        matrices for use in forming the two electron !>        gradient. Valid for closed and open shell SCF. !> @note  dabmax is computed from the unnormalized density products (the !>        historic screening convention); the basis normalization enters only !>        the stored block, through norm factors hoisted out of the inner !>        loops. subroutine grd2_uhf_compute_data_t_get_density ( this , basis , id , dab , dabmax ) implicit none class ( grd2_uhf_compute_data_t ), target , intent ( inout ) :: this type ( basis_set ), intent ( in ) :: basis integer , intent ( in ) :: id ( 4 ) real ( kind = dp ), target , intent ( out ) :: dab ( * ) real ( kind = dp ), intent ( out ) :: dabmax real ( kind = dp ) :: coulfact , xcfact , df1 , dq1 , bfn logical :: do_exchange integer :: i , j , k , l integer :: loc ( 4 ) integer :: nbf ( 4 ) real ( kind = dp ), pointer :: ab (:,:,:,:) real ( kind = dp ), pointer :: d2a (:,:), d2b (:,:) integer :: i1 , j1 , k1 , l1 logical :: usecart coulfact = 4 * this % coulscale xcfact = this % hfscale do_exchange = xcfact /= 0.0_dp usecart = HARMONIC_ACTIVE if ( usecart ) then d2a => this % d2a_cart d2b => this % d2b_cart loc = this % cart_off ( id ) - 1 nbf = NUM_CART_BF ( basis % am ( id )) else d2a => this % d2a d2b => this % d2b loc = basis % ao_offset ( id ) - 1 nbf = basis % naos ( id ) end if dabmax = 0 ab ( 1 : nbf ( 4 ), 1 : nbf ( 3 ), 1 : nbf ( 2 ), 1 : nbf ( 1 )) => dab ( 1 : product ( nbf )) do i = 1 , nbf ( 1 ) i1 = loc ( 1 ) + i do j = 1 , nbf ( 2 ) j1 = loc ( 2 ) + j do k = 1 , nbf ( 3 ) k1 = loc ( 3 ) + k do l = 1 , nbf ( 4 ) l1 = loc ( 4 ) + l df1 = coulfact * d2a ( i1 , j1 ) * d2a ( k1 , l1 ) if ( do_exchange ) then dq1 = d2a ( i1 , k1 ) * d2a ( j1 , l1 ) & + d2a ( i1 , l1 ) * d2a ( j1 , k1 ) & + d2b ( i1 , k1 ) * d2b ( j1 , l1 ) & + d2b ( i1 , l1 ) * d2b ( j1 , k1 ) df1 = df1 - xcfact * dq1 end if dabmax = max ( dabmax , abs ( df1 )) bfn = 1.0_dp if (. not . usecart ) bfn = product ( basis % bfnrm ([ i1 , j1 , k1 , l1 ])) ab ( l , k , j , i ) = df1 * bfn end do end do end do end do end subroutine grd2_uhf_compute_data_t_get_density end module hf_gradient_mod","tags":"","url":"sourcefile/hf_gradient.f90.html"},{"title":"grid_storage.F90 – OpenQP Fortran API","text":"Source Code !> @brief Module to store data of DFT atomic quadratures !> @author Vladimir Mironov module mod_grid_storage use precision , only : fp implicit none !******************************************************************************* !> @brief Type to store 3D quadrature grid !> @author Vladimir Mironov type :: grid_3d_t !< X coordinates real ( KIND = fp ), allocatable :: x (:) !< Y coordinates real ( KIND = fp ), allocatable :: y (:) !< Z coordinates real ( KIND = fp ), allocatable :: z (:) !< quadrature weights real ( KIND = fp ), allocatable :: w (:) !< number of points integer :: nPts = 0 !< grid array index, used for reverse search integer :: idGrid = 0 !< tesselation data: (number or points per zone, tesselation degree) integer ( KIND = 2 ), allocatable :: izones (:, :) contains procedure , pass :: set => setGrid procedure , pass :: get => getGrid procedure , pass :: check => checkGrid procedure , pass :: clear => clearGrid end type !******************************************************************************* !> @brief Pointer to 3D grid container (to be used in arrays) !> @author Vladimir Mironov type :: grid_3d_pt type ( grid_3d_t ), pointer :: p end type !******************************************************************************* !> @brief Basic array list type to store 3d grids !> @note DO not use any method except `p => list%get` !>  in a performance-critical loop! !> @author Vladimir Mironov type :: list_grid_3d_t private !< Current number of grids stored integer , public :: nGrids = 0 !< Maximum number of grids integer :: maxGrids = 0 !< Grid data type ( grid_3d_pt ), allocatable :: elem (:) contains procedure , non_overridable :: get_pts => get_grid_pts procedure , non_overridable :: set_pts => set_grid_pts procedure , non_overridable :: findID => findIDListGrid procedure , non_overridable :: getByID => getByIDListGrid procedure , non_overridable :: push => pushListGrid procedure , non_overridable :: pop => popListGrid procedure :: get => getListGrid procedure :: set => setListGrid procedure :: init => initListGrid procedure :: clear => clearListGrid procedure :: delete => deleteListGrid procedure , private :: extend => extendListGrid end type type :: atomic_grid_t type ( list_grid_3d_t ), pointer :: spherical_grids integer , allocatable :: sph_npts (:) integer :: idAtm real ( kind = fp ) :: rAtm real ( KIND = fp ), allocatable :: sph_radii (:) !< Index-based pruning sectors (e.g. SG-2/SG-3): region i covers the !< next sph_nrad(i) radial shells (ascending radius).  When allocated, !< it takes precedence over the radius-based sph_radii regions. integer , allocatable :: sph_nrad (:) real ( KIND = fp ), allocatable :: rad_pts (:) real ( KIND = fp ), allocatable :: rad_wts (:) end type integer , parameter :: DEFAULT_GRID_CHUNK = 32 !******************************************************************************* private public grid_3d_t public grid_3d_pt public list_grid_3d_t public atomic_grid_t contains !******************************************************************************* !------------------------------------------------------------------------------- !> @brief Get angular grid data !> @param[in]   npts  number of points !> @param[out]  x        x coordinates !> @param[out]  y        y coordinates !> @param[out]  z        z coordinates !> @param[out]  w        weights !> @param[out]  izones   tesselation data !> @param[out]  found    whether the grid was found in the dataset !> @author Vladimir Mironov subroutine get_grid_pts ( grids , npts , x , y , z , w , izones , found ) class ( list_grid_3d_t ) :: grids integer , intent ( OUT ) :: izones (:, :) real ( KIND = fp ), intent ( OUT ) :: x (:), y (:), z (:), w (:) integer , intent ( IN ) :: npts logical , intent ( OUT ) :: found type ( grid_3d_t ), pointer :: tmp tmp => grids % get ( npts ) found = associated ( tmp ) if ( found ) then x = tmp % x y = tmp % y z = tmp % z w = tmp % w izones = tmp % izones end if end subroutine !------------------------------------------------------------------------------- !> @brief Set angular grid data !> @param[in]  npts  number of points !> @param[in]  x        x coordinates !> @param[in]  y        y coordinates !> @param[in]  z        z coordinates !> @param[in]  w        weights !> @param[in]  izones   tesselation data !> @author Vladimir Mironov subroutine set_grid_pts ( grids , npts , x , y , z , w , izones ) class ( list_grid_3d_t ) :: grids real ( KIND = fp ), intent ( IN ) :: x (:), y (:), z (:), w (:) integer , intent ( IN ) :: izones (:, :) integer , intent ( IN ) :: npts type ( grid_3d_t ), pointer :: tmp !TYPE(grid_3d_t) :: grid !CALL grid%set(npts,x,y,z,w,izones) !tmp => grids%set(grid) tmp => grids % set ( grid_3d_t ( x = x , y = y , z = z , w = w , & npts = npts , izones = int ( izones , 2 ))) end subroutine !******************************************************************************* !> @brief Get a pointer to a grid stored in a list !> @param[in]  npts  number of points !> @author Vladimir Mironov function getListGrid ( list , npts ) result ( res ) class ( list_grid_3d_t ), target , intent ( IN ) :: list type ( grid_3d_t ), pointer :: res integer , intent ( IN ) :: npts integer :: i logical :: found found = . false . do i = 1 , list % nGrids res => list % elem ( i )% p found = res % check ( npts ) if ( found ) exit end do if (. not . found ) res => null () end function getListGrid !------------------------------------------------------------------------------- !> @brief Get index of a grid stored in a list !> @param[in]  npts  number of points !> @author Vladimir Mironov function findIDListGrid ( list , npts ) result ( id ) class ( list_grid_3d_t ), target , intent ( IN ) :: list integer :: id integer , intent ( IN ) :: npts logical :: found found = . false . do id = 1 , list % nGrids found = list % elem ( id )% p % check ( npts ) if ( found ) exit end do if (. not . found ) id = 0 end function findIDListGrid !------------------------------------------------------------------------------- !> @brief Get a pointer to a grid stored in a list by its index !> @param[in]  id    grid index !> @author Vladimir Mironov function getByIDListGrid ( list , id ) result ( res ) class ( list_grid_3d_t ), target , intent ( IN ) :: list type ( grid_3d_t ), pointer :: res integer , intent ( IN ) :: id res => null () if ( id >= 1 . and . id <= list % nGrids ) res => list % elem ( id )% p end function getByIDListGrid !------------------------------------------------------------------------------- !> @brief Set a grid in the list. Return a pointer to the list entry. !> @param[in]  grid  grid data !> @author Vladimir Mironov function setListGrid ( list , grid ) result ( ptr ) class ( list_grid_3d_t ), intent ( INOUT ) :: list type ( grid_3d_t ), intent ( IN ) :: grid type ( grid_3d_t ), pointer :: ptr ptr => list % get ( grid % npts ) if ( associated ( ptr )) then ptr = grid else ptr => list % push ( grid ) end if end function setListGrid !------------------------------------------------------------------------------- !> @brief Add a new grid to the list. Return a pointer to the list entry. !> @param[in]  grid  grid data !> @author Vladimir Mironov function pushListGrid ( list , grid ) result ( ptr ) class ( list_grid_3d_t ), intent ( INOUT ) :: list type ( grid_3d_t ), intent ( IN ) :: grid type ( grid_3d_t ), pointer :: ptr if ( list % nGrids == list % maxGrids ) call list % extend list % nGrids = list % nGrids + 1 allocate ( list % elem ( list % nGrids )% p ) !, source=grid) list % elem ( list % nGrids )% p = grid ptr => list % elem ( list % nGrids )% p ptr % idGrid = list % nGrids end function pushListGrid !------------------------------------------------------------------------------- !> @brief Pop a grid from the top of the list. !> @author Vladimir Mironov function popListGrid ( list ) result ( grid ) class ( list_grid_3d_t ), target , intent ( INOUT ) :: list type ( grid_3d_t ) :: grid if ( list % nGrids /= 0 ) then grid = list % elem ( list % nGrids )% p deallocate ( list % elem ( list % nGrids )% p ) list % nGrids = list % nGrids - 1 end if end function popListGrid !------------------------------------------------------------------------------- !> @brief Initialize grid list, possibly specifying its size !> @param[in]  iSize   desired list size !> @author Vladimir Mironov subroutine initListGrid ( list , iSize ) class ( list_grid_3d_t ) :: list integer , optional , intent ( IN ) :: iSize integer :: isz isz = DEFAULT_GRID_CHUNK if ( present ( iSize )) isz = iSize if ( allocated ( list % elem )) then call list % clear if ( list % maxGrids < isz ) then deallocate ( list % elem ) end if end if if (. not . allocated ( list % elem )) then allocate ( list % elem ( isz )) end if list % nGrids = 0 list % maxGrids = max ( isz , list % maxGrids ) end subroutine initListGrid !------------------------------------------------------------------------------- !> @brief Clear grid list !> @author Vladimir Mironov subroutine clearListGrid ( list ) class ( list_grid_3d_t ) :: list integer :: i do i = 1 , list % nGrids if ( associated ( list % elem ( i )% p )) deallocate ( list % elem ( i )% p ) end do list % nGrids = 0 end subroutine clearListGrid !------------------------------------------------------------------------------- !> @brief Destroy grid list !> @author Vladimir Mironov subroutine deleteListGrid ( list ) class ( list_grid_3d_t ) :: list call list % clear deallocate ( list % elem ) list % maxGrids = 0 end subroutine deleteListGrid !------------------------------------------------------------------------------- !> @brief Extend grid list to a new size !> @param[in] iSize  size to extend the list !> @author Vladimir Mironov subroutine extendListGrid ( list , iSize ) class ( list_grid_3d_t ), intent ( INOUT ) :: list type ( grid_3d_pt ), allocatable :: elem_new (:) integer , optional , intent ( IN ) :: iSize integer :: isz isz = DEFAULT_GRID_CHUNK if ( present ( iSize )) isz = iSize allocate ( elem_new ( list % maxGrids + isz ), source = list % elem ) call move_alloc ( from = elem_new , to = list % elem ) list % maxGrids = list % maxGrids + isz end subroutine !******************************************************************************* !> @brief Set 3D grid data !> @param[in]  npts  number of points !> @param[in]  x        x coordinates !> @param[in]  y        y coordinates !> @param[in]  z        z coordinates !> @param[in]  w        weights !> @param[in]  izones   tesselation data !> @author Vladimir Mironov subroutine setGrid ( grid , npts , x , y , z , w , izones ) class ( grid_3d_t ), intent ( INOUT ) :: grid real ( KIND = fp ), intent ( IN ) :: x (:), y (:), z (:), w (:) integer , intent ( IN ) :: izones (:, :) integer , intent ( IN ) :: npts grid % npts = npts grid % x = x grid % y = y grid % z = z grid % w = w grid % izones = int ( izones , kind = 2 ) end subroutine setGrid !------------------------------------------------------------------------------- !> @brief Get 3D grid data !> @param[in]   npts  number of points !> @param[out]  x        x coordinates !> @param[out]  y        y coordinates !> @param[out]  z        z coordinates !> @param[out]  w        weights !> @param[out]  izones   tesselation data !> @author Vladimir Mironov subroutine getGrid ( grid , npts , x , y , z , w , izones ) class ( grid_3d_t ), intent ( IN ) :: grid real ( KIND = fp ), intent ( OUT ) :: x (:), y (:), z (:), w (:) integer , intent ( OUT ) :: izones (:, :) integer , intent ( OUT ) :: npts npts = grid % npts x = grid % x y = grid % y z = grid % z w = grid % w izones = grid % izones end subroutine getGrid !------------------------------------------------------------------------------- !> @brief Check if it is the grid you are looking for. !> @param[in]   npts  number of points !> @author Vladimir Mironov function checkGrid ( grid , npts ) result ( ok ) class ( grid_3d_t ) :: grid integer , intent ( IN ) :: npts logical :: ok ok = . false . if ( grid % npts == npts ) ok = . true . end function checkGrid !------------------------------------------------------------------------------- !> @brief Destroy grid !> @author Vladimir Mironov subroutine clearGrid ( grid ) class ( grid_3d_t ), intent ( INOUT ) :: grid grid % npts = 0 deallocate ( grid % x , grid % y , grid % z , grid % w ) deallocate ( grid % izones ) end subroutine clearGrid !------------------------------------------------------------------------------- end module mod_grid_storage","tags":"","url":"sourcefile/grid_storage.f90.html"},{"title":"mod_shell_tools.F90 – OpenQP Fortran API","text":"Source Code MODULE mod_shell_tools USE precision , only : dp USE basis_tools , ONLY : basis_set USE constants , ONLY : NUM_CART_BF TYPE shell_t !INTEGER :: shid, atid, ig1, ig2, ang, minbf, maxbf, locao, nao INTEGER :: shid !< shell ID in a basis set INTEGER :: atid !< ID of the corresponding atom INTEGER :: ig1 !< index of the first primitive of the shell in total basis set INTEGER :: ig2 !< index of the last primitive of the shell in total basis set INTEGER :: ang !< angular momentum + 1 INTEGER :: locao !< position of shell's first basis function in the basis set INTEGER :: nao !< number of basis functions (atomic orbitals) in shell INTEGER :: harmonic = 0 !< 1 = pure spherical-harmonic shell, 0 = Cartesian REAL ( kind = dp ) :: r ( 3 ) !< shell origin CONTAINS PROCEDURE :: fetch_by_id => bas_set_indices END TYPE !< @brief Data structure to hold data of primitive shell pair TYPE primpair_t REAL ( kind = dp ) :: r ( 3 ) !< center of charge coordinates REAL ( kind = dp ) :: aa !< sum of exponents REAL ( kind = dp ) :: aa1 !< reverse sum of exponents REAL ( kind = dp ) :: ai !< exponent of the first shell REAL ( kind = dp ) :: aj !< exponent of the second shell REAL ( kind = dp ) :: expfac !< exponential prefactor END TYPE !< @brief Data structure to hold data of contracted shell pair !   I think AoS for primitive pairs would be OK as the only computationally !   intensive part involving primitive pairs formation is not the limiting step. !   There is small benefit in vectorizing 1e integrals: most of them are in fact !   memory bandwidth limited, so it is better to focus on smaller CPU cache footprint. TYPE shpair_t REAL ( kind = dp ) :: ri ( 3 ) !< coordinates of the first shell REAL ( kind = dp ) :: pad1 REAL ( kind = dp ) :: rj ( 3 ) !< coordinates of the second shell REAL ( kind = dp ) :: pad2 INTEGER :: iang !< angular momentum of the first shell INTEGER :: jang !< angular momentum of the second shell INTEGER :: inao !< number of B.F. in the first shell INTEGER :: jnao !< number of B.F. in the second shell INTEGER :: isder !< `isder/=0` if derivatives are computed INTEGER :: numpairs !< number of primitives in shell pair block INTEGER :: nroots LOGICAL :: iandj !< true if first shell is same to second one TYPE ( primpair_t ), ALLOCATABLE :: p (:) !< array of primitive pairs data !dir$ attributes align : 64 :: p CONTAINS PROCEDURE :: alloc => shell_pair_alloc PROCEDURE :: alloc2 => shell_pair_alloc2 PROCEDURE :: shell_pair PROCEDURE :: shell_pair2 END TYPE PRIVATE PUBLIC shell_t PUBLIC shpair_t ! PUBLIC shell_pair ! PUBLIC shell_pair_alloc ! PUBLIC bas_set_indices CONTAINS !> @brief Copy shell info from basis set to shell_t variable !> @param[in]  shid     index of shell in a basis set !> @param[out] shinfo   shell data ! !> @author   Vladimir Mironov ! !     REVISION HISTORY: !> @date _Sep, 2018_ Initial release ! SUBROUTINE bas_set_indices ( shinfo , basis , shid ) !dir$ attributes inline :: bas_set_indices INTEGER , INTENT ( IN ) :: shid type ( basis_set ), INTENT ( IN ) :: basis CLASS ( shell_t ), INTENT ( INOUT ) :: shinfo shinfo % shid = shid shinfo % atid = basis % origin ( shid ) shinfo % ig1 = basis % g_offset ( shid ) shinfo % ig2 = basis % g_offset ( shid ) + basis % ncontr ( shid ) - 1 shinfo % ang = basis % am ( shid ) shinfo % locao = basis % ao_offset ( shid ) shinfo % nao = basis % naos ( shid ) shinfo % harmonic = basis % harmonic ( shid ) shinfo % r = basis % atoms % xyz (:, shinfo % atid ) END SUBROUTINE bas_set_indices !-------------------------------------------------------------------------------- !> @brief Allocate shell pair array of primitives !> @param[out] sp     shell pair data !> @param[in]  basis  basis set ! !> @author   Vladimir Mironov ! !     REVISION HISTORY: !> @date _Oct, 2018_ Initial release ! SUBROUTINE shell_pair_alloc ( sp , basis ) CLASS ( shpair_t ), INTENT ( INOUT ) :: sp type ( basis_set ), INTENT ( IN ) :: basis IF ( allocated ( sp % p ). AND . ubound ( sp % p , 1 ) < basis % mxcontr ** 2 ) DEALLOCATE ( sp % p ) IF (. NOT . allocated ( sp % p )) ALLOCATE ( sp % p ( basis % mxcontr ** 2 )) END SUBROUTINE !-------------------------------------------------------------------------------- !> @brief Allocate shell pair array of primitives !> @param[out] sp     shell pair data !> @param[in]  basis1 first basis set !> @param[in]  basis2 second basis set ! !> @author   Igor S. Gerasimov ! !     REVISION HISTORY: !> @date _Oct, 2022_ Initial release ! SUBROUTINE shell_pair_alloc2 ( sp , basis1 , basis2 ) CLASS ( shpair_t ), INTENT ( INOUT ) :: sp type ( basis_set ), INTENT ( IN ) :: basis1 , basis2 IF ( allocated ( sp % p ). AND . ubound ( sp % p , 1 ) < basis1 % mxcontr * basis2 % mxcontr ) DEALLOCATE ( sp % p ) IF (. NOT . allocated ( sp % p )) ALLOCATE ( sp % p ( basis1 % mxcontr * basis2 % mxcontr )) END SUBROUTINE !-------------------------------------------------------------------------------- !> @brief Generate data for pairwise electronic distributions !> @param[in]  shi      index of the first shell in a basis set !> @param[in]  shj      index of the second shell in a basis set !> @param[in]  tol      cut-off for integrals !> @param[out] pair     shell pair data !> @param[in]  dup      [optional] if `.true.` - multiply prefactors by 2 when `shi==shj` ! !> @author   Vladimir Mironov ! !     REVISION HISTORY: !> @date _Oct, 2018_ Initial release ! SUBROUTINE shell_pair ( pair , basis , shi , shj , tol , dup ) !dir$ attributes inline :: shell_pair CLASS ( shpair_t ), INTENT ( INOUT ) :: pair type ( basis_set ), INTENT ( IN ) :: basis TYPE ( shell_t ), INTENT ( IN ) :: shi , shj REAL ( kind = dp ), INTENT ( IN ) :: tol LOGICAL , INTENT ( IN ), OPTIONAL :: dup REAL ( kind = dp ) :: rr , cci , ccj , aa , fac , ai , aj INTEGER :: ig , jg , jgmax , ij LOGICAL :: iandj , duplicate duplicate = . TRUE . if ( present ( dup )) duplicate = dup rr = sum ( ( shi % r - shj % r ) ** 2 ) pair % ri = shi % r pair % rj = shj % r pair % nroots = ( shi % ang + shj % ang + 1 ) / 2 + 1 iandj = shi % shid == shj % shid pair % iandj = iandj iandj = iandj . AND . duplicate pair % iang = shi % ang pair % jang = shj % ang ! Integral primitives fill Cartesian shell blocks; the component count ! must stay Cartesian even when nao (placement) is the spherical count. pair % inao = NUM_CART_BF ( shi % ang ) pair % jnao = NUM_CART_BF ( shj % ang ) !   I primitive ij = 0 jgmax = shj % ig2 DO ig = shi % ig1 , shi % ig2 ai = basis % ex ( ig ) cci = basis % cc ( ig ) !       J primitive IF ( iandj ) jgmax = ig DO jg = shj % ig1 , jgmax aj = basis % ex ( jg ) ccj = basis % cc ( jg ) aa = ai + aj IF ( ai * aj * rr > tol * aa ) CYCLE ij = ij + 1 ASSOCIATE ( pp => pair % p ( ij )) pp % ai = ai pp % aj = aj pp % aa = aa pp % aa1 = 1 / aa pp % r = ( ai * pair % ri + aj * pair % rj ) * pp % aa1 fac = cci * ccj * exp ( - ai * aj * pp % aa1 * rr ) pp % expfac = fac IF ( iandj ) pp % expfac = 2 * fac END ASSOCIATE END DO IF ( iandj ) pair % p ( ij )% expfac = fac END DO pair % numpairs = ij END SUBROUTINE !-------------------------------------------------------------------------------- !> @brief Generate data for pairwise electronic distributions for basis sets overlapping !> @param[out] pair     shell pair data !> @param[in]  shi      index of the first shell in a first basis set !> @param[in]  shj      index of the second shell in a second basis set !> @param[in]  tol      cut-off for integrals ! !> @author   Igor S. Gerasimov ! !     REVISION HISTORY: !> @date _Oct, 2022_ Initial release ! SUBROUTINE shell_pair2 ( pair , basis1 , basis2 , shi , shj , tol ) !dir$ attributes inline :: shell_pair2 CLASS ( shpair_t ), INTENT ( INOUT ) :: pair type ( basis_set ), INTENT ( IN ) :: basis1 , basis2 TYPE ( shell_t ), INTENT ( IN ) :: shi , shj REAL ( kind = dp ), INTENT ( IN ) :: tol REAL ( kind = dp ) :: rr , cci , ccj , aa , fac , ai , aj INTEGER :: ig , jg , ij rr = sum ( ( shi % r - shj % r ) ** 2 ) pair % ri = shi % r pair % rj = shj % r pair % nroots = ( shi % ang + shj % ang + 1 ) / 2 + 1 pair % iandj = . false . pair % iang = shi % ang pair % jang = shj % ang ! Integral primitives fill Cartesian shell blocks; the component count ! must stay Cartesian even when nao (placement) is the spherical count. pair % inao = NUM_CART_BF ( shi % ang ) pair % jnao = NUM_CART_BF ( shj % ang ) !   I primitive ij = 0 DO ig = shi % ig1 , shi % ig2 ai = basis1 % ex ( ig ) cci = basis1 % cc ( ig ) !       J primitive DO jg = shj % ig1 , shj % ig2 aj = basis2 % ex ( jg ) ccj = basis2 % cc ( jg ) aa = ai + aj IF ( ai * aj * rr > tol * aa ) CYCLE ij = ij + 1 ASSOCIATE ( pp => pair % p ( ij )) pp % ai = ai pp % aj = aj pp % aa = aa pp % aa1 = 1 / aa pp % r = ( ai * pair % ri + aj * pair % rj ) * pp % aa1 fac = cci * ccj * exp ( - ai * aj * pp % aa1 * rr ) pp % expfac = fac END ASSOCIATE END DO END DO pair % numpairs = ij END SUBROUTINE !-------------------------------------------------------------------------------- END MODULE","tags":"","url":"sourcefile/mod_shell_tools.f90.html"},{"title":"dft_gridint_sap.F90 – OpenQP Fortran API","text":"Source Code !> @brief Grid integration of the superposition-of-atomic-potentials (SAP) !>        one-electron operator. !> !> Builds the SAP potential matrix !>     V_{mu,nu} = sum_g w_g phi_mu(r_g) V_SAP(r_g) phi_nu(r_g), !>     V_SAP(r) = sum_A V_A(|r - R_A|) = sum_A -Z_eff&#94;A(|r - R_A|)/|r - R_A|, !> on the existing DFT molecular grid, reusing the AO-on-grid evaluation and !> AO-pruning machinery of mod_dft_gridint (run_grid_aos). The construction !> mirrors the Kohn-Sham matrix accumulation in mod_dft_gridint_energy. !> !> Reference: S. Lehtola, \"Assessment of Initial Guesses for Self-Consistent !> Field Calculations. Superposition of Atomic Potentials: Simple yet !> Efficient\", J. Chem. Theory Comput. 15, 1593 (2019). module mod_dft_gridint_sap use precision , only : fp use mod_dft_gridint , only : xc_engine_t , xc_consumer_t use sap_lut , only : sap_table_t use oqp_linalg implicit none !------------------------------------------------------------------------------- type , extends ( xc_consumer_t ) :: xc_consumer_sap_t real ( kind = fp ), allocatable :: va2 (:,:) !< full SAP matrix accumulator real ( kind = fp ), allocatable :: vmat_ (:,:) !< per-thread pruned block real ( kind = fp ), allocatable :: tmp_ (:,:) !< per-thread scratch ! SAP inputs (read-only during the grid loop) real ( kind = fp ), pointer :: atxyz (:,:) => null () !< atom coordinates (3,nat), bohr integer , allocatable :: atz (:) !< nuclear charge per atom type ( sap_table_t ), pointer :: sap => null () !< radial Z_eff table contains procedure :: parallel_start procedure :: parallel_stop procedure :: resetOrbPointers procedure :: update procedure :: postUpdate procedure :: clean end type !------------------------------------------------------------------------------- private public sap_potential_matrix !------------------------------------------------------------------------------- contains !------------------------------------------------------------------------------- subroutine parallel_start ( self , xce , nthreads ) implicit none class ( xc_consumer_sap_t ), target , intent ( inout ) :: self class ( xc_engine_t ), intent ( in ) :: xce integer , intent ( in ) :: nthreads ! Note: do NOT call self%clean() here -- it would wipe the SAP inputs ! (atxyz/atz/sap) set by the driver before the parallel region. if ( allocated ( self % va2 )) deallocate ( self % va2 ) if ( allocated ( self % vmat_ )) deallocate ( self % vmat_ ) if ( allocated ( self % tmp_ )) deallocate ( self % tmp_ ) allocate ( self % va2 ( xce % numAOs * xce % numAOs , nthreads ) & , self % vmat_ ( xce % numAOs * xce % numAOs , nthreads ) & , self % tmp_ ( xce % numAOs * xce % maxPts , nthreads ) & , source = 0.0d0 ) end subroutine !------------------------------------------------------------------------------- subroutine parallel_stop ( self ) implicit none class ( xc_consumer_sap_t ), intent ( inout ) :: self if ( ubound ( self % va2 , 2 ) /= 1 ) then self % va2 (:, lbound ( self % va2 , 2 )) = sum ( self % va2 , dim = 2 ) end if call self % pe % allreduce ( self % va2 (:, 1 ), size ( self % va2 (:, 1 ))) end subroutine !------------------------------------------------------------------------------- subroutine clean ( self ) implicit none class ( xc_consumer_sap_t ), intent ( inout ) :: self if ( allocated ( self % va2 )) deallocate ( self % va2 ) if ( allocated ( self % vmat_ )) deallocate ( self % vmat_ ) if ( allocated ( self % tmp_ )) deallocate ( self % tmp_ ) if ( allocated ( self % atz )) deallocate ( self % atz ) end subroutine !------------------------------------------------------------------------------- subroutine resetOrbPointers ( self , xce , vmat , tmp , va , myThread ) class ( xc_consumer_sap_t ), target , intent ( inout ) :: self class ( xc_engine_t ), intent ( in ) :: xce real ( kind = fp ), intent ( out ), pointer , optional :: vmat (:,:) real ( kind = fp ), intent ( out ), pointer , optional :: tmp (:,:) real ( kind = fp ), intent ( out ), pointer , optional :: va (:,:) integer , intent ( in ) :: myThread associate ( numAOs => xce % numAOs & , numAOs_p => xce % numAOs_p & , numPts => xce % numPts ) if ( present ( vmat )) & vmat ( 1 : numAOs_p , 1 : numAOs_p ) => self % vmat_ ( 1 : numAOs_p * numAOs_p , myThread ) if ( present ( tmp )) & tmp ( 1 : numAOs_p , 1 : numPts ) => self % tmp_ ( 1 : numAOs_p * numPts , myThread ) if ( present ( va )) & va ( 1 : numAOs , 1 : numAOs ) => self % va2 ( 1 : numAOs * numAOs , myThread ) end associate end subroutine !------------------------------------------------------------------------------- subroutine update ( self , xce , mythread ) implicit none class ( xc_consumer_sap_t ), intent ( inout ) :: self class ( xc_engine_t ), intent ( in ) :: xce integer :: mythread integer :: i , iat real ( kind = fp ) :: vsap , dist , dx , dy , dz real ( kind = fp ), pointer :: vmat (:,:) real ( kind = fp ), pointer :: tmp (:,:) call self % resetOrbPointers ( xce , vmat = vmat , tmp = tmp , myThread = myThread ) associate ( aoV => xce % aoV & , xyzw => xce % xyzw & , wts => xce % wts & , numAOs => xce % numAOs_p & , numPts => xce % numPts ) do i = 1 , numPts vsap = 0.0_fp do iat = 1 , size ( self % atz ) dx = xyzw ( i , 1 ) - self % atxyz ( 1 , iat ) dy = xyzw ( i , 2 ) - self % atxyz ( 2 , iat ) dz = xyzw ( i , 3 ) - self % atxyz ( 3 , iat ) dist = sqrt ( dx * dx + dy * dy + dz * dz ) vsap = vsap + self % sap % potential ( self % atz ( iat ), dist ) end do ! factor 0.5: dsyr2k forms aoV*tmp&#94;T + tmp*aoV&#94;T tmp (:, i ) = 0.5_fp * wts ( i ) * vsap * aoV (:, i ) end do call dsyr2k ( 'U' , 'N' , numAOs , numPts , 1.0_fp , & aoV , numAOs , & tmp , numAOs , & 0.0_fp , vmat , numAOs ) end associate end subroutine !------------------------------------------------------------------------------- subroutine postUpdate ( self , xce , mythread ) implicit none class ( xc_consumer_sap_t ), intent ( inout ) :: self class ( xc_engine_t ), intent ( in ) :: xce integer :: mythread real ( kind = fp ), pointer :: vmat (:,:) real ( kind = fp ), pointer :: va (:,:) call self % resetOrbPointers ( xce , vmat = vmat , va = va , myThread = myThread ) associate ( numAOs => xce % numAOs_p & , indices => xce % indices_p ) if ( xce % skip_p ) then va = va + vmat else va ( indices ( 1 : numAOs ), indices ( 1 : numAOs )) = & va ( indices ( 1 : numAOs ), indices ( 1 : numAOs )) + vmat end if end associate end subroutine !------------------------------------------------------------------------------- !> @brief Compute the SAP potential matrix (packed lower-triangular). !> @param[in]    basis          basis set !> @param[in]    molGrid        molecular grid !> @param[out]   vsap_tri       packed (lower-triangular) SAP matrix, nbf*(nbf+1)/2 !> @param[in]    nbf            number of basis functions !> @param[in]    sap            radial Z_eff table !> @param[in]    infos          calculation information subroutine sap_potential_matrix ( basis , molGrid , vsap_tri , nbf , sap , infos ) use mod_dft_molgrid , only : dft_grid_t use basis_tools , only : basis_set use mod_dft_gridint , only : xc_options_t , run_grid_aos use types , only : information implicit none type ( dft_grid_t ), target , intent ( in ) :: molGrid type ( information ), target , intent ( in ) :: infos type ( basis_set ) :: basis integer , intent ( in ) :: nbf real ( kind = fp ), intent ( out ) :: vsap_tri ( * ) type ( sap_table_t ), target , intent ( in ) :: sap type ( xc_consumer_sap_t ) :: dat type ( xc_options_t ) :: xc_opts integer :: i0 , i , maxl , nang , nat nat = infos % mol_prop % natom maxl = maxval ( basis % am ) nang = maxl + 1 + 1 xc_opts % isGGA = . false . xc_opts % needTau = . false . xc_opts % hasBeta = . false . xc_opts % isWFVecs = . false . xc_opts % numAOs = nbf xc_opts % maxPts = molGrid % maxSlicePts xc_opts % limPts = molGrid % maxNRadTimesNAng xc_opts % numAtoms = nat xc_opts % maxAngMom = nang xc_opts % nDer = 0 xc_opts % numOccAlpha = infos % mol_prop % nelec_A xc_opts % numOccBeta = infos % mol_prop % nelec_B xc_opts % molGrid => molGrid xc_opts % dft_threshold = infos % dft % grid_density_cutoff xc_opts % ao_threshold = infos % dft % grid_ao_threshold ! Disable AO-space pruning: the engine's pruned-AO path compresses the ! wavefunction (wfAlpha), which the SAP guess does not provide. Keeping all ! AOs (skip_p always true) avoids that path at a small performance cost. xc_opts % ao_sparsity_ratio = 0.0_fp ! SAP inputs dat % atxyz => infos % atoms % xyz dat % sap => sap allocate ( dat % atz ( nat )) do i = 1 , nat dat % atz ( i ) = nint ( infos % atoms % zn ( i )) end do call dat % pe % init ( infos % mpiinfo % comm , infos % mpiinfo % usempi ) call run_grid_aos ( xc_opts , dat , basis ) ! Pack accumulated (raw-normalized) matrix into lower triangle, applying ! the basis-function normalization, exactly as in dmatd_blk. i0 = 0 do i = 1 , nbf vsap_tri ( i0 + 1 : i0 + i ) = dat % va2 (( i - 1 ) * nbf + 1 :( i - 1 ) * nbf + i , 1 ) & * basis % bfnrm ( i ) * basis % bfnrm ( 1 : i ) i0 = i0 + i end do call dat % clean () end subroutine !------------------------------------------------------------------------------- end module mod_dft_gridint_sap","tags":"","url":"sourcefile/dft_gridint_sap.f90.html"},{"title":"dft_molgrid.F90 – OpenQP Fortran API","text":"Source Code module mod_dft_molgrid use precision , only : fp , dp use mod_grid_storage , only : list_grid_3d_t , grid_3d_t use lebedev , only : lebedev_get_grid use bragg_slater_radii , only : BRSL_NUM_ELEMENTS implicit none integer , parameter :: DEFAULT_NSLICES_PER_ATOM = 100 integer , parameter :: MAXGRID = 10 real ( kind = fp ), parameter :: GROWTH_FACTOR = 1.5 integer , parameter :: ALLOC_PAD = 4 integer , parameter :: MAXDEPTH = 2 real ( KIND = fp ), parameter :: HUGEFP = huge ( 1.0_fp ) type , extends ( list_grid_3d_t ) :: sorted_grid_t !< Array to store vertices for triangulation of sphere, for internal use real ( KIND = fp ), allocatable :: triangles (:, :, :, :) contains procedure :: add_grid => get_sorted_lebedev_pts procedure :: init => initSortedListGrid end type !> @brief Type to store molecular grid information type :: dft_grid_t !< current number of slices integer :: nSlices = 0 !< maximum number of slices integer :: maxSlices = 0 !< maximum number of grid points per atom integer :: maxAtomPts = 0 !< maximum number of nonzero grid points per slice integer :: maxSlicePts = 0 !< maximum possible number of grid points per slice integer :: maxNRadTimesNAng = 0 !< total number of nonzero grid points integer :: nMolPts = 0 !< spherical atomic grids used in this molecular grid type ( sorted_grid_t ) :: spherical_grids ! Every slice is a spacially localized subgrid of molecular grid: ! slice = (few radial points)x(few angular points) ! The following arrays contains data for each slice !< index of angular grid integer , allocatable :: idAng (:) !< index of the first point in angular grid array integer , allocatable :: iAngStart (:) !< number of angular grid points integer , allocatable :: nAngPts (:) !< index of the first point in radial grid array integer , allocatable :: iRadStart (:) !< number of radial grid points integer , allocatable :: nRadPts (:) !< number of grid points with nonzero weight integer , allocatable :: nTotPts (:) !< index of atom which owns the slice integer , allocatable :: idOrigin (:) !< type of chunk -- used for different processing integer , allocatable :: chunkType (:) !< index of the first point in weights array integer , allocatable :: wtStart (:) !< isInner == 1 means that the slice is 'inner' -- i.e. its weight is not modified and is equal to wtRad*wtAng integer , allocatable :: isInner (:) ! The following arrays contains information about atoms !< effective radii of atoms real ( KIND = fp ), allocatable :: rAtm (:) !< max radii for 'inner' points real ( KIND = fp ), allocatable :: rInner (:) !< .TRUE. for dummy atoms logical , allocatable :: dummyAtom (:) ! The following arrays contains information about the radial grid(s). ! Several radial grids (\"radial types\") may coexist: column iTyp of ! rad_pts/rad_wts is the radial grid of type iTyp, and radTypeId(iAtm) ! selects the column used by atom iAtm.  Type 1 is the standard grid; ! per-element grids (e.g. the SG-2/SG-3 double-exponential grids) are ! stored in additional columns. !< Radial grid points: (radial point, radial type) real ( KIND = fp ), allocatable :: rad_pts (:,:) !< Radial grid weights: (radial point, radial type) real ( KIND = fp ), allocatable :: rad_wts (:,:) !< radial grid type (column of rad_pts/rad_wts) of each atom integer , allocatable :: radTypeId (:) !< array to store grid point weights real ( KIND = fp ), allocatable :: totWts (:, :) !< number of nonzero grid points per atom integer , allocatable , private :: wt_top (:) contains procedure , pass :: getSliceData => getSliceData procedure , pass :: getSliceNonZero => getSliceNonZero procedure , pass :: exportGrid => exportGrid procedure , pass :: setSlice => setSlice procedure , pass :: reset => reset_dft_grid_t procedure , pass :: compress => compress_dft_grid_t procedure , pass :: extend => extend_dft_grid_t procedure , pass :: add_atomic_grid => add_atomic_grid procedure , pass :: add_slices => add_slices procedure , pass :: find_neighbours => find_neighbours end type dft_grid_t private public dft_grid_t contains !******************************************************************************* ! Legacy Fortran wrappers !------------------------------------------------------------------------------- !> @brief Initialize grid list, possibly specifying its size !> @param[in]  iSize   desired list size !> @author Vladimir Mironov subroutine initSortedListGrid ( list , iSize ) class ( sorted_grid_t ) :: list integer , optional , intent ( IN ) :: iSize integer :: ntrngoct , ntrng , i ntrngoct = 4 ** MAXDEPTH ntrng = 8 * ntrngoct if (. not . allocated ( list % triangles )) then allocate ( list % triangles ( 3 , 3 , ntrng , MAXDEPTH + 1 )) do i = 1 , MAXDEPTH + 1 call triangulate_sphere ( list % triangles (:, :, :, i ), i - 1 ) end do end if call list % list_grid_3d_t % init ( iSize ) end subroutine !> @brief Clear grid list !> @author Vladimir Mironov subroutine clearSortedListGrid ( list ) class ( sorted_grid_t ) :: list if ( allocated ( list % triangles )) deallocate ( list % triangles ) call list % list_grid_3d_t % clear () end subroutine !> @brief Find nearest neghbours of every atom and the corresponding distance !>  The results are stored into `grid` dataset !> @details This is needed for screening inner points in SSF variant of !>  Becke's fuzzy cell method !> @param[in]    rij       array of interatomic distances !> @param[in]    nAt       number of atoms !> @author Vladimir Mironov subroutine find_neighbours ( grid , rij , partFunType ) use mod_dft_partfunc , only : partition_function class ( dft_grid_t ) :: grid integer , intent ( IN ) :: partFunType real ( KIND = fp ), intent ( IN ) :: rij (:,:) type ( partition_function ) :: partFunc integer :: nAt , i , j real ( KIND = fp ) :: distNN call partFunc % set ( partFunType ) nAt = ubound ( rij , 1 ) do j = 1 , nAt !     Find distance to the nearest neghbour of current atom distNN = HUGEFP do i = 1 , nAt if ( grid % dummyAtom ( i ) . or . i == j ) cycle distNN = min ( distNN , rij ( i , j )) end do grid % rInner ( j ) = 0.5 * distNN * ( 1.0 - partFunc % limit ) end do end subroutine !> @brief Get spherical Lebedev grid of nReq number of points !> @details If the grid is not yet computed, then compute it, !>  sort according to pre-defined triangulation scheme and save !>  the result for later use. If the same grid was already computed, !>  fetch it from the in-memory storage !> @author Vladimir Mironov subroutine get_sorted_lebedev_pts ( grids , nreq ) class ( sorted_grid_t ), intent ( inout ) :: grids integer , intent ( IN ) :: nreq real ( KIND = fp ), allocatable :: xyz (:,:), w (:) integer , allocatable :: icnt (:, :) type ( grid_3d_t ), pointer :: curGrid allocate ( icnt ( 8 * 4 ** MAXDEPTH , MAXDEPTH + 2 )) curGrid => grids % get ( nreq ) if ( associated ( curGrid )) return allocate ( xyz ( nreq , 3 ), w ( nreq ), source = 0.0d0 ) call lebedev_get_grid ( nreq , xyz , w ) call tesselate_layer ( xyz (:, 1 ), xyz (:, 2 ), xyz (:, 3 ), w , nreq , icnt , grids % triangles ) curGrid => grids % set ( & grid_3d_t ( x = xyz (:, 1 ), & y = xyz (:, 2 ), & z = xyz (:, 3 ), & w = w , & npts = nreq , & izones = int ( icnt , 2 )) & ) end subroutine !> @brief Append slice data of an atom to `grid` arrays !> @param[in]   idAtom      index of current atom !> @param[in]   layers      meta-data for atom grid layers: radial grid, angular grid, and angular grid separation depth !> @param[in]   nLayers     number of atom grid layers !> @param[in]   rAtm        effective radius of current atom !> @author Vladimir Mironov subroutine add_slices ( grid , idAtm , layers , nLayers , rAtm ) class ( dft_grid_t ) :: grid integer , intent ( IN ) :: idAtm , layers (:, :), nLayers real ( KIND = fp ), intent ( IN ) :: rAtm integer :: i , j , ilen , idrad0 , idrad1 , idang0 , idang1 , nAngTr , nPtSlc , depth type ( grid_3d_t ), pointer :: curAng idrad1 = 0 do i = 1 , nLayers associate ( & nCur => grid % nSlices , & maxSlices => grid % maxSlices , & nextRad => layers ( 1 , i ), & depth0 => layers ( 3 , i ), & wtTopAtm => grid % wt_top ( idAtm )) curAng => grid % spherical_grids % get ( layers ( 2 , i )) idrad0 = idrad1 + 1 idrad1 = nextRad depth = depth0 if ( grid % rad_pts ( idrad0 , grid % radTypeId ( idAtm )) < 2.0 . and . depth == - 1 ) then if ( curAng % npts * ( idrad1 - idrad0 + 1 ) >= 10 * 32 ) then depth = 1 else if ( curAng % npts * ( idrad1 - idrad0 + 1 ) >= 10 * 8 ) then depth = 0 end if end if select case ( depth ) case ( - 1 ) nPtSlc = ( idrad1 - idrad0 + 1 ) * curAng % nPts if ( nPtSlc == 0 ) cycle if ( nCur == maxSlices ) call grid % extend nCur = nCur + 1 call grid % setSlice ( nCur , & idrad0 , idrad1 - idrad0 + 1 , & curAng % idGrid , 1 , curAng % nPts , & wtTopAtm + 1 , & idAtm , rAtm , 0 ) wtTopAtm = wtTopAtm + nPtSlc case ( 0 : 3 ) ilen = 4 ** depth idang1 = 0 do j = 1 , 8 * ilen nAngTr = curAng % izones ( j , depth + 2 ) if ( nAngTr == 0 ) cycle if ( nCur == maxSlices ) call grid % extend nCur = nCur + 1 idang0 = idang1 + 1 idang1 = idang0 + nAngTr - 1 nPtSlc = nAngTr * ( idrad1 - idrad0 + 1 ) call grid % setSlice ( nCur , & idrad0 , idrad1 - idrad0 + 1 , & curAng % idGrid , idAng0 , nAngTr , & wtTopAtm + 1 , & idAtm , rAtm , 1 ) wtTopAtm = wtTopAtm + nPtSlc end do case DEFAULT nPtSlc = ( idRad1 - idRad0 + 1 ) * curAng % nPts if ( nPtSlc == 0 ) cycle if ( nCur == maxSlices ) call grid % extend nCur = nCur + 1 call grid % setSlice ( nCur , & idrad0 , idrad1 - idrad0 + 1 , & curAng % idGrid , 1 , curAng % nPts , & wtTopAtm + 1 , & idAtm , rAtm , 2 ) wtTopAtm = wtTopAtm + nPtSlc end select end associate end do end subroutine !> @brief Split atomic 3D grid on spacially localized clusters (\"slices\") !>  and appended the data to `grid` dataset !> @details First, decompose atomic grid on layers, depending on the pruning !>  scheme and the distance from the nuclei. It is done in this procedure. !>  Then, split layers on slices and append their data to the `grid` !>  dataset. It is done by calling subroutine `addSlices`. !> @param[in]   idAtm       index of current atom !> @param[in]   nGrids      number of grids in pruning scheme !> @param[in]   rAtm        effective radius of current atom !> @param[in]   pruneRads   radii of the pruning scheme !> @author Vladimir Mironov subroutine add_atomic_grid ( grid , atomic_grid ) use mod_grid_storage , only : atomic_grid_t class ( dft_grid_t ) :: grid type ( atomic_grid_t ) :: atomic_grid real ( KIND = fp ), parameter :: EPS = tiny ( 0.0_fp ) integer , parameter :: depths ( 5 ) = [ - 1 , 0 , 1 , 1 , 1 ] real ( KIND = fp ), parameter :: stepSz ( 5 ) = [ 1.0 , 1.5 , 4.0 , 8.0 , 1 6.0 ] real ( KIND = fp ) :: limits ( 5 ) integer :: i , nLayers , nGrids , iSpl , iRMin , iRMax , iRNext , nRad !, k integer :: idAtm real ( KIND = fp ) :: rAtm , rMin , rMax , rNext logical :: by_index integer :: layers ( 3 , MAXGRID * 5 ) idAtm = atomic_grid % idAtm nRad = ubound ( atomic_grid % rad_pts , 1 ) nGrids = ubound ( atomic_grid % sph_npts , 1 ) rAtm = atomic_grid % rAtm !   Index-based pruning sectors (e.g. SG-2/SG-3): region i spans the !   next sph_nrad(i) radial shells instead of all shells up to radius !   sph_radii(i) by_index = allocated ( atomic_grid % sph_nrad ) limits = [ 1.0 , 2.0 , 8.0 , 1 2.0 , 2 0.0 ] if ( grid % rInner ( idAtm ) /= 0.0_fp ) then limits ( 1 ) = grid % rInner ( idAtm ) + EPS end if nLayers = 0 iRMax = 0 iRNext = 0 do i = 1 , nGrids iRMin = iRMax + 1 ! No radial points left for this and the following regions ! (e.g. pruned-grid region boundaries beyond the radial grid) if ( iRMin > nRad ) exit if ( by_index ) then iRMax = min ( nRad , iRMin + atomic_grid % sph_nrad ( i ) - 1 ) else iRMax = findl ( atomic_grid % sph_radii ( i ), atomic_grid % rad_pts , iRMin ) end if if ( nGrids == 1 ) iRMax = nRad if ( i == nGrids ) iRMax = nRad rMin = rAtm * atomic_grid % rad_pts ( iRMin ) rMax = rAtm * atomic_grid % rad_pts ( iRMax ) iSpl = findl ( rMin , limits , 1 ) rNext = rMin do rNext = min ( rMax , rNext + stepSz ( iSpl )) iRNext = min ( iRMax , findl ( rNext / rAtm , atomic_grid % rad_pts , iRNext + 1 )) nLayers = nLayers + 1 layers ( 1 , nLayers ) = iRNext layers ( 2 , nLayers ) = atomic_grid % sph_npts ( i ) layers ( 3 , nLayers ) = depths ( iSpl ) if ( rNext >= limits ( iSpl )) iSpl = min ( iSpl + 1 , size ( stepSz )) if ( iRNext == iRMax ) exit end do end do call grid % add_slices ( idAtm , layers , nLayers , rAtm ) contains !> @brief Find the location of the largest element in !>  sorted (in ascending order) real-valued array, !>  which is smaller than the specified value. Return last array index !>  if `ALL(X>=V)` !> @note Linear search is used due to problem specifics: !>  tiny arrays and sequential access !> @param[in]   x       value to found !> @param[in]   v       sorted real array !> @param[in]   hint    the index from which the lookup is started !> @author Vladimir Mironov function findl ( x , v , hint ) result ( id ) integer :: id integer :: hint real ( KIND = fp ) :: x , v (:) do id = max ( lbound ( v , 1 ), hint ), ubound ( v , 1 ) if ( x < v ( id )) return end do id = ubound ( v , 1 ) end function end subroutine !> @brief Split spherical grid on localized clusters of points !> @param[inout] xs     grid point X coordinates !> @param[inout] ys     grid point Y coordinates !> @param[inout] zs     grid point Z coordinates !> @param[inout] wt     grid point weights !> @param[in]    npts   number of points !> @param[out]   icnts  sizes of clusters !> @author Vladimir Mironov subroutine tesselate_layer ( xs , ys , zs , wt , npts , icnts , triangles ) real ( KIND = fp ), intent ( INOUT ) :: xs (:), ys (:), zs (:) real ( KIND = fp ), intent ( INOUT ) :: wt (:) real ( KIND = fp ), target , intent ( in ) :: triangles (:, :, :, :) integer , intent ( IN ) :: npts integer , intent ( OUT ) :: icnts (:, - 1 :) real ( KIND = fp ), allocatable :: tmp (:, :, :) integer :: i , j , itrng , itrngoct , ntrng , ntrngoct , m1 , m2 , m3 , i0 , i1 , ilen real ( KIND = fp ), pointer :: trng (:, :, :) ntrngoct = 4 ** MAXDEPTH ntrng = 8 * ntrngoct trng => triangles (:, :, :, MAXDEPTH + 1 ) allocate ( tmp ( size ( xs , dim = 1 ), 4 , ntrng )) icnts ( 1 : ntrng , :) = 0 associate ( icnt => icnts (:, MAXDEPTH )) do i = 1 , npts associate ( x => xs ( i ), y => ys ( i ), z => zs ( i ), w => wt ( i )) !        Find the octant of this point m1 = int ( sign ( 0.5_fp , x ) + 0.5 ) m2 = int ( sign ( 0.5_fp , y ) + 0.5 ) m3 = int ( sign ( 0.5_fp , z ) + 0.5 ) itrngoct = 8 - ( m1 + 2 * m2 + 4 * m3 ) do itrng = ntrngoct * ( itrngoct - 1 ) + 1 , ntrngoct * itrngoct !           If point is on the boundary between two cells - first !           one gets it if ( is_vector_inside_shape ([ x , y , z ], trng (:, :, itrng ))) exit end do icnt ( itrng ) = icnt ( itrng ) + 1 tmp ( icnt ( itrng ), 1 , itrng ) = x tmp ( icnt ( itrng ), 2 , itrng ) = y tmp ( icnt ( itrng ), 3 , itrng ) = z tmp ( icnt ( itrng ), 4 , itrng ) = w end associate end do i0 = 0 do i = 1 , ntrng i1 = i0 + icnt ( i ) xs ( i0 + 1 : i1 ) = tmp ( 1 : icnt ( i ), 1 , i ) ys ( i0 + 1 : i1 ) = tmp ( 1 : icnt ( i ), 2 , i ) zs ( i0 + 1 : i1 ) = tmp ( 1 : icnt ( i ), 3 , i ) wt ( i0 + 1 : i1 ) = tmp ( 1 : icnt ( i ), 4 , i ) i0 = i1 end do end associate do i = MAXDEPTH - 1 , 0 , - 1 ilen = 4 ** i do j = 1 , 8 * ilen icnts ( j , i ) = sum ( icnts (( j - 1 ) * 4 + 1 : j * 4 , i + 1 )) end do end do icnts ( 1 , - 1 ) = npts deallocate ( tmp ) end subroutine !> @brief Compute triangulation map of the sphere !> @details This subroutine returns inscribed polyhedron with triangular !>  faces and octahedral symmetry. Polyhedron faces are computed by recursive !>  subdivision of the octahedron faces on four spherical !>  equilateral triangles. !> @param[in]   depth   depth of recursion !> @param[out]  vect    vertices of triangles !> @author Vladimir Mironov subroutine triangulate_sphere ( vect , depth ) integer , intent ( IN ) :: depth real ( KIND = fp ), intent ( OUT ) :: vect ( 3 , 3 , * ) real ( KIND = fp ), dimension ( 3 ) :: v1 , v2 , v3 real ( KIND = fp ), parameter :: xf ( 8 ) = [ 1 , - 1 , 1 , - 1 , 1 , - 1 , 1 , - 1 ] real ( KIND = fp ), parameter :: yf ( 8 ) = [ 1 , 1 , - 1 , - 1 , 1 , 1 , - 1 , - 1 ] real ( KIND = fp ), parameter :: zf ( 8 ) = [ 1 , 1 , 1 , 1 , - 1 , - 1 , - 1 , - 1 ] integer :: ip integer :: i , ip0 , ip1 ip = 0 !   Fill in first octant v1 = [ 1.0 , 0.0 , 0.0 ] v2 = [ 0.0 , 1.0 , 0.0 ] v3 = [ 0.0 , 0.0 , 1.0 ] call subdivide_triangle ( v1 , v2 , v3 , vect , ip , depth ) !   Fill in other octants - use octaherdal symmetry of the polyhedron do i = 2 , 8 ip0 = ( i - 1 ) * ip + 1 ip1 = i * ip vect ( 1 , 1 : 3 , ip0 : ip1 ) = xf ( i ) * vect ( 1 , 1 : 3 , 1 : ip ) vect ( 2 , 1 : 3 , ip0 : ip1 ) = yf ( i ) * vect ( 2 , 1 : 3 , 1 : ip ) vect ( 3 , 1 : 3 , ip0 : ip1 ) = zf ( i ) * vect ( 3 , 1 : 3 , 1 : ip ) end do end subroutine !> @brief Recursively subdivide spherical triangle on four equal triangles !> @param[in]       v1      vertex of initial triangle !> @param[in]       v2      vertex of initial triangle !> @param[in]       v3      vertex of initial triangle !> @param[inout]    res     stack of triangles; dim: (xyz,vertices,triangles) !> @param[in]       ip      index of the last triangle on stack !> @param[in]       depth   current depth of recursion !> @author Vladimir Mironov recursive subroutine subdivide_triangle ( v1 , v2 , v3 , res , ip , depth ) integer , intent ( IN ) :: depth integer , intent ( INOUT ) :: ip real ( KIND = 8 ), intent ( IN ) :: v1 ( 3 ), v2 ( 3 ), v3 ( 3 ) real ( KIND = 8 ), intent ( INOUT ) :: res ( 3 , 3 , * ) real ( KIND = 8 ) :: c1 ( 3 ), c2 ( 3 ), c3 ( 3 ) if ( depth < 0 . or . depth > MAXDEPTH ) then write ( * , * ) 'DEPTH=' , depth , ' IS .GT. MAXDEPTH=' , MAXDEPTH end if if ( depth == 0 ) then !     add lowest level triangle to the result array ip = ip + 1 res (:, 1 , ip ) = v1 res (:, 2 , ip ) = v2 res (:, 3 , ip ) = v3 return end if !   find centers of arcs between input vectors c1 = v1 + v2 c2 = v2 + v3 c3 = v1 + v3 c1 = c1 / sqrt ( sum ( c1 * c1 )) c2 = c2 / sqrt ( sum ( c2 * c2 )) c3 = c3 / sqrt ( sum ( c3 * c3 )) !   subdivide the resulting four triangles call subdivide_triangle ( v1 , c1 , c3 , res , ip , depth - 1 ) call subdivide_triangle ( c1 , v2 , c2 , res , ip , depth - 1 ) call subdivide_triangle ( c3 , c2 , v3 , res , ip , depth - 1 ) call subdivide_triangle ( c1 , c2 , c3 , res , ip , depth - 1 ) end subroutine !> @brief Clean up `grid` dataset and reallocate arrays if needed !> @param[in]   maxSlices   guess for maximum number of slices !> @param[in]   nAt         number of atoms in a system !> @param[in]   maxPtPerAt  maximum number of points per atom !> @param[in]   nRad        size of the radial grid !> @param[in]   nRadTypes   number of distinct radial grids (default 1) !> @author Vladimir Mironov subroutine reset_dft_grid_t ( grid , nAt , maxPtPerAt , nRad , nRadTypes ) class ( dft_grid_t ), intent ( INOUT ) :: grid integer , intent ( IN ) :: nAt , maxPtPerAt , nRad integer , intent ( IN ), optional :: nRadTypes integer :: maxSlices , nRadTypes_ maxSlices = DEFAULT_NSLICES_PER_ATOM * nAt if ( grid % maxSlices < maxSlices ) then grid % maxSlices = maxSlices if ( allocated ( grid % idAng )) then deallocate ( grid % idAng , grid % iAngStart , grid % nAngPts , & grid % iRadStart , grid % nRadPts , grid % nTotPts , & grid % idOrigin , grid % chunkType , grid % rAtm , & grid % wtStart , grid % isInner ) end if allocate ( grid % idAng ( maxSlices ), source = 0 ) allocate ( grid % iAngStart ( maxSlices ), source = 0 ) allocate ( grid % nAngPts ( maxSlices ), source = 0 ) allocate ( grid % iRadStart ( maxSlices ), source = 0 ) allocate ( grid % nRadPts ( maxSlices ), source = 0 ) allocate ( grid % nTotPts ( maxSlices ), source = 0 ) allocate ( grid % idOrigin ( maxSlices ), source = 0 ) allocate ( grid % chunkType ( maxSlices ), source = 0 ) allocate ( grid % rAtm ( maxSlices ), source = 0.0_fp ) allocate ( grid % wtStart ( maxSlices ), source = 0 ) allocate ( grid % isInner ( maxSlices ), source = 0 ) end if !   Initialize spherical grids storage call grid % spherical_grids % init () !   Initialize radial grids storage nRadTypes_ = 1 if ( present ( nRadTypes )) nRadTypes_ = max ( 1 , nRadTypes ) if ( allocated ( grid % rad_pts )) deallocate ( grid % rad_pts ) if ( allocated ( grid % rad_wts )) deallocate ( grid % rad_wts ) if ( allocated ( grid % radTypeId )) deallocate ( grid % radTypeId ) allocate ( grid % rad_pts ( nRad , nRadTypes_ ), source = 0.0_fp ) allocate ( grid % rad_wts ( nRad , nRadTypes_ ), source = 0.0_fp ) allocate ( grid % radTypeId ( nAt ), source = 1 ) if ( allocated ( grid % totWts )) deallocate ( grid % totWts ) if ( allocated ( grid % wt_top )) deallocate ( grid % wt_top ) allocate ( grid % totWts ( maxPtPerAt , nAt ), source = 0.0_fp ) allocate ( grid % wt_top ( nAt ), source = 0 ) if ( allocated ( grid % rInner )) deallocate ( grid % rInner ) if ( allocated ( grid % dummyAtom )) deallocate ( grid % dummyAtom ) allocate ( grid % rInner ( nAt ), source = 0.0_fp ) allocate ( grid % dummyAtom ( nAt ), source = . false .) grid % maxAtomPts = maxPtPerAt grid % maxSlicePts = 0 grid % maxNRadTimesNAng = 0 grid % nSlices = 0 grid % nMolPts = 0 end subroutine reset_dft_grid_t !> @brief Compress the grid for eaach atom !> @note This is a very basic implementation and it will be changed in future !> @author Vladimir Mironov subroutine compress_dft_grid_t ( grid ) class ( dft_grid_t ), intent ( INOUT ) :: grid integer :: i integer :: iCur , nPts integer , allocatable :: iCurWt (:) allocate ( iCurWt ( ubound ( grid % totWts , 2 ))) iCur = 0 iCurWt = 1 do i = 1 , grid % nSlices if ( grid % nTotPts ( i ) > 0 ) then iCur = iCur + 1 grid % idAng ( iCur ) = grid % idAng ( i ) grid % iAngStart ( iCur ) = grid % iAngStart ( i ) grid % nAngPts ( iCur ) = grid % nAngPts ( i ) grid % iRadStart ( iCur ) = grid % iRadStart ( i ) grid % nRadPts ( iCur ) = grid % nRadPts ( i ) grid % idOrigin ( iCur ) = grid % idOrigin ( i ) grid % chunkType ( iCur ) = grid % chunkType ( i ) grid % rAtm ( iCur ) = grid % rAtm ( i ) grid % isInner ( iCur ) = grid % isInner ( i ) grid % nTotPts ( iCur ) = grid % nTotPts ( i ) associate ( totWts => grid % totWts , & iAt => grid % idOrigin ( i ), wt0 => grid % wtStart ( i ), & nAng => grid % nAngPts ( i ), nRad => grid % nRadPts ( i )) nPts = nAng * nRad totWts ( iCurWt ( iAt ): iCurWt ( iAt ) + nPts - 1 , iAt ) = & totWts ( wt0 : wt0 + nPts - 1 , iAt ) grid % wtStart ( iCur ) = iCurWt ( iAt ) iCurWt ( iAt ) = iCurWt ( iAt ) + nPts end associate end if end do grid % nSlices = iCur deallocate ( iCurWt ) end subroutine compress_dft_grid_t !> @brief Extend arrays in molecular grid type !> @author Vladimir Mironov subroutine extend_dft_grid_t ( grid ) class ( dft_grid_t ), intent ( INOUT ) :: grid integer :: maxSlices maxSlices = int ( ( grid % maxSlices + 1 ) * GROWTH_FACTOR ) maxSlices = ( ( maxSlices - 1 ) / ALLOC_PAD + 1 ) * ALLOC_PAD call reallocate_int ( grid % idAng , maxSlices ) call reallocate_int ( grid % iAngStart , maxSlices ) call reallocate_int ( grid % nAngPts , maxSlices ) call reallocate_int ( grid % iRadStart , maxSlices ) call reallocate_int ( grid % nRadPts , maxSlices ) call reallocate_int ( grid % nTotPts , maxSlices ) call reallocate_int ( grid % idOrigin , maxSlices ) call reallocate_int ( grid % chunkType , maxSlices ) call reallocate_int ( grid % wtStart , maxSlices ) call reallocate_int ( grid % isInner , maxSlices ) call reallocate_real ( grid % rAtm , maxSlices ) grid % maxSlices = maxSlices contains !> @brief Extend allocatable array of integers to a new size !> @param[inout]  v         the array !> @param[in]     newsz     new size of the array !> @author Vladimir Mironov subroutine reallocate_int ( v , newsz ) integer , allocatable , intent ( INOUT ) :: v (:) integer , intent ( IN ) :: newsz integer , allocatable :: nv (:) if ( allocated ( v )) then allocate ( nv ( 1 : newsz ), source = v ) call move_alloc ( from = nv , to = v ) end if end subroutine reallocate_int !> @brief Extend allocatable array of integers to a new size !> @param[inout]  v         the array !> @param[in]     newsz     new size of the array !> @author Vladimir Mironov subroutine reallocate_real ( v , newsz ) real ( kind = fp ), allocatable , intent ( INOUT ) :: v (:) integer , intent ( IN ) :: newsz real ( kind = fp ), allocatable :: nv (:) if ( allocated ( v )) then allocate ( nv ( 1 : newsz ), source = v ) call move_alloc ( from = nv , to = v ) end if end subroutine reallocate_real end subroutine extend_dft_grid_t !> @brief Get coordinates and weight for quadrature points, which !>   belong to a slice !> @param[in]     iSlice    index of a slice !> @param[out]    xyzw      coordinates and weights !> @author Vladimir Mironov subroutine getSliceData ( grid , iSlice , xyzw ) class ( dft_grid_t ), intent ( IN ) :: grid integer , intent ( IN ) :: iSlice real ( KIND = fp ), contiguous , intent ( OUT ) :: xyzw (:, :) real ( KIND = fp ), parameter :: FOUR_PI = 4.0_fp * 3.141592653589793238463_fp type ( grid_3d_t ), pointer :: curGrid integer :: iAng , iRad , iPt real ( KIND = fp ) :: r1 curGrid => grid % spherical_grids % getbyid ( grid % idAng ( iSlice )) associate ( & rad => grid % rAtm ( iSlice ), & isInner => grid % isInner ( iSlice ), & wtStart => grid % wtStart ( iSlice ) - 1 , & curAt => grid % idOrigin ( iSlice ), & iTyp => grid % radTypeId ( grid % idOrigin ( iSlice )), & iAngStart => grid % iAngStart ( iSlice ), & iRadStart => grid % iRadStart ( iSlice ), & nAngPts => grid % nAngPts ( iSlice ), & nRadPts => grid % nRadPts ( iSlice )) associate ( & xAng => curGrid % x ( iAngStart : iAngStart + nAngPts - 1 ), & yAng => curGrid % y ( iAngStart : iAngStart + nAngPts - 1 ), & zAng => curGrid % z ( iAngStart : iAngStart + nAngPts - 1 ), & wAng => curGrid % w ( iAngStart : iAngStart + nAngPts - 1 )) do iAng = 1 , nAngPts do iRad = 1 , nRadPts r1 = rad * grid % rad_pts ( iRadStart + iRad - 1 , iTyp ) iPt = ( iAng - 1 ) * nRadPts + iRad xyzw ( iPt , 1 ) = r1 * xAng ( iAng ) xyzw ( iPt , 2 ) = r1 * yAng ( iAng ) xyzw ( iPt , 3 ) = r1 * zAng ( iAng ) if ( isInner == 0 ) then xyzw ( iPt , 4 ) = grid % totWts ( wtStart + iPt , curAt ) else xyzw ( iPt , 4 ) = FOUR_PI * rad * rad * rad * & grid % rad_wts ( iRadStart + iRad - 1 , iTyp ) * wAng ( iAng ) end if end do end do end associate end associate end subroutine !> @brief Export grid for use in legacy TD-DFT code !> @param[out]   xyz       coordinates of grid points !> @param[out]   w         weights of grid points !> @param[out]   kcp       atoms, which the points belongs to !> @param[out]   npts      number of nonzero point !> @param[in]    cutoff    cutoff to skip small weights !> @author Vladimir Mironov subroutine exportGrid ( grid , xyz , w , kcp , c , npts , cutoff ) class ( dft_grid_t ), intent ( IN ) :: grid real ( KIND = fp ), intent ( OUT ) :: xyz ( 3 , * ), w ( * ) real ( KIND = fp ), intent ( in ) :: c ( 3 , * ) integer , intent ( OUT ) :: kcp ( * ) integer , intent ( OUT ) :: npts real ( KIND = fp ), intent ( IN ) :: cutoff integer :: iSlice , iPt , iPtOld , nPt , iAt real ( KIND = fp ), allocatable :: xyzw (:, :) iPt = 0 !$omp parallel private(xyzw, iSlice, nPt, iPtOld, iAt) allocate ( xyzw ( grid % maxSlicePts , 4 )) !$omp do schedule(dynamic) do iSlice = 1 , grid % nSlices call grid % getSliceNonZero ( cutoff , iSlice , xyzw , nPt ) if ( nPt == 0 ) cycle !$omp atomic capture iPtOld = iPt iPt = iPt + nPt !$omp end atomic iAt = grid % idOrigin ( iSlice ) xyz ( 1 , iPtOld + 1 : iPtOld + nPt ) = c ( 1 , iAt ) + xyzw ( 1 : nPt , 1 ) xyz ( 2 , iPtOld + 1 : iPtOld + nPt ) = c ( 2 , iAt ) + xyzw ( 1 : nPt , 2 ) xyz ( 3 , iPtOld + 1 : iPtOld + nPt ) = c ( 3 , iAt ) + xyzw ( 1 : nPt , 3 ) w ( iPtOld + 1 : iPtOld + nPt ) = xyzw ( 1 : nPt , 4 ) kcp ( iPtOld + 1 : iPtOld + nPt ) = iAt end do !$omp end do !$omp end parallel npts = iPt end subroutine !> @brief Get grid points from a slice, which weights are larger !>  than a cutoff. !> @param[in]    cutoff    cutoff to skip small weights !> @param[in]    iSlice    index of current slice !> @param[out]   xyzw      coordinates and weights of grid points !> @param[out]   nPt       number of nonzero point for slice !> @author Vladimir Mironov subroutine getSliceNonZero ( grid , cutoff , iSlice , xyzw , nPt ) use constants , only : pi class ( dft_grid_t ), intent ( IN ) :: grid real ( KIND = fp ), intent ( IN ) :: cutoff integer , intent ( IN ) :: iSlice real ( KIND = fp ), contiguous , intent ( OUT ) :: xyzw (:, :) integer , intent ( OUT ) :: nPt real ( KIND = fp ), parameter :: FOUR_PI = 4.0_fp * pi type ( grid_3d_t ), pointer :: curGrid integer :: iAng , iRad , iPt real ( KIND = fp ) :: r1 , wtCur nPt = 0 curGrid => grid % spherical_grids % getbyid ( grid % idAng ( iSlice )) associate ( & rad => grid % rAtm ( iSlice ), & isInner => grid % isInner ( iSlice ), & wtStart => grid % wtStart ( iSlice ) - 1 , & totWts => grid % totWts , & curAt => grid % idOrigin ( iSlice ), & iTyp => grid % radTypeId ( grid % idOrigin ( iSlice )), & iAngStart => grid % iAngStart ( iSlice ), & iRadStart => grid % iRadStart ( iSlice ), & nAngPts => grid % nAngPts ( iSlice ), & nRadPts => grid % nRadPts ( iSlice )) associate ( & xAng => curGrid % x ( iAngStart : iAngStart + nAngPts - 1 ), & yAng => curGrid % y ( iAngStart : iAngStart + nAngPts - 1 ), & zAng => curGrid % z ( iAngStart : iAngStart + nAngPts - 1 ), & wAng => curGrid % w ( iAngStart : iAngStart + nAngPts - 1 )) do iAng = 1 , nAngPts do iRad = 1 , nRadPts iPt = ( iAng - 1 ) * nRadPts + iRad if ( isInner == 0 ) then wtCur = totWts ( wtStart + iPt , curAt ) else wtCur = FOUR_PI * rad * rad * rad * & grid % rad_wts ( iRadStart + iRad - 1 , iTyp ) * wAng ( iAng ) end if if ( wtCur == 0.0_fp ) exit if ( wtCur < cutoff ) cycle nPt = nPt + 1 r1 = rad * grid % rad_pts ( iRadStart + iRad - 1 , iTyp ) xyzw ( nPt , 1 ) = r1 * xAng ( iAng ) xyzw ( nPt , 2 ) = r1 * yAng ( iAng ) xyzw ( nPt , 3 ) = r1 * zAng ( iAng ) xyzw ( nPt , 4 ) = wtCur end do end do end associate end associate end subroutine !> @brief Set slice data !> @param[in]    iSlice     index of current slice !> @param[in]    iRadStart  index of the first point in radial grid array !> @param[in]    nRadPts    number of radial grid points !> @param[in]    idAng      index of angular grid !> @param[in]    idAngStart index of the first point in angular grid array !> @param[in]    nAngPts    number of angular grid points !> @param[in]    wtStart    index of the first point in weights array !> @param[in]    idAtm      index of atom which owns the slice !> @param[in]    rAtm       effective radius of current atom !> @param[in]    chunkType  type of chunk -- used for different processing !> @author Vladimir Mironov subroutine setSlice ( grid , iSlice , iRadStart , nRadPts , & idAng , iAngStart , nAngPts , & wtStart , idAtm , rAtm , chunkType ) class ( dft_grid_t ), intent ( INOUT ) :: grid integer , intent ( IN ) :: iSlice integer , intent ( IN ) :: iRadStart , nRadPts integer , intent ( IN ) :: idAng , iAngStart , nAngPts integer , intent ( IN ) :: wtStart integer , intent ( IN ) :: idAtm , chunkType real ( KIND = fp ), intent ( IN ) :: rAtm grid % idAng ( iSlice ) = idAng grid % iRadStart ( iSlice ) = iRadStart grid % iAngStart ( iSlice ) = iAngStart grid % nRadPts ( iSlice ) = nRadPts grid % nAngPts ( iSlice ) = nAngPts grid % nTotPts ( iSlice ) = 0 grid % idOrigin ( iSlice ) = idAtm grid % rAtm ( iSlice ) = rAtm grid % chunkType ( iSlice ) = chunkType grid % wtStart ( iSlice ) = wtStart end subroutine setSlice !> @brief Compute average vector of two 3D vectors !> @param[in]    vectors    input 3D vectors !> @author Vladimir Mironov pure function vector_average ( vectors ) result ( avg ) real ( KIND = fp ), intent ( IN ) :: vectors (:, :) real ( KIND = fp ) :: avg ( 3 ) real ( KIND = fp ) :: norm avg = sum ( vectors ( 1 : 3 , :), dim = 2 ) norm = 1.0 / sqrt ( sum ( avg ** 2 )) avg = avg * norm end function vector_average !> @brief Compute cross product of two 3D vectors !> @param[in]    a    first vector !> @param[in]    b    second vector !> @author Vladimir Mironov pure function cross_product ( a , b ) result ( c ) real ( KIND = fp ), intent ( IN ) :: a (:), b (:) real ( KIND = fp ) :: c ( 3 ) c ( 1 ) = a ( 2 ) * b ( 3 ) - a ( 3 ) * b ( 2 ) c ( 2 ) = a ( 3 ) * b ( 1 ) - a ( 1 ) * b ( 3 ) c ( 3 ) = a ( 1 ) * b ( 2 ) - a ( 2 ) * b ( 1 ) end function !> @brief Check if test vector crosses spherical polygon !> @param[in]    test  test vector !> @param[in]    vecs  vectors, defining the polygon !> @author Vladimir Mironov pure function is_vector_inside_shape ( test , vecs ) result ( inside ) real ( KIND = fp ), intent ( IN ) :: test (:), vecs (:, :) logical :: inside integer :: i real ( KIND = fp ) :: sgn , sgnold , vectmp ( 3 ) !     Test vector must at least has same direction, as average vector !     vectmp(:) = sum(vecs(:,:),dim=1) !     if (sum(test*vectmp)<0.0) then !         inside = .false. !         return !     end if inside = . true . vectmp = cross_product ( vecs (:, ubound ( vecs , 2 )), vecs (:, lbound ( vecs , 2 ))) sgnold = sign ( 1.0_fp , sum ( test ( 1 : 3 ) * vectmp ( 1 : 3 ))) do i = lbound ( vecs , 2 ), ubound ( vecs , 2 ) - 1 vectmp = cross_product ( vecs (:, i ), vecs (:, i + 1 )) sgn = sign ( 1.0_fp , sum ( test ( 1 : 3 ) * vectmp ( 1 : 3 ))) if ( sgn * sgnold < 0.0d0 ) then ! different signs inside = . false . return end if sgnold = sgn end do end function end module mod_dft_molgrid","tags":"","url":"sourcefile/dft_molgrid.f90.html"},{"title":"precision.F90 – OpenQP Fortran API","text":"Source Code ! module precision !>    @author  Vladimir Mironov !> !>    @brief   Contains constants for floating !>             point number precision ! !     REVISION HISTORY: !>    @date _May, 2016_ Initial release ! module precision use , intrinsic :: iso_fortran_env , only : int8 , int16 , int32 , int64 , real32 , real64 , real128 implicit none public integer , parameter :: I1B = int8 integer , parameter :: I2B = int16 integer , parameter :: I4B = int32 integer , parameter :: I8B = int64 integer , parameter :: SP = real32 integer , parameter :: DP = real64 !   Quad precision: integer , parameter :: QP = real128 !   Default floating pcision: integer , parameter :: FP = DP integer , parameter :: SPC = real32 integer , parameter :: DPC = real64 integer , parameter :: LGC = kind (. true .) end module precision","tags":"","url":"sourcefile/precision.f90.html"},{"title":"scf.F90 – OpenQP Fortran API","text":"Source Code module scf use precision , only : dp character ( len =* ), parameter :: module_name = \"scf\" public :: scf_driver public :: fock_jk contains !============================================================================== ! Main SCF Driver Subroutine !============================================================================== !> @brief Performs self-consistent field (SCF) calculations for Hartree-Fock (HF) !>        and Density Functional Theory (DFT) methods. !> @detail This subroutine implements SCF iterations for !>         Restricted (RHF), Unrestricted (UHF), and Restricted Open-Shell (ROHF) !> !> @section Supported SCF Options for RHF/UHF/ROHF: !>          - MOM: Maximum Overlap Method for orbital consistency between SCF iterations. !>          - pFON: Pseudo-Fractional Occupation Number for near-degenerate states. !>          - Vshift: Level shifting for virtual orbitals. !> !> @section accelerators Supported SCF Convergence Accelerators: !>          - A-DIIS: Augmented Direct Inversion in the Iterative Subspace. !>          - E-DIIS: Energy-based DIIS. !>          - C-DIIS: Commutator-based DIIS. !>          - V-DIIS: Variable DIIS with dynamic switching. !>          - SOSCF:  Second-Order SCF convergence method. !> !> @author Vladimir Mironov - Original author, developed initial SCF module !>                            and DIIS drivers (pre-2022). !> @author Konstantin Komarov - Added Guest-Saunders ROHF Fock transformation, !>                              MOM, Vshift, SOSCF, wrapped pFON into `pfon_t` type, !>                              optimized memory usage, added documentation and comments, !>                              and cleaned up the code (2023-2025). !> @author Mohsen Mazaherifar - Added MPI parallelization support (2023-2024). !> @author Alireza Lashkaripour - Implemented pFON functionality (January 2025). !> !> @date Initial version: pre-2022; Major updates: 2023-2025. !> !> @param[in]     basis    Basis set information. !> @param[inout]  infos    System information and calculation parameters !>                         (updated with converged energy and wavefunction). !> @param[in]     molGrid  Molecular grid for DFT calculations. subroutine scf_driver ( basis , infos , molGrid , coarseGrid ) USE precision , only : dp use oqp_tagarray_driver use constants , only : kB_HaK use types , only : information use int2_compute , only : int2_compute_t , int2_fock_data_t , & int2_rhf_data_t , int2_urohf_data_t use dft , only : dftexcor use mod_dft_molgrid , only : dft_grid_t use messages , only : show_message , WITH_ABORT use guess , only : get_ab_initio_density , get_ab_initio_orbital use util , only : measure_time , e_charge_repulsion use printing , only : print_mo_range use mathlib , only : traceprod_sym_packed use qmat_cache , only : get_qmat_cached use mathlib , only : unpack_matrix use io_constants , only : IW use basis_tools , only : basis_set use scf_converger , only : scf_conv_result , scf_conv , & conv_cdiis , conv_ediis , conv_soscf , & conv_trah use mod_dft_incdft , only : incdft_should_reuse , incdft_reset use scf_addons , only : pfon_t , apply_mom , level_shift_fock , calc_fock , & scf_energy_t , scf_rhf , scf_uhf , scf_rohf , get_scf_name , & scf_diis , scf_bfgs , scf_trah , get_solver_name use qmmm_mod , only : get_mm_energy , form_esp_charges , print_mm_energy , add_potqm_contributions implicit none character ( len =* ), parameter :: subroutine_name = \"scf_driver\" !============================================================================== ! Input/Output Arguments !============================================================================== type ( basis_set ), intent ( in ) :: basis ! Basis set information type ( information ), target , intent ( inout ) :: infos ! System information & parameters type ( dft_grid_t ), intent ( in ), target :: molGrid ! Molecular grid for DFT (full/fine) type ( dft_grid_t ), intent ( in ), target , optional :: coarseGrid ! coarse grid for the SCF descent !================================================o=o=========================== ! Matrix Dimensions and Basic Parameters !============================================================================== integer :: nbf ! Number of basis functions integer :: nbf_tri ! Size of triangular matrices (nbf*(nbf+1)/2) integer :: nbf2 ! Square matrix size (nbf*nbf) integer :: nfocks ! Number of Fock matrices (1 for RHF, 2 for UHF/ROHF) integer :: nschwz ! Number of skipped integrals (integral screening) integer :: ok ! Status flag for memory allocation !============================================================================== ! SCF Type Parameters !============================================================================== integer :: scf_type ! Type of SCF calculation character ( 16 ) :: scf_name = \"\" ! Name of the SCF method (RHF/UHF/ROHF) logical :: is_dft ! True if using DFT, false for HF logical :: use_incdft ! Opt 2: incremental-XC reuse enabled logical :: xc_reuse_now ! Opt 2: reuse XC this iteration real ( kind = dp ) :: scalefactor ! Scaling factor for HF exchange logical :: do_check = . false . !============================================================================== ! Electron Counting Parameters !============================================================================== integer :: nelec ! Total number of electrons integer :: nelec_a ! Number of alpha electrons integer :: nelec_b ! Number of beta electrons !============================================================================== ! Iteration Control Parameters !============================================================================== integer :: i , ii , iter ! Loop counters and current iteration number integer :: maxit ! Maximum number of SCF iterations !============================================================================== ! Energy Components !============================================================================== real ( kind = dp ) :: e_old ! Energy from previous iteration type ( scf_energy_t ) :: energy !============================================================================== ! DIIS Convergence Acceleration Parameters !============================================================================== integer :: diis_nfocks ! Number of Fock matrices for DIIS integer :: soscf_nfocks ! Number of Fock matrices for SOSCF integer :: diis_reset ! Frequency of DIIS reset integer :: maxdiis ! Maximum number of DIIS vectors real ( kind = dp ) :: diis_error ! DIIS error matrix norm real ( kind = dp ) :: stall_best ! best DIIS error seen (orchestration: stall detection) integer :: stall_count ! iters since the last meaningful DIIS-error drop logical :: stalled_exit ! converger bailed out stalled (escalate, not converged) character ( len = 6 ), dimension ( 5 ) :: diis_name ! Names of DIIS methods real ( kind = dp ), parameter :: ethr_cdiis_big = 2.0_dp ! DIIS error threshold for C-DIIS real ( kind = dp ), parameter :: ethr_ediis = 1.0_dp ! DIIS error threshold for E-DIIS logical :: diis_reset_condition ! Flag for DIIS reset condition !============================================================================== ! Progressive (iteration-dependent) integral screening !============================================================================== logical :: ps_on ! progressive screening enabled this run logical :: ps_timer ! env-gated per-iteration Fock-build timer real ( kind = dp ) :: ps_cut_tight ! the user's tight (final) int2e_cutoff real ( kind = dp ) :: ps_k ! coupling: tau_iter = ps_k * diis_error real ( kind = dp ) :: ps_cap ! loosest allowed cutoff (upper clamp) real ( kind = dp ) :: ps_tight ! pin to ps_cut_tight once diis_error < ps_tight real ( kind = dp ) :: ps_tau ! this iteration's effective cutoff logical :: ps_pin ! true once we have pinned to the tight cutoff character ( len = 64 ) :: ps_env ! scratch for env-var reads integer :: ps_ln ! env-var length / iostat scratch integer ( kind = 8 ) :: ps_t0 , ps_t1 , ps_rate ! Fock-build timer counters logical :: ps_xc ! progressive XC-grid threshold ramp active real ( kind = dp ) :: ps_xc_dcut ! loose grid density cutoff during descent real ( kind = dp ) :: ps_xc_aocut ! loose grid AO-prune threshold during descent real ( kind = dp ) :: ps_xc_dcut0 ! saved baseline grid density cutoff real ( kind = dp ) :: ps_xc_aocut0 ! saved baseline grid AO-prune threshold logical :: ps_grid_on ! coarse->fine XC grid ramp active type ( dft_grid_t ), pointer :: ps_cur_grid ! grid selected for this iteration's XC build logical :: ps_force_iter ! force one pinned full-accuracy iteration before converging !============================================================================== ! SOSCF Convergence Acceleration Parameters !============================================================================== logical :: use_soscf ! Flag to use SOSCF method real ( kind = dp ) :: rms_grad ! RMS of gradient real ( kind = dp ) :: rms_dp ! RMS of density different real ( kind = dp ) :: delta_dens_a ! for ROHFFIX real ( kind = dp ) :: delta_dens_b ! for ROHFFIX real ( kind = dp ), allocatable :: dens_prev (:,:) ! Previous density !============================================================================== ! TRAH Convergence Acceleration Parameters !============================================================================== logical :: use_trah = . false . !============================================================================== ! Virtual Orbital Shift Parameters (for ROHF) !============================================================================== real ( kind = dp ) :: vshift ! Virtual orbital energy shift real ( kind = dp ) :: H_U_gap ! HOMO-LUMO gap logical :: vshift_last_iter ! Flag for last iteration with vshift !============================================================================== ! MOM (Maximum Overlap Method) Parameters !============================================================================== logical :: do_mom ! Flag to enable MOM method logical :: initial_mom_iter ! Flag for first MOM iteration logical :: mom_active ! Flag indicating MOM is currently active real ( kind = dp ), allocatable :: mo_a_prev (:,:) ! Previous alpha MO coefficients real ( kind = dp ), allocatable :: mo_e_a_prev (:) ! Previous alpha orbital energies real ( kind = dp ), allocatable :: mo_b_prev (:,:) ! Previous beta MO coefficients (UHF only) real ( kind = dp ), allocatable :: mo_e_b_prev (:) ! Previous beta orbital energies (UHF only) !============================================================================== ! pFON (pseudo-Fractional Occupation Number) Parameters !============================================================================== logical :: do_pfon ! Flag to use pFON method logical :: do_pfon_final ! Flag to trigger extra iteration at 1K type ( pfon_t ), pointer :: pfon ! pFON handler object real ( kind = dp ), allocatable , target :: occ_a (:), occ_b (:) ! Orbital occupations for alpha/beta !============================================================================== ! Matrices and Vectors for SCF Calculation !============================================================================== real ( kind = dp ), allocatable , target :: smat_full (:,:) ! Full overlap matrix real ( kind = dp ), allocatable , target :: pdmat (:,:) ! Density matrices in triangular format real ( kind = dp ), allocatable , target :: pfock (:,:) ! Fock matrices in triangular format real ( kind = dp ), allocatable , target :: rohf_bak (:,:) ! Backup for ROHF Fock real ( kind = dp ), allocatable , target :: dold (:,:) ! Old density for incremental builds real ( kind = dp ), allocatable , target :: fold (:,:) ! Old Fock for incremental builds real ( kind = dp ), allocatable :: pfxc (:,:) ! DFT exchange-correlation matrix real ( kind = dp ), allocatable :: qmat (:,:) ! Orthogonalization matrix real ( kind = dp ), allocatable , target :: work1 (:,:) ! Work matrix 1 real ( kind = dp ), allocatable , target :: work2 (:,:) ! Work matrix 2 !============================================================================== ! Matrices and Vectors for SCF Calculation !============================================================================== logical :: do_rstctmo real ( kind = dp ), allocatable , dimension (:,:) :: mo_a_for_rstctmo , mo_b_for_rstctmo real ( kind = dp ), allocatable :: mo_energy_a_for_rstctmo (:) !============================================================================== ! Matrices and Vectors for QMMM !============================================================================== real ( kind = dp ), allocatable :: dhcore (:) real ( kind = dp ), allocatable :: hcore_bk (:) !    real(kind=dp), allocatable :: dens_old(:) !============================================================================== ! Tag Arrays for Accessing Data !============================================================================== real ( kind = dp ), contiguous , pointer :: smat (:), hcore (:), tmat (:), & fock_a (:), fock_b (:), & dmat_a (:), dmat_b (:), & mo_energy_b (:), mo_energy_a (:), & mo_a (:,:), mo_b (:,:) character ( len =* ), parameter :: tags_general ( 3 ) = & ( / character ( len = 80 ) :: OQP_SM , OQP_TM , OQP_Hcore / ) character ( len =* ), parameter :: tags_alpha ( 4 ) = & ( / character ( len = 80 ) :: OQP_FOCK_A , OQP_DM_A , OQP_E_MO_A , OQP_VEC_MO_A / ) character ( len =* ), parameter :: tags_beta ( 4 ) = & ( / character ( len = 80 ) :: OQP_FOCK_B , OQP_DM_B , OQP_E_MO_B , OQP_VEC_MO_B / ) !============================================================================== ! SCF Convergence Accelerator Objects !============================================================================== type ( scf_conv ) :: conv ! SCF convergence driver class ( scf_conv_result ), allocatable :: conv_res ! SCF convergence result integer :: stat ! Status flag for DIIS/SOSCF !============================================================================== ! Integral Evaluation Objects !============================================================================== type ( int2_compute_t ) :: int2_driver ! Two-electron integral driver class ( int2_fock_data_t ), allocatable :: int2_data ! Two-electron integral data !============================================================================== ! Extract Calculation Parameters from Input !============================================================================== ! Set SCF type (RHF, UHF, or ROHF) and ! configure parameters based on SCF type select case ( infos % control % scftype ) case ( 1 ) scf_type = scf_rhf nfocks = 1 diis_nfocks = 1 soscf_nfocks = 1 case ( 2 ) scf_type = scf_uhf nfocks = 2 diis_nfocks = 2 soscf_nfocks = 2 case ( 3 ) scf_type = scf_rohf nfocks = 2 diis_nfocks = 1 soscf_nfocks = 2 end select scf_name = get_scf_name ( scf_type ) ! Get electron counts nelec = infos % mol_prop % nelec nelec_a = infos % mol_prop % nelec_a nelec_b = infos % mol_prop % nelec_b ! Get matrix dimensions nbf = basis % nbf nbf_tri = nbf * ( nbf + 1 ) / 2 nbf2 = nbf * nbf ! Get iteration parameters maxit = infos % control % maxit ! Determine calculation type (HF or DFT) is_dft = infos % control % hamilton >= 20 ! Set HF exchange scaling factor for DFT if ( is_dft ) then scalefactor = infos % dft % HFscale else scalefactor = 1.0_dp end if !============================================================================== ! Retrieve Tag Arrays and Allocate Memory !============================================================================== ! Get general tag arrays call data_has_tags ( infos % dat , tags_general , module_name , subroutine_name , WITH_ABORT ) call tagarray_get_data ( infos % dat , OQP_Hcore , hcore ) call tagarray_get_data ( infos % dat , OQP_SM , smat ) call tagarray_get_data ( infos % dat , OQP_TM , tmat ) ! Get alpha-spin tag arrays call data_has_tags ( infos % dat , tags_alpha , module_name , subroutine_name , WITH_ABORT ) call tagarray_get_data ( infos % dat , OQP_FOCK_A , fock_a ) call tagarray_get_data ( infos % dat , OQP_DM_A , dmat_a ) call tagarray_get_data ( infos % dat , OQP_E_MO_A , mo_energy_a ) call tagarray_get_data ( infos % dat , OQP_VEC_MO_A , mo_a ) ! Get beta-spin tag arrays if needed if ( nfocks > 1 ) then call data_has_tags ( infos % dat , tags_beta , module_name , subroutine_name , WITH_ABORT ) call tagarray_get_data ( infos % dat , OQP_FOCK_B , fock_b ) call tagarray_get_data ( infos % dat , OQP_DM_B , dmat_b ) call tagarray_get_data ( infos % dat , OQP_E_MO_B , mo_energy_b ) call tagarray_get_data ( infos % dat , OQP_VEC_MO_B , mo_b ) end if ! Allocate main work arrays ok = 0 allocate ( smat_full ( nbf , nbf ), & dens_prev ( nbf_tri , nfocks ), & pdmat ( nbf_tri , nfocks ), & pfock ( nbf_tri , nfocks ), & rohf_bak ( nbf_tri , nfocks ), & qmat ( nbf , nbf ), & work1 ( nbf , nbf ), & work2 ( nbf , nbf ), & dhcore ( nbf_tri ), & hcore_bk ( nbf_tri ), & stat = ok , & source = 0.0_dp ) if ( ok /= 0 ) call show_message ( 'Cannot allocate memory for SCF' , WITH_ABORT ) ! Allocate incremental Fock building arrays if enabled if ( infos % control % scf_incremental /= 0 ) then allocate ( dold ( nbf_tri , nfocks ), & fold ( nbf_tri , nfocks ), & stat = ok , & source = 0.0_dp ) if ( ok /= 0 ) call show_message ( 'Cannot allocate memory for SCF: 2' , WITH_ABORT ) end if ! Allocate DFT arrays if needed if ( is_dft ) then allocate ( pfxc ( nbf_tri , nfocks ), & stat = ok , & source = 0.0_dp ) if ( ok /= 0 ) call show_message ( 'Cannot allocate memory for temporary vectors' , WITH_ABORT ) end if hcore_bk = hcore ! Opt 2 (IncDFT): start each SCF with a clean XC reference store. ! Controlled by [scf] xc_incdft (infos%control%xc_incdft). use_incdft = is_dft . and . ( infos % control % xc_incdft /= 0 ) if ( use_incdft ) call incdft_reset () !============================================================================== ! Initialize pFON Parameters !============================================================================== do_pfon = . false . do_pfon = infos % control % pfon if ( do_pfon ) then ! Flag to trigger extra iteration at 1K do_pfon_final = . false . ! Allocate and initialize occupation arrays allocate ( occ_a ( nbf ), source = 0.0_dp , stat = ok ) if ( nfocks > 1 ) then ! For UHF and ROHF allocate ( occ_b ( nbf ), source = 0.0_dp , stat = ok ) end if if ( ok /= 0 ) call show_message ( 'Cannot allocate memory for occupation arrays' , WITH_ABORT ) ! Set initial occupation numbers based on SCF type select case ( scf_type ) case ( scf_rhf ) occ_a ( 1 : nelec / 2 ) = 2.0_dp case ( scf_uhf ) occ_a ( 1 : nelec_a ) = 1.0_dp occ_b ( 1 : nelec_b ) = 1.0_dp case ( scf_rohf ) occ_a ( 1 : nelec_b ) = 2.0_dp ! Closed shells occ_a ( nelec_b + 1 : nelec_a ) = 1.0_dp ! Open shells occ_b ( 1 : nelec_b ) = 2.0_dp ! Closed shells only end select ! Allocate pFON object allocate ( pfon ) ! Initialize pFON object if ( nfocks > 1 ) then call pfon % init ( infos % control , nbf , nelec , nelec_a , nelec_b , scf_type , occ_a , occ_b ) else call pfon % init ( infos % control , nbf , nelec , nelec_a , nelec_b , scf_type , occ_a ) end if end if !============================================================================== ! Initialize MOM parameters !============================================================================== do_mom = infos % control % mom if ( do_mom ) then initial_mom_iter = . true . mom_active = . false . ! Allocate storage for previous iteration's orbitals allocate ( mo_a_prev ( nbf , nbf ), source = 0.0_dp ) allocate ( mo_e_a_prev ( nbf ), source = 0.0_dp ) ! For UHF, we need separate storage for beta orbitals if ( scf_type == scf_uhf ) then allocate ( mo_b_prev ( nbf , nbf ), source = 0.0_dp ) allocate ( mo_e_b_prev ( nbf ), source = 0.0_dp ) end if end if !============================================================================== ! Initialize XAS parameters !============================================================================== do_rstctmo = infos % control % rstctmo if ( do_mom . and . do_rstctmo ) call show_message ( '* Error: Use either MOM or RSTCTMO' , WITH_ABORT ) if ( do_rstctmo ) then allocate ( mo_a_for_rstctmo ( nbf , nbf ), & mo_b_for_rstctmo ( nbf , nbf ), & mo_energy_a_for_rstctmo ( nbf ), & source = 0.0_dp ) end if !============================================================================== ! Initialize Vshift Parameters (currently only works for ROHF) !============================================================================== vshift = infos % control % vshift vshift_last_iter = . false . !============================================================================== ! Initialize SCF Calculation !============================================================================== call measure_time ( print_total = 1 , log_unit = IW ) ! Prepare orthogonalization matrix (S&#94;-1/2), reusing the ! copy cached during the initial guess when available call get_qmat_cached ( infos , smat , qmat , nbf ) ! Compute Nuclear-Nuclear repulsion energy on EVERY SCF entry, directly from ! the (Fortran-owned) atom data. Do not rely on it being set by a later ! energy-components pass: the robust-driver escalation / stability-following ! TRAH pass re-enters SCF with a fresh energy object and would otherwise read ! an uninitialised nenergy (garbage ~0) -> total = electronic only, which then ! overwrites the correct mol_energy. (ecp_zn_num is 0 for non-ECP atoms.) energy % nenergy = e_charge_repulsion ( infos % atoms % xyz , infos % atoms % zn - infos % basis % ecp_zn_num ) ! During guess, the Hcore, Q nd Overlap matrices were formed. ! Using these, the initial orbitals (VEC) and density (Dmat) were subsequently computed. ! Now we are going to calculate ERI(electron repulsion integrals) to form a new FOCK ! matrix. ! Initialize ERI calculations and screening call int2_driver % init ( basis , infos ) call int2_driver % set_screening () call flush ( IW ) ! Initialize density matrices for integral evaluation select case ( scf_type ) case ( scf_rhf ) pdmat (:, 1 ) = dmat_a allocate ( int2_rhf_data_t :: int2_data ) int2_data = int2_rhf_data_t ( nfocks = 1 , & d = pdmat , & scale_exchange = scalefactor ) case ( scf_uhf , scf_rohf ) pdmat (:, 1 ) = dmat_a pdmat (:, 2 ) = dmat_b allocate ( int2_urohf_data_t :: int2_data ) int2_data = int2_urohf_data_t ( nfocks = 2 , & d = pdmat , & scale_exchange = scalefactor ) end select ! Convert overlap matrix to full format for DIIS/SOSCF call unpack_matrix ( smat , smat_full , nbf , 'U' ) !============================================================================== ! Configure SCF Convergence Accelerator (DIIS/SOSCF) !============================================================================== ! Configuration is determined by converger_type, diis_type, and vshift: ! ! converger_type = 0 (Pure DIIS): !   ├── diis_type = 5 (V-DIIS): !   │   ├── vshift unset (0.0): Sets vshift = 0.1 !   │   └── Uses: [C-DIIS, E-DIIS, C-DIIS] !   │       Thresholds: [2.0, 1.0, cdiis_switch] !   ├── vshift set (non-zero): !   │   └── Uses: [C-DIIS, E-DIIS, C-DIIS] !   │       Thresholds: [2.0, 1.0, cdiis_switch] !   └── Otherwise: !       └── Uses: diis_type method (1=C-DIIS, 2=E-DIIS, 3=A-DIIS) !           Threshold: 2.0 ! ! converger_type = 1 (Pure SOSCF): !   └── Uses: SOSCF !       Starts: From first iteration ! ! converger_type = 2 (Pure TRAH): ! ! Additional Note: ! - MOM activates if mom = .true. and DIIS error < mom_switch, handled outside this block. !============================================================================== ! SOSCF options use_soscf = . false . ! DIIS options maxdiis = infos % control % maxdiis diis_error = 2.0_dp stall_best = huge ( 1.0_dp ) stall_count = 0 stalled_exit = . false . diis_name = [ character ( len = 6 ) :: \"none\" , \"c-DIIS\" , \"e-DIIS\" , \"a-DIIS\" , \"v-DIIS\" ] diis_reset = infos % control % diis_reset_mod !============================================================================== ! Progressive (iteration-dependent) integral screening setup. Default OFF. ! tau_iter = clamp(ps_k*diis_error, ps_cut_tight, ps_cap) while diis_error ! >= ps_tight; pinned to ps_cut_tight (with a full incremental rebuild) once ! diis_error < ps_tight, so the converged energy matches the all-tight run. ! Env vars override the control fields for quick experimentation. !============================================================================== ps_cut_tight = infos % control % int2e_cutoff ps_on = ( infos % control % scf_pscreen /= 0 ) ps_k = infos % control % pscreen_k ps_cap = infos % control % pscreen_cap ps_tight = infos % control % pscreen_tight ps_pin = . false . call get_environment_variable ( \"OQP_PSCREEN\" , ps_env , ps_ln ) if ( ps_ln > 0 ) ps_on = ( ps_env ( 1 : 1 ) == '1' . or . ps_env ( 1 : 1 ) == 'y' . or . ps_env ( 1 : 1 ) == 'Y' & . or . ps_env ( 1 : 1 ) == 't' . or . ps_env ( 1 : 1 ) == 'T' ) call get_environment_variable ( \"OQP_PSCREEN_K\" , ps_env , ps_ln ) if ( ps_ln > 0 ) read ( ps_env , * , iostat = ps_ln ) ps_k call get_environment_variable ( \"OQP_PSCREEN_CAP\" , ps_env , ps_ln ) if ( ps_ln > 0 ) read ( ps_env , * , iostat = ps_ln ) ps_cap call get_environment_variable ( \"OQP_PSCREEN_TIGHT\" , ps_env , ps_ln ) if ( ps_ln > 0 ) read ( ps_env , * , iostat = ps_ln ) ps_tight ! The pin must trigger at or before convergence, otherwise the loose/coarse phase ! can never reach its (looser) noise floor below pscreen_tight and the SCF stalls. ! Keep pscreen_tight at least an order above the SCF convergence threshold. ps_tight = max ( ps_tight , 1 0.0_dp * infos % control % conv ) ps_timer = . false . call get_environment_variable ( \"OQP_FOCK_TIMER\" , ps_env , ps_ln ) if ( ps_ln > 0 ) ps_timer = ( ps_env ( 1 : 1 ) == '1' . or . ps_env ( 1 : 1 ) == 'y' . or . ps_env ( 1 : 1 ) == 'Y' & . or . ps_env ( 1 : 1 ) == 't' . or . ps_env ( 1 : 1 ) == 'T' ) ! keep the loose cap from ever being tighter than the final cutoff ps_cap = max ( ps_cap , ps_cut_tight ) if ( ps_on ) then write ( IW , '(/3x,a)' ) 'Progressive integral screening ENABLED (iteration-dependent int2e_cutoff)' write ( IW , '(3x,a,es9.2,a,es9.2,a,es9.2,a,es9.2)' ) & '  tight=' , ps_cut_tight , '  k=' , ps_k , '  cap=' , ps_cap , '  pin<' , ps_tight end if ! Progressive XC-grid threshold ramp (gated by the same scf_pscreen + ps_pin latch). ! During the descent, loosen the DFT grid density cutoff / AO-prune threshold so early ! XC builds prune more AOs and skip more low-density points; restore to the user's ! baseline (tight) once pinned, so the converged XC energy is unchanged. ps_xc_dcut = infos % control % pscreen_xc_dcut ps_xc_aocut = infos % control % pscreen_xc_aocut call get_environment_variable ( \"OQP_PSCREEN_XC_DCUT\" , ps_env , ps_ln ) if ( ps_ln > 0 ) read ( ps_env , * , iostat = ps_ln ) ps_xc_dcut call get_environment_variable ( \"OQP_PSCREEN_XC_AOCUT\" , ps_env , ps_ln ) if ( ps_ln > 0 ) read ( ps_env , * , iostat = ps_ln ) ps_xc_aocut ps_xc_dcut0 = infos % dft % grid_density_cutoff ps_xc_aocut0 = infos % dft % grid_ao_threshold ps_xc = ps_on . and . ( ps_xc_dcut > 0.0_dp . or . ps_xc_aocut > 0.0_dp ) if ( ps_xc ) write ( IW , '(3x,a,es9.2,a,es9.2)' ) & '  XC ramp: loose grid dcut=' , ps_xc_dcut , '  loose grid aocut=' , ps_xc_aocut ! Coarse->fine XC grid ramp (single engine). coarseGrid is built+passed by ! hf_energy under the unified policy: it covers BOTH the opt-in progressive- ! screening request and the default-on coarse-to-fine schedule. The ramp is ! therefore independent of integral screening (ps_on) -- it runs whenever a ! coarse grid was provided. ps_grid_on = present ( coarseGrid ) ! When the grid ramp runs without integral screening, it still needs a pin ! threshold: the coarse-to-fine switch threshold (fixed 1e-2, floored at ! 10*conv). With integral screening on, ps_tight (above) governs both. if ( ps_grid_on . and . . not . ps_on ) then ps_tight = 1.0e-2_dp ps_tight = max ( ps_tight , 1 0.0_dp * infos % control % conv ) end if ps_cur_grid => molGrid if ( ps_grid_on ) write ( IW , '(3x,a)' ) '  XC ramp: coarse grid during descent, full grid pinned in the tail' ! Initialize SCF Convergence Accelerator (single source of truth) call init_scf_converger ( infos , molGrid , conv , nbf , nelec_a , nelec_b , & maxdiis , diis_nfocks , soscf_nfocks , & smat_full , qmat , vshift , use_soscf , use_trah ) ! Initialize DFT exchange-correlation energy energy % eexc = 0.0_dp energy % e_old = 0.0_dp !============================================================================== ! Print SCF Options !============================================================================== ! Only the options relevant to the active converger/features are printed, ! to keep the log focused (the previous version dumped every knob always). write ( IW , '(/5X,\"SCF options\"/5X,18(\"-\"))' ) write ( IW , '(5X,\"SCF reference type = \",A,5X,\"MaxIT = \",I0,5X,\"Conv = \",ES9.2)' ) & trim ( scf_name ), infos % control % maxit , infos % control % conv if ( use_trah ) then write ( IW , '(5X,\"Converger = TRAH (trust-region augmented Hessian)\")' ) else if ( use_soscf ) then write ( IW , '(5X,\"Converger = SOSCF (\",A,\")\")' ) & trim ( get_solver_name ( int ( infos % control % converger_type ))) else write ( IW , '(5X,\"Converger = \",A,\"   MaxDIIS = \",I0)' ) & trim ( diis_name ( infos % control % diis_type )), infos % control % maxdiis if ( infos % control % diis_reset_mod > 0 ) & write ( IW , '(5X,\"DIIS reset every \",I0,\" iters when error > \",ES9.2)' ) & infos % control % diis_reset_mod , infos % control % diis_reset_conv if ( infos % control % diis_type == 5 ) & write ( IW , '(5X,\"vDIIS switch: cDIIS = \",F6.3,\"  vshift = \",F7.4)' ) & infos % control % cdiis_switch , infos % control % vdiis_vshift_switch if ( infos % control % vshift /= 0.0_dp ) & write ( IW , '(5X,\"Level shift = \",F6.3,\"  (cDIIS switch = \",F6.3,\")\")' ) & infos % control % vshift , infos % control % cdiis_switch end if if ( infos % control % mom ) & write ( IW , '(5X,\"MOM enabled (switch = \",ES9.2,\")\")' ) infos % control % mom_switch if ( infos % control % pfon ) & write ( IW , '(5X,\"pFON enabled: start T = \",F7.1,\" K, cooling = \",F6.1, & &\" K/iter, smearing = \",F6.3)' ) & infos % control % pfon_start_temp , infos % control % pfon_cooling_rate , & infos % control % pfon_nsmear ! Initial message for SCF iterations if ( infos % control % pfon ) then write ( IW , fmt = \"& &(/3x,'Direct SCF iterations begin.'/, & &  3x,113('='),/ & &  4x,'Iter',9x,'Energy',12x,'Delta E',9x,'Int Skip',5x,'DIIS Error',5x,'Shift',5x,'Method',5x,'pFON'/ & &  3x,113('='))\" ) elseif ( infos % control % converger_type == scf_bfgs ) then write ( IW , fmt = \"& &(/3x,'Direct SCF iterations begin.'/, & &  3x,107('='),/ & &  4x,'Iter',9x,'Energy',12x,'Delta E',9x,'Int Skip',5x,'Grad. RMS',6x,'Den. RMS',7x,'Shift',5x,'Method'/ & &  3x,107('='))\" ) elseif ( infos % control % converger_type == scf_trah ) then #ifdef OQP_HAVE_OPENTRAH if ( infos % control % trh_impl == 1 ) then write ( IW , \"(/,5x,'Trust-region augmented-Hessian (TRAH) SCF solver', & &/,5x,'[Helmich-Paris, J. Chem. Phys. 154, 164104 (2021)]')\" ) else write ( IW , \"(/,5x,'OpenTRAH (external OpenTrustRegion library)', & &/,5x,'[Helmich-Paris, J. Chem. Phys. 154, 164104 (2021);', & &/,5x,' https://github.com/eriksen-lab/opentrustregion]')\" ) end if #else write ( IW , \"(/,5x,'Trust-region augmented-Hessian (TRAH) SCF solver', & &/,5x,'[Helmich-Paris, J. Chem. Phys. 154, 164104 (2021)]')\" ) #endif else write ( IW , fmt = \"& &(/3x,'Direct SCF iterations begin.'/, & &  3x,93('='),/ & &  4x,'Iter',9x,'Energy',12x,'Delta E',9x,'Int Skip',5x,'DIIS Error',5x,'Shift',5x,'Method'/ & &  3x,93('='))\" ) end if call flush ( IW ) !============================================================================== ! Begin Main SCF Iteration Loop !============================================================================== do iter = 1 , maxit if ( do_rstctmo ) then mo_energy_a_for_rstctmo = mo_energy_a mo_a_for_rstctmo = mo_a end if !---------------------------------------------------------------------------- ! Update pFON Temperature (if enabled) !---------------------------------------------------------------------------- call pfon % adjust_temperature ( iter , maxit , diis_error , infos % control % conv , do_pfon , do_pfon_final ) !---------------------------------------------------------------------------- ! Initialize Fock Matrices for Current Iteration !---------------------------------------------------------------------------- pfock = 0.0_dp !---------------------------------------------------------------------------- ! Unified pin latch: enter the convergence tail (pin to full accuracy) once ! the DIIS error drops below ps_tight. Shared by the 2e-cutoff ramp (ps_on), ! the XC-threshold ramp (ps_xc) and the coarse->fine grid ramp (ps_grid_on) ! so they all tighten together. Sticky; never fires on iteration 1. !---------------------------------------------------------------------------- if (( ps_on . or . ps_grid_on ) . and . . not . ps_pin . and . iter > 1 & . and . diis_error < ps_tight ) then ps_pin = . true . end if ! Fail-safe: also pin in the final iterations, so a run that exhausts maxit ! without converging still reports a full-accuracy (full-grid, tight-cutoff) ! state -- and hands a full-grid warm-start to any convergence-escalation ! restart -- rather than a loose/coarse one. if (( ps_on . or . ps_grid_on ) . and . . not . ps_pin . and . iter >= maxit - 2 ) then ps_pin = . true . end if ! Progressive screening: pick this iteration's 2e cutoff. Loose early ! (coupled to the previous iteration's DIIS error), pinned to the user's ! tight cutoff in the convergence tail. fock_jk re-reads ! infos%control%int2e_cutoff on every build, so setting it here suffices. if ( ps_on ) then if ( ps_pin ) then ps_tau = ps_cut_tight ! latched: tight for the rest of the SCF else if ( iter == 1 ) then ps_tau = ps_cap ! loosest cutoff for the first build else ps_tau = max ( ps_cut_tight , min ( ps_cap , ps_k * diis_error )) end if infos % control % int2e_cutoff = ps_tau end if ! Progressive XC: loosen the grid thresholds during the descent, restore (pin) in ! the tail. Uses the same ps_pin latch set above, so ERI and XC tighten together. if ( ps_xc ) then if ( ps_pin ) then infos % dft % grid_density_cutoff = ps_xc_dcut0 infos % dft % grid_ao_threshold = ps_xc_aocut0 else if ( ps_xc_dcut > 0.0_dp ) infos % dft % grid_density_cutoff = ps_xc_dcut if ( ps_xc_aocut > 0.0_dp ) infos % dft % grid_ao_threshold = ps_xc_aocut end if end if ! Coarse->fine grid selection (shares the ps_pin latch): coarse grid during the ! descent, full grid once pinned so the converged XC energy is unchanged. if ( ps_grid_on ) then if ( ps_pin ) then ps_cur_grid => molGrid else ps_cur_grid => coarseGrid end if end if ! Incremental-Fock refresh. The incremental build forms F = F_old + G[dD] and ! screens the two-electron contributions on the *shrinking* dD; as dD -> 0 the ! int2e_cutoff drops proportionally more terms, so F_old drifts (~1e-8) and the ! DIIS error plateaus at that noise floor (it cannot reach conv). Periodically, ! and every iteration once in the tight tail, rebuild the FULL Fock by zeroing ! the incremental history -- this clears the accumulated drift (so DIIS converges ! cleanly, matching a from-scratch build) while keeping incremental's per-cycle ! savings during the global descent. With progressive screening, ALSO rebuild ! whenever we pin to the tight cutoff, so contributions dropped during the loose ! phase are recaptured and the converged energy matches the all-tight run. if ( infos % control % scf_incremental /= 0 . and . iter > 1 ) then if ( mod ( iter , 10 ) == 0 . or . diis_error < 1.0e-4_dp . or . (( ps_on . or . ps_grid_on ) . and . ps_pin )) then fold = 0.0_dp dold = 0.0_dp end if end if ! Opt 2 (IncDFT): decide whether to reuse the reference XC this iteration. ! diis_error here is the previous iteration's value (set after calc_fock), ! a valid proxy for closeness to convergence; the reuse window forces full ! XC builds again once near convergence (diis_error < incdft_stop, aligned ! with the J/K incremental refresh above) so the fixed point stays exact. xc_reuse_now = . false . if ( use_incdft ) xc_reuse_now = incdft_should_reuse ( diis_error , iter ) ! The progressive coarse->fine grid ramp and IncDFT's collocation-Phi cache are ! incompatible while the grid is coarse (the cache is grid-specific): never reuse ! XC during the loose/coarse phase. Once pinned the grid is the full grid again ! and reuse is valid. (Both default off, so this is a no-op on the default path.) if ( ps_grid_on . and . . not . ps_pin ) xc_reuse_now = . false . if ( ps_timer ) call system_clock ( ps_t0 , ps_rate ) call calc_fock ( basis , infos , ps_cur_grid , pfock , energy , mo_a , pdmat , mo_b , nschwz , fold , dold , & xc_reuse = xc_reuse_now ) if ( ps_timer ) then call system_clock ( ps_t1 ) write ( IW , '(3x,a,i4,a,f10.4,a,es9.2,a,i0)' ) 'pscreen iter ' , iter , & '  Fock(s)=' , real ( ps_t1 - ps_t0 , dp ) / real ( max ( 1_8 , ps_rate ), dp ), & '  tau=' , infos % control % int2e_cutoff , '  skip=' , nschwz end if !---------------------------------------------------------------------------- ! Form Special ROHF Fock Matrix and Apply Vshift (if ROHF calculation) !---------------------------------------------------------------------------- do_check = ( scf_type == scf_rohf ) . and . & ( . not .( use_soscf . or . use_trah ) . or . iter == 1 ) if ( do_check ) then ! Store the original alpha Fock matrix before ROHF transformation rohf_bak = pfock ! Turn off level shifting for the final iteration if requested if ( vshift_last_iter ) vshift = 0.0_dp ! Apply the Guest-Saunders ROHF Fock transformation call form_rohf_fock ( pfock (:, 1 ), pfock (:, 2 ), mo_a , smat_full , & nelec_a , nelec_b , nbf , vshift , work1 , work2 ) ! Combine alpha and beta densities for ROHF pdmat (:, 1 ) = pdmat (:, 1 ) + pdmat (:, 2 ) end if !---------------------------------------------------------------------------- ! Apply Vshift for RHF/UHF (if enabled) !---------------------------------------------------------------------------- if ( vshift > 0.0_dp . and . scf_type /= scf_rohf ) then ! Turn off level shifting for the final iteration if requested if ( vshift_last_iter ) vshift = 0.0_dp ! Apply level shifting based on SCF type select case ( scf_type ) case ( scf_rhf ) ! RHF: One Fock matrix with doubly occupied orbitals call level_shift_fock ( pfock (:, 1 ), mo_a , smat_full , nelec / 2 , nbf , vshift , & work1 , work2 ) case ( scf_uhf ) ! UHF: Two Fock matrices with separate alpha and beta occupations call level_shift_fock ( pfock (:, 1 ), mo_a , smat_full , nelec_a , nbf , vshift , & work1 , work2 ) if ( nelec_b > 0 ) then call level_shift_fock ( pfock (:, 2 ), mo_b , smat_full , nelec_b , nbf , vshift , & work1 , work2 ) end if end select end if !---------------------------------------------------------------------------- ! Pass Fock and Density to Convergence Accelerator !---------------------------------------------------------------------------- if ( use_soscf ) then select case ( scf_type ) case ( scf_rhf ) call conv % add_data ( & f = pfock (:, 1 : diis_nfocks ), & dens = pdmat (:, 1 : diis_nfocks ), & e = energy % etot , & mo_a = mo_a , & mo_e_a = mo_energy_a ) case ( scf_rohf ) call conv % add_data ( & f = pfock (:, 1 : soscf_nfocks ), & dens = pdmat (:, 1 : soscf_nfocks ), & e = energy % etot , & mo_a = mo_a , & mo_b = mo_b , & mo_e_a = mo_energy_a , & mo_e_b = mo_energy_b ) case ( scf_uhf ) call conv % add_data ( & f = pfock (:, 1 : diis_nfocks ), & dens = pdmat (:, 1 : diis_nfocks ), & e = energy % etot , & mo_a = mo_a , & mo_b = mo_b , & mo_e_a = mo_energy_a , & mo_e_b = mo_energy_b ) end select elseif ( use_trah ) then select case ( scf_type ) case ( scf_rhf ) call conv % add_data ( & f = pfock (:, 1 : diis_nfocks ), & dens = pdmat (:, 1 : diis_nfocks ), & e = energy % etot , & mo_a = mo_a , & mo_e_a = mo_energy_a ) case ( scf_rohf ) call conv % add_data ( & f = pfock (:, 1 : soscf_nfocks ), & dens = pdmat (:, 1 : soscf_nfocks ), & e = energy % etot , & mo_a = mo_a , & mo_b = mo_b , & mo_e_a = mo_energy_a , & mo_e_b = mo_energy_b ) case ( scf_uhf ) call conv % add_data ( & f = pfock (:, 1 : diis_nfocks ), & dens = pdmat (:, 1 : diis_nfocks ), & e = energy % etot , & mo_a = mo_a , & mo_b = mo_b , & mo_e_a = mo_energy_a , & mo_e_b = mo_energy_b ) end select else ! DIIS: Only pass Fock and density matrices call conv % add_data ( & f = pfock (:, 1 : diis_nfocks ), & dens = pdmat (:, 1 : diis_nfocks ), & e = energy % etot ) end if !---------------------------------------------------------------------------- ! Run Convergence Accelerator (DIIS/SOSCF) !---------------------------------------------------------------------------- call conv % run ( conv_res ) if ( use_trah . and . trim ( conv_res % active_converger_name ) == 'TRAH' ) then call run_otr ( infos , molgrid , conv , conv_res , energy ) if ( conv_res % ierr == 4 ) exit call conv_res % get_fock ( pfock , istat = stat ) call conv_res % get_mo_a ( mo_a , istat = stat ) ! Retrieve updated Energies of Alpha Orbitals call conv_res % get_mo_e_a ( mo_energy_a , istat = stat ) if ( scf_type == scf_uhf . and . nelec_b /= 0 ) then ! Retrieve updated Beta Orbitals and its Energies call conv_res % get_mo_b ( mo_b , stat ) call conv_res % get_mo_e_b ( mo_energy_b , stat ) elseif ( scf_type == scf_rohf ) then mo_b = mo_a mo_energy_b = mo_energy_a end if call get_ab_initio_density ( pdmat (:, 1 ), mo_a , pdmat (:, 2 ), mo_b , infos , basis ) ! TRAH returns rotated (non-canonical) orbitals/energies. Diagonalize ! the converged Fock so post-SCF properties and analytic gradients receive ! canonical MOs and orbital energies (same density/energy at the stationary ! point). RHF/UHF use the spin Fock directly; ROHF needs its effective Fock ! and is left to the existing ROHF handling. if ( infos % control % trh_impl == 1 . and . scf_type /= scf_rohf ) then if ( do_mom ) then ! MOM: the aufbau fill in get_ab_initio_orbital can drop the ! state-specific occupation TRAH converged to (TRAH itself preserves ! the occupied space by rotation, so the energy/density built above are ! already on the target). Use the TRAH-converged MOs as the MOM ! reference so the canonical MOs -- and the density rebuilt from them -- ! keep the targeted occupied space. mo_a_prev = mo_a ; mo_e_a_prev = mo_energy_a call get_ab_initio_orbital ( pfock (:, 1 ), mo_a , mo_energy_a , qmat ) call apply_mom ( infos , mo_a_prev , mo_e_a_prev , mo_a , mo_energy_a , & smat_full , nelec_a , \"Alpha\" , work1 , work2 ) if ( scf_type == scf_uhf . and . nelec_b /= 0 ) then mo_b_prev = mo_b ; mo_e_b_prev = mo_energy_b call get_ab_initio_orbital ( pfock (:, 2 ), mo_b , mo_energy_b , qmat ) call apply_mom ( infos , mo_b_prev , mo_e_b_prev , mo_b , mo_energy_b , & smat_full , nelec_b , \"Beta\" , work1 , work2 ) end if call get_ab_initio_density ( pdmat (:, 1 ), mo_a , pdmat (:, 2 ), mo_b , infos , basis ) else call get_ab_initio_orbital ( pfock (:, 1 ), mo_a , mo_energy_a , qmat ) if ( scf_type == scf_uhf . and . nelec_b /= 0 ) & call get_ab_initio_orbital ( pfock (:, 2 ), mo_b , mo_energy_b , qmat ) end if end if end if diis_error = conv_res % get_error () if ( use_soscf ) then rms_grad = conv_res % get_rms_grad () rms_dp = conv_res % get_rms_dp () end if !---------------------------------------------------------------------------- ! Print Current Energy !---------------------------------------------------------------------------- ! Print iteration information if ( infos % control % pfon ) then write ( IW , fmt = \"(4x,i4.1,2x,a23,1x,a23,1x,i16,1x,a14,5x,f5.3,5x,a,5x,a,f9.2)\" ) & iter , fmt_real17 ( energy % etot ), fmt_real17 ( energy % etot - e_old ), nschwz , & fmt_real14 ( diis_error ), vshift , & trim ( conv_res % active_converger_name ), \"Temp:\" , pfon % temp write ( IW , fmt = \"(100x,a,f9.2)\" ) \"Beta:\" , pfon % beta elseif ( infos % control % converger_type == scf_bfgs ) then write ( IW , '(4x,i4.1,2x,a23,1x,a23,1x,i16,1x,a14,1x,a14,5x,f5.3,5x,a)' ) & iter , fmt_real17 ( energy % etot ), fmt_real17 ( energy % etot - e_old ), nschwz , & fmt_real14 ( rms_grad ), fmt_real14 ( rms_dp ), vshift , & trim ( conv_res % active_converger_name ) elseif ( use_trah ) then !              write(IW, \"(10x, '')\") else write ( IW , '(4x,i4.1,2x,a23,1x,a23,1x,i16,1x,a14,5x,f5.3,5x,a)' ) & iter , fmt_real17 ( energy % etot ), fmt_real17 ( energy % etot - e_old ), nschwz , & fmt_real14 ( diis_error ), vshift , & trim ( conv_res % active_converger_name ) end if call flush ( IW ) !---------------------------------------------------------------------------- ! Orchestration: detect converger stagnation and hand off early !---------------------------------------------------------------------------- ! A converger that stops reducing its error for many iterations while still ! above the threshold is stuck near its noise floor (e.g. C-DIIS oscillating ! at ~1e-8 from integral/grid noise). Rather than spin to maxit, bail out so ! the escalation ladder (DIIS -> SOSCF -> TRAH) hands the residual gradient ! to a higher-order method. Skipped for TRAH (the last-resort solver) and ! while a level shift / pFON anneal is still ramping the error artificially. if (. not . use_trah . and . vshift == 0.0_dp . and . . not . do_pfon ) then if ( diis_error < 0.5_dp * stall_best ) then stall_best = diis_error stall_count = 0 else stall_count = stall_count + 1 end if if ( stall_count >= 12 . and . iter >= 20 . and . & diis_error > infos % control % conv ) then if ( ps_grid_on . and . . not . ps_pin ) then ! Stalled while still on the coarse descent grid: pin to the full grid ! and give it a chance before handing off, so the reported state (and ! any escalation warm-start) comes from the full grid, not the coarse one. ps_pin = . true . stall_best = huge ( 1.0_dp ) stall_count = 0 else write ( IW , \"(3x,64('-')/10x,'Converger stalled (error ',ES9.2, & &' flat for ',I0,' iters); handing off to the escalation ladder.')\" ) & diis_error , stall_count infos % mol_energy % SCF_converged = . false . stalled_exit = . true . exit end if end if end if !---------------------------------------------------------------------------- ! Update VDIIS Parameters (if using VDIIS) !---------------------------------------------------------------------------- if (( infos % control % diis_type == 5 ) . and . & ( diis_error < infos % control % vdiis_vshift_switch )) then vshift = 0.0_dp else if (( infos % control % diis_type == 5 ) . and . & ( diis_error >= infos % control % vdiis_vshift_switch )) then vshift = infos % control % vshift end if e_old = energy % etot !---------------------------------------------------------------------------- ! Progressive screening: never accept convergence on a loose/coarse build. ! diis_error can drop from > pscreen_tight to < conv in a single step, which ! would otherwise exit right after a loose-cutoff / coarse-grid Fock and report ! that approximate energy. Force one pinned full-accuracy iteration (tight ! int2e_cutoff + XC thresholds + full grid) before convergence is allowed. !---------------------------------------------------------------------------- ps_force_iter = . false . if (( ps_on . or . ps_grid_on ) . and . . not . ps_pin & . and . ( abs ( diis_error ) < infos % control % conv ) . and . ( vshift == 0.0_dp )) then ps_pin = . true . ps_force_iter = . true . write ( IW , \"(3x,64('-')/10x,'Coarse-to-fine / progressive screening: final full-accuracy SCF iteration.')\" ) end if !---------------------------------------------------------------------------- ! Check for SCF Convergence !---------------------------------------------------------------------------- ! Convergence guards (both .false. on the default path, so a no-op there): !  - ps_force_iter (progressive screening): never converge on a loose/coarse build. !  - xc_reuse_now (IncDFT): never converge on an iteration whose XC was reused !    (stale); the next iteration forces a full XC build so the fixed point is exact. if (( abs ( diis_error ) < infos % control % conv ) . and . ( vshift == 0.0_dp ) & . and . (. not . ps_force_iter ) . and . (. not . xc_reuse_now )) then ! Fully converged - exit loop if ( do_pfon ) then if ( pfon % temp > 1.0_dp + 1.0e-6_dp ) then do_pfon_final = . true . else exit end if else if ( vshift_last_iter ) vshift = 0.0_dp call handle_soscf_trah_rohf ( use_soscf , use_trah , scf_type , pfock , rohf_bak , & mo_a , mo_b , mo_energy_a , mo_energy_b , & qmat , smat_full , nelec_a , nelec_b , nbf , nbf_tri , vshift , & work1 , work2 , infos , basis , & dens_prev , pdmat ) exit end if elseif (( abs ( diis_error ) < infos % control % conv ) . and . ( vshift /= 0.0_dp )) then ! Converged but need one more iteration with vshift=0 write ( IW , \"(3x,64('-')/10x,'Performing a last SCF with zero VSHIFT.')\" ) vshift_last_iter = . true . elseif ( vshift_last_iter ) then ! Only for ROHF case the final iteration with vshift=0 complete - exit loop call get_ab_initio_orbital ( pfock (:, 1 ), mo_a , mo_energy_a , qmat ) exit end if !---------------------------------------------------------------------------- ! Reset DIIS !---------------------------------------------------------------------------- ! Vshift=0.0 and slow cases ! Check if DIIS reset is needed diis_reset_condition = ((( iter / diis_reset ) >= 1 ) . and . & ( modulo ( iter , diis_reset ) == 0 ) . and . & ( diis_error > infos % control % diis_reset_conv ) . and . & ( infos % control % vshift == 0.0_dp ) . and . & ( infos % control % converger_type == scf_diis )) if ( diis_reset_condition ) then ! Resetting DIIS for difficult cases write ( IW , \"(3x,64('-')/10x,'Resetting DIIS.')\" ) call conv_res % get_fock ( matrix = pfock (:, 1 : diis_nfocks ), istat = stat ) call conv % init ( ldim = nbf , & maxvec = maxdiis , & subconvergers = [ conv_cdiis ], & thresholds = [ ethr_cdiis_big ], & overlap = smat_full , & overlap_sqrt = qmat , & num_focks = diis_nfocks , & verbose = int ( infos % control % verbose )) ! After resetting DIIS, we need to skip SD call conv % add_data ( f = pfock (:, 1 : diis_nfocks ), & dens = pdmat (:, 1 : diis_nfocks ), & e = energy % Etot ) call conv % run ( conv_res ) end if !---------------------------------------------------------------------------- ! Update Fock or Orbitals and Eigenvalues Based on Active Converger !---------------------------------------------------------------------------- if ( use_soscf . and . trim ( conv_res % active_converger_name ) == 'SOSCF' ) then ! SOSCF: Retrieve updated MOs and energies directly ! Note: Fock matrix is fixed in SOSCF; !       rebuilt in next iteration, !       Fock is not retrieved here. if ( int2_driver % pe % rank == 0 ) then ! Retrieve updated Alpha Orbitals call conv_res % get_mo_a ( mo_a , istat = stat ) ! Retrieve updated Energies of Alpha Orbitals call conv_res % get_mo_e_a ( mo_energy_a , istat = stat ) if ( scf_type == scf_uhf . and . nelec_b /= 0 ) then ! Retrieve updated Beta Orbitals and its Energies call conv_res % get_mo_b ( mo_b , stat ) call conv_res % get_mo_e_b ( mo_energy_b , stat ) elseif ( scf_type == scf_rohf ) then mo_b = mo_a mo_energy_b = mo_energy_a end if if ( stat /= 0 ) then call show_message ( 'Error retrieving SOSCF results' , WITH_ABORT ) end if end if else ! DIIS: Retrieve updated Fock directly ! Form the interpolated the Fock/Density matrix call conv_res % get_fock ( matrix = pfock (:, 1 : diis_nfocks ), istat = stat ) if ( int2_driver % pe % rank == 0 ) then ! Compute New Alpha Orbitals call get_ab_initio_orbital ( pfock (:, 1 ), mo_a , mo_energy_a , qmat ) if ( scf_type == scf_uhf . and . nelec_b /= 0 ) then ! Only UHF has beta orbitals. call get_ab_initio_orbital ( pfock (:, 2 ), mo_b , mo_energy_b , qmat ) end if end if end if ! Broadcast updated orbitals to all processes call int2_driver % pe % bcast ( mo_a , size ( mo_a )) call int2_driver % pe % bcast ( mo_energy_a , size ( mo_energy_a )) if ( scf_type == scf_uhf . and . nelec_b /= 0 ) then call int2_driver % pe % bcast ( mo_b , size ( mo_b )) call int2_driver % pe % bcast ( mo_energy_b , size ( mo_energy_b )) end if !---------------------------------------------------------------------------- ! Calculate pFON Occupations (if enabled) !---------------------------------------------------------------------------- call pfon % compute_occupations ( mo_energy_a , do_pfon , mo_energy_b ) !---------------------------------------------------------------------------- ! Apply MOM (Maximum Overlap Method) if enabled !---------------------------------------------------------------------------- call handle_mom ( infos , do_mom , diis_error , scf_type , & nelec_a , nelec_b , mo_a , mo_energy_a , & mo_b , mo_energy_b , mo_a_prev , mo_e_a_prev , & mo_b_prev , mo_e_b_prev ,& smat_full , work1 , work2 ,& mom_active , initial_mom_iter , & . false ., IW ) !---------------------------------------------------------------------------- ! Apply XAS if enabled !---------------------------------------------------------------------------- if ( do_rstctmo ) then call apply_mom ( infos , mo_a_for_rstctmo , mo_energy_a_for_rstctmo , & mo_a , mo_energy_a , smat_full , nelec_a , \"Alpha\" , work1 , work2 ) end if !---------------------------------------------------------------------------- ! Build New Density Matrix from Updated Orbitals !---------------------------------------------------------------------------- if ( int2_driver % pe % rank == 0 ) then call pfon % build_density ( pdmat (:, 1 ), mo_a , work1 , work2 , do_pfon , pdmat (:, 2 ), mo_b ) if (. not . do_pfon ) & call get_ab_initio_density ( pdmat (:, 1 ), mo_a , pdmat (:, 2 ), mo_b , infos , basis ) end if call int2_driver % pe % bcast ( pdmat , size ( pdmat )) !---------------------------------------------------------------------------- ! Check HOMO-LUMO Gap for Convergence Prediction !---------------------------------------------------------------------------- call handle_homo_lumo_gap ( iter , scf_type , nelec , nelec_a , nelec_b , & mo_energy_a , mo_energy_b , vshift , IW , & H_U_gap , modify_vshift = . false ., do_print = . true .) select case ( scf_type ) case ( scf_rhf ) call add_potqm_contributions ( infos , pdmat (:, 1 ), dhcore ) case ( scf_uhf , scf_rohf ) call add_potqm_contributions ( infos , pdmat (:, 1 ) + pdmat (:, 2 ), dhcore ) end select hcore = hcore_bk + dhcore ! End of Main SCF Iteration Loop end do ! Restore the user's tight 2e cutoff for any downstream builds (gradient, ! properties, response) regardless of where the SCF loop exited. if ( ps_on ) infos % control % int2e_cutoff = ps_cut_tight if ( ps_xc ) then infos % dft % grid_density_cutoff = ps_xc_dcut0 infos % dft % grid_ao_threshold = ps_xc_aocut0 end if !---------------------------------------------------------------------------- ! Clean Convergence Accelerator (DIIS/SOSCF) !---------------------------------------------------------------------------- call conv % clean () !============================================================================== ! Post-SCF Processing and Final Output !============================================================================== !---------------------------------------------------------------------------- ! Report SCF Convergence Status !---------------------------------------------------------------------------- if ( use_trah ) iter = conv_res % get_iter () if ( stalled_exit ) then write ( IW , \"(3x,64('-')/10x,'SCF stalled before convergence; escalating to a higher-order solver.')\" ) infos % mol_energy % SCF_converged = . false . else if ( iter > maxit ) then write ( IW , \"(3x,64('-')/10x,'SCF did not converge. Restarting SCF with the TRAH method.')\" ) infos % mol_energy % SCF_converged = . false . else write ( IW , \"(3x,64('-')/10x,'SCF convergence achieved ....')\" ) infos % mol_energy % SCF_converged = . true . end if write ( IW , \"(/' Final ',A,' energy is',F20.10,' after',I4,' iterations'/)\" ) trim ( scf_name ), energy % etot , iter !---------------------------------------------------------------------------- ! Print DFT-Specific Information (if DFT) !---------------------------------------------------------------------------- if ( is_dft ) then write ( IW , * ) write ( IW , \"(' DFT: XC energy              = ',F20.10)\" ) energy % eexc write ( IW , \"(' DFT: total electron density = ',F20.10)\" ) energy % totele write ( IW , \"(' DFT: number of electrons    = ',I9,/)\" ) nelec end if !---------------------------------------------------------------------------- ! Broadcast Final MOs and Energies to All Processes !---------------------------------------------------------------------------- call int2_driver % pe % bcast ( pdmat , size ( pdmat )) call int2_driver % pe % bcast ( mo_a , size ( mo_a )) call int2_driver % pe % bcast ( mo_energy_a , size ( mo_energy_a )) if ( scf_type == scf_uhf . and . nelec_b /= 0 ) then call int2_driver % pe % bcast ( mo_b , size ( mo_b )) call int2_driver % pe % bcast ( mo_energy_b , size ( mo_energy_b )) end if if ( scf_type == scf_uhf ) then call get_ab_initio_orbital ( pfock (:, 1 ), mo_a , mo_energy_a , qmat ) call get_ab_initio_orbital ( pfock (:, 2 ), mo_b , mo_energy_b , qmat ) endif !---------------------------------------------------------------------------- ! Save Final Fock and Density Matrices !---------------------------------------------------------------------------- select case ( scf_type ) case ( scf_rhf ) fock_a = pfock (:, 1 ) dmat_a = pdmat (:, 1 ) case ( scf_uhf ) fock_a = pfock (:, 1 ) fock_b = pfock (:, 2 ) dmat_a = pdmat (:, 1 ) dmat_b = pdmat (:, 2 ) case ( scf_rohf ) fock_a = rohf_bak (:, 1 ) fock_b = rohf_bak (:, 2 ) !      call mo_to_ao(fock_b, pfock(:,2), smat_full, mo_a, nbf, nbf, work1, work2) dmat_a = pdmat (:, 1 ) - pdmat (:, 2 ) dmat_b = pdmat (:, 2 ) mo_b = mo_a mo_energy_b = mo_energy_a end select !  Construct ESPF partial charges and print MM energy in output (only done if QM/MM run) !     select case (scf_type) !     case (scf_rhf) !       add_potqm_contributions(infos, dmat_a, h1e) !       call form_esp_charges(infos,dmat_a,nbf) !     case (scf_uhf,scf_rohf) !       call add_potqm_contributions(infos, dmat_a+dmat_b, h1e) !       call form_esp_charges(infos,dmat_a+dmat_b,nbf) !     end select !---------------------------------------------------------------------------- ! Print Molecular Orbitals !---------------------------------------------------------------------------- call print_mo_range ( basis , infos , mostart = 1 , moend = nbf ) !---------------------------------------------------------------------------- ! Calculate Final Energy Components !---------------------------------------------------------------------------- energy % psinrm = 0.0_dp energy % tkin = 0.0_dp do i = 1 , diis_nfocks energy % psinrm = energy % psinrm + traceprod_sym_packed ( pdmat (:, i ), smat , nbf ) / nelec energy % tkin = energy % tkin + traceprod_sym_packed ( pdmat (:, i ), tmat , nbf ) end do ! Calculate energy components energy % vne = energy % ehf1 - energy % tkin energy % vee = energy % etot - energy % ehf1 - energy % nenergy energy % vnn = energy % nenergy energy % vtot = energy % vne + energy % vnn + energy % vee energy % virial = - energy % vtot / energy % tkin !---------------------------------------------------------------------------- ! Print Final Energy Components !---------------------------------------------------------------------------- call energy % print_e () !---------------------------------------------------------------------------- ! Save Results to infos Structure !---------------------------------------------------------------------------- infos % mol_energy % energy = energy % etot infos % mol_energy % psinrm = energy % psinrm infos % mol_energy % ehf1 = energy % ehf1 infos % mol_energy % vee = energy % vee infos % mol_energy % nenergy = energy % nenergy infos % mol_energy % vne = energy % vne infos % mol_energy % vnn = energy % vnn infos % mol_energy % vtot = energy % vtot infos % mol_energy % tkin = energy % tkin infos % mol_energy % virial = energy % virial infos % mol_energy % energy = energy % etot !---------------------------------------------------------------------------- ! Clean Up Resources !---------------------------------------------------------------------------- call int2_driver % clean () call measure_time ( print_total = 1 , log_unit = IW ) !---------------------------------------------------------------------------- ! Clean up in the finalization section !---------------------------------------------------------------------------- if ( do_mom ) then if ( allocated ( mo_a_prev )) deallocate ( mo_a_prev ) if ( allocated ( mo_e_a_prev )) deallocate ( mo_e_a_prev ) if ( allocated ( mo_b_prev )) deallocate ( mo_b_prev ) if ( allocated ( mo_e_b_prev )) deallocate ( mo_e_b_prev ) end if end subroutine scf_driver subroutine handle_soscf_trah_rohf ( use_soscf , use_trah , scf_type , & pfock , rohf_bak , & mo_a , mo_b , mo_energy_a , mo_energy_b , & qmat , smat_full , & nelec_a , nelec_b , nbf , nbf_tri , vshift , & work1 , work2 , & infos , basis , & dens_prev , pdmat ) use precision , only : dp use types , only : information use scf_addons , only : scf_rhf , scf_uhf , scf_rohf use basis_tools , only : basis_set use guess , only : get_ab_initio_density , get_ab_initio_orbital implicit none ! Inputs / inouts mirroring your code logical , intent ( in ) :: use_soscf , use_trah integer , intent ( in ) :: scf_type , nelec_a , nelec_b , nbf , nbf_tri real ( dp ), intent ( inout ) :: pfock (:,:) ! (nbf, 2) real ( dp ), intent ( inout ) :: rohf_bak (:,:) ! (nbf, 2) real ( dp ), intent ( inout ) :: mo_a (:,:), mo_b (:,:) real ( dp ), intent ( inout ) :: mo_energy_a (:), mo_energy_b (:) real ( dp ), intent ( inout ) :: qmat (:,:), smat_full (:,:) real ( dp ), intent ( inout ) :: vshift real ( dp ), intent ( inout ) :: work1 (:,:), work2 (:,:) type ( information ), intent ( inout ) :: infos type ( basis_set ), intent ( in ) :: basis real ( dp ), intent ( inout ) :: dens_prev (:,:) ! (nbf_tri, 2) real ( dp ), intent ( inout ) :: pdmat (:,:) ! (nbf_tri, 2) ! locals integer :: i real ( dp ) :: delta_dens_a , delta_dens_b if (. not .( use_soscf . or . use_trah )) return if ( scf_type == scf_rohf ) then rohf_bak (:, 1 ) = pfock (:, 1 ) rohf_bak (:, 2 ) = pfock (:, 2 ) ! Build ROHF effective Fock(s) call form_rohf_fock ( pfock (:, 1 ), pfock (:, 2 ), mo_a , smat_full , & nelec_a , nelec_b , nbf , vshift , work1 , work2 ) end if ! Diagonalize alpha Fock call get_ab_initio_orbital ( pfock (:, 1 ), mo_a , mo_energy_a , qmat ) ! Spin treatment if ( scf_type == scf_rohf ) then mo_b = mo_a mo_energy_b = mo_energy_a else if ( scf_type == scf_uhf ) then call get_ab_initio_orbital ( pfock (:, 2 ), mo_b , mo_energy_b , qmat ) end if ! Build densities from MOs (both spins) call get_ab_initio_density ( dens_prev (:, 1 ), mo_a , & dens_prev (:, 2 ), mo_b , infos , basis ) ! ROHF post-fix based on density delta if ( scf_type == scf_rohf ) then delta_dens_a = 0.0_dp delta_dens_b = 0.0_dp do i = 1 , nbf_tri delta_dens_a = delta_dens_a + abs ( dens_prev ( i , 1 ) - pdmat ( i , 1 )) delta_dens_b = delta_dens_b + abs ( dens_prev ( i , 2 ) - pdmat ( i , 2 )) end do if ( delta_dens_a > 0.1_dp ) then call rohf_fix ( mo_a , mo_energy_a , pdmat (:, 1 ), smat_full , nelec_a , nbf , nbf ) mo_b = mo_a mo_energy_b = mo_energy_a end if if ( delta_dens_b > 0.1_dp ) then call rohf_fix ( mo_b , mo_energy_b , pdmat (:, 2 ), smat_full , nelec_b , nelec_a , nbf ) mo_a = mo_b mo_energy_a = mo_energy_b end if ! Combine spin densities pdmat (:, 1 ) = pdmat (:, 1 ) + pdmat (:, 2 ) end if end subroutine handle_soscf_trah_rohf subroutine handle_mom ( infos , do_mom , diis_error , scf_type , & nelec_a , nelec_b , & mo_a , mo_energy_a , & mo_b , mo_energy_b , & mo_a_prev , mo_e_a_prev , & mo_b_prev , mo_e_b_prev , & smat_full , work1 , work2 , & mom_active , initial_mom_iter , & do_print , IW ) use precision , only : dp use types , only : information use scf_addons , only : apply_mom , scf_rhf , scf_uhf , scf_rohf implicit none type ( information ), intent ( inout ) :: infos logical , intent ( in ) :: do_mom real ( dp ), intent ( in ) :: diis_error integer , intent ( in ) :: scf_type , nelec_a , nelec_b real ( dp ), intent ( inout ) :: mo_a (:,:), mo_energy_a (:) real ( dp ), intent ( inout ), optional :: mo_b (:,:), mo_energy_b (:) real ( dp ), intent ( in ) :: smat_full (:,:) real ( dp ), intent ( inout ) :: work1 (:,:), work2 (:,:) logical , intent ( inout ) :: mom_active , initial_mom_iter logical , intent ( in ) :: do_print integer , intent ( in ) :: IW real ( dp ), intent ( inout ) :: mo_a_prev (:,:), mo_e_a_prev (:) real ( dp ), intent ( inout ), optional :: mo_b_prev (:,:), mo_e_b_prev (:) if (. not . do_mom ) return if ( diis_error < infos % control % mom_switch ) then if (. not . mom_active . and . do_print ) then write ( IW , \"(3x,'MOM activated: diis_error=',ES12.5,' < mom_switch=',ES12.5)\" ) diis_error , infos % control % mom_switch end if mom_active = . true . end if if ( mom_active . and . . not . initial_mom_iter ) then ! Alpha call apply_mom ( infos , mo_a_prev , mo_e_a_prev , & mo_a , mo_energy_a , smat_full , nelec_a , & \"Alpha\" , work1 , work2 ) ! Beta channel only for UHF with electrons and if arrays are present if ( scf_type == scf_uhf . and . nelec_b > 0 . and . present ( mo_b ) . and . present ( mo_energy_b ) & . and . present ( mo_b_prev ) . and . present ( mo_e_b_prev )) then call apply_mom ( infos , mo_b_prev , mo_e_b_prev , & mo_b , mo_energy_b , smat_full , nelec_b , & \"Beta\" , work1 , work2 ) end if end if mo_a_prev = mo_a mo_e_a_prev = mo_energy_a if ( scf_type == scf_uhf . and . present ( mo_b ) . and . present ( mo_b_prev ) . and . present ( mo_energy_b ) . and . present ( mo_e_b_prev )) then mo_b_prev = mo_b mo_e_b_prev = mo_energy_b end if initial_mom_iter = . false . end subroutine handle_mom subroutine handle_homo_lumo_gap ( iter , scf_type , nelec , nelec_a , nelec_b , & mo_e_a , mo_e_b , vshift , IW , & gap_out , & modify_vshift , do_print ) use precision , only : dp use scf_addons , only : scf_rhf , scf_uhf , scf_rohf implicit none integer , intent ( in ) :: iter , scf_type integer , intent ( in ) :: nelec , nelec_a , nelec_b real ( dp ), intent ( in ) :: mo_e_a (:) real ( dp ), intent ( in ), optional :: mo_e_b (:) real ( dp ), intent ( inout ) :: vshift integer , intent ( in ) :: IW real ( dp ), intent ( inout ) :: gap_out logical , intent ( in ) :: modify_vshift , do_print integer , PARAMETER :: iter_min = 20 real ( dp ), PARAMETER :: gap_crit = 0.02_dp integer :: nocc , nocc_a , nocc_b real ( dp ) :: ga , gb gap_out = - 1.0_dp if ( iter <= iter_min ) return select case ( scf_type ) case ( scf_rhf ) !RHF nocc = nelec / 2 gap_out = mo_e_a ( nocc + 1 ) - mo_e_a ( nocc ) case ( scf_uhf ) !UHF ga = mo_e_a ( nelec_a + 1 ) - mo_e_a ( nelec_a ) gb = mo_e_b ( nelec_b + 1 ) - mo_e_b ( nelec_b ) gap_out = min ( ga , gb ) case ( scf_rohf ) !ROHF gap_out = mo_e_a ( nelec_a + 1 ) - mo_e_a ( nelec_a ) end select if ( gap_out >= 0.0_dp . and . gap_out < gap_crit . and . vshift > 0.0_dp ) then if ( modify_vshift ) then !   experimental vshift tweak (replace with your policy as needed) vshift = max ( vshift , 0.5_dp * vshift + 0.01_dp ) end if if ( do_print ) then write ( IW , \"(3x,64('-')/10x,'Small HOMO-LUMO gap detected (',F10.6,' au).',/ & 10x,'Applying level shift vshift = ',F10.6,' au.')\" ) gap_out , vshift end if end if end subroutine handle_homo_lumo_gap !> @brief Configure the SCF convergence accelerator (DIIS / SOSCF / TRAH). !> !> Single source of truth for converger selection.  Behaviour is identical !> to the former inline select-case in scf_driver; it is factored out here so !> all converger-selection logic lives in one place. !> !>   converger_type = scf_diis : DIIS family !>       diis_type = 5 (v-DIIS) -> [c-DIIS, e-DIIS, c-DIIS], auto vshift=0.1 !>       vshift /= 0            -> [c-DIIS, e-DIIS, c-DIIS] with custom vshift !>       otherwise             -> single diis_type method !>   converger_type = scf_bfgs : SOSCF (active from the first iteration) !>   converger_type = scf_trah : TRAH trust-region subroutine init_scf_converger ( infos , molgrid , conv , nbf , nelec_a , nelec_b , & maxdiis , diis_nfocks , soscf_nfocks , & smat_full , qmat , vshift , use_soscf , use_trah ) use precision , only : dp use io_constants , only : iw use types , only : information use mod_dft_molgrid , only : dft_grid_t use scf_converger , only : scf_conv , conv_cdiis , conv_ediis , conv_soscf , conv_trah use scf_addons , only : scf_diis , scf_bfgs , scf_trah implicit none type ( information ), intent ( inout ) :: infos type ( dft_grid_t ), intent ( in ) :: molgrid type ( scf_conv ), intent ( inout ) :: conv integer , intent ( in ) :: nbf , nelec_a , nelec_b integer , intent ( in ) :: maxdiis , diis_nfocks , soscf_nfocks real ( kind = dp ), intent ( in ) :: smat_full (:,:), qmat (:,:) real ( kind = dp ), intent ( inout ) :: vshift logical , intent ( out ) :: use_soscf , use_trah real ( kind = dp ), parameter :: ethr_cdiis_big = 2.0_dp ! c-DIIS error threshold real ( kind = dp ), parameter :: ethr_ediis = 1.0_dp ! e-DIIS error threshold integer :: control_converger , control_diis , control_verbose integer :: control_maxit , control_scftype use_soscf = . false . use_trah = . false . control_converger = int ( infos % control % converger_type ) control_diis = int ( infos % control % diis_type ) control_verbose = int ( infos % control % verbose ) control_maxit = int ( infos % control % maxit ) control_scftype = int ( infos % control % scftype ) select case ( control_converger ) case ( scf_diis ) ! DIIS family if ( control_diis == 5 ) then ! v-DIIS: cascade of c-DIIS / e-DIIS / c-DIIS with level shift call conv % init ( ldim = nbf , & maxvec = maxdiis , & subconvergers = [ conv_cdiis , conv_ediis , conv_cdiis ], & thresholds = [ ethr_cdiis_big , ethr_ediis , & infos % control % cdiis_switch ], & overlap = smat_full , & overlap_sqrt = qmat , & num_focks = diis_nfocks , & verbose = control_verbose ) if ( infos % control % vshift == 0.0_dp ) then infos % control % vshift = 0.1_dp vshift = 0.1_dp write ( iw , '(X,A)' ) 'Setting Vshift = 0.1 a.u., since VDIIS is chosen without Vshift value.' end if elseif ( infos % control % vshift /= 0.0_dp ) then ! Custom level shift with c-DIIS / e-DIIS / c-DIIS cascade call conv % init ( ldim = nbf , & maxvec = maxdiis , & subconvergers = [ conv_cdiis , conv_ediis , conv_cdiis ], & thresholds = [ ethr_cdiis_big , ethr_ediis , & infos % control % cdiis_switch ], & overlap = smat_full , & overlap_sqrt = qmat , & num_focks = diis_nfocks , & verbose = control_verbose ) else ! Standard single DIIS method from input call conv % init ( ldim = nbf , & maxvec = maxdiis , & subconvergers = [ control_diis ], & thresholds = [ ethr_cdiis_big ], & overlap = smat_full , & overlap_sqrt = qmat , & num_focks = diis_nfocks , & verbose = control_verbose ) end if case ( scf_bfgs ) ! SOSCF use_soscf = . true . call conv % init ( ldim = nbf , nelec_a = nelec_a , nelec_b = nelec_b , & maxvec = control_maxit , & subconvergers = [ conv_soscf ], & thresholds = [ huge ( 1.0_dp )], & overlap = smat_full , & overlap_sqrt = qmat , & num_focks = soscf_nfocks , & scf_type = control_scftype , & verbose = control_verbose ) call set_soscf_parametres ( infos , conv ) case ( scf_trah ) ! TRAH use_trah = . true . call conv % init ( ldim = nbf , nelec_a = nelec_a , nelec_b = nelec_b , & maxvec = control_maxit , & subconvergers = [ conv_trah ], & thresholds = [ huge ( 1.0_dp )], & overlap = smat_full , & overlap_sqrt = qmat , & num_focks = soscf_nfocks , & scf_type = control_scftype , & verbose = control_verbose , & sd_scf = infos % control % sd_scf ) call set_trah_parametres ( infos , molgrid , conv ) case default end select end subroutine init_scf_converger !> @In this implementation, we don’t need these parameters— they were added, !> @but they appear to be unnecessary right now. !> @brief Configures parameters for the Second-Order SCF (SOSCF) convergence accelerator. !> @detail Sets SOSCF-specific parameters. !> @author Konstantin Komarov, 2023 !> @param[in] infos System information and control parameters. !> @param[inout] conv SCF convergence driver object. subroutine set_soscf_parametres ( infos , conv ) use types , only : information use scf_converger , only : scf_conv , soscf_converger , & SOSCF_VARIANT_ORIGINAL , SOSCF_VARIANT_STABLE_ONLY , SOSCF_VARIANT_QUAD_LS type ( information ), target , intent ( inout ) :: infos type ( scf_conv ) :: conv integer :: i ! Through accessing the SOSCF converger set its parameters: do i = lbound ( conv % sconv , 1 ), ubound ( conv % sconv , 1 ) select type ( sc => conv % sconv ( i )% s ) type is ( soscf_converger ) sc % level_shift = infos % control % soscf_lvl_shift sc % variant = SOSCF_VARIANT_ORIGINAL sc % soscf_reset_mod = 0 ! no orbital-Hessian reset (preserved default) class default ! not an SOSCF converger; nothing to do end select end do end subroutine set_soscf_parametres subroutine set_trah_parametres ( infos , mol_grid , conv ) use types , only : information use mod_dft_molgrid , only : dft_grid_t use scf_converger , only : scf_conv , trah_converger implicit none type ( information ), target , intent ( inout ) :: infos type ( dft_grid_t ), target , intent ( in ) :: mol_grid type ( scf_conv ) :: conv integer :: i ! Through accessing the TRAH converger set its parameters: do i = lbound ( conv % sconv , 1 ), ubound ( conv % sconv , 1 ) select type ( sc => conv % sconv ( i )% s ) type is ( trah_converger ) sc % infos => infos sc % molgrid => mol_grid sc % is_dft = ( infos % control % hamilton >= 20 ) sc % hf_scale = merge ( infos % dft % HFscale , 1.0_dp , sc % is_dft ) end select end do end subroutine set_trah_parametres subroutine run_otr ( infos , mol_grid , conv , res , energy ) use types , only : information use mod_dft_molgrid , only : dft_grid_t use scf_converger , only : scf_conv , trah_converger , scf_conv_result #ifdef OQP_HAVE_OPENTRAH use otr_interface , only : init_trah_solver , run_trah_solver #endif use trah_native , only : trah_native_run use scf_addons , only : scf_energy_t use io_constants , only : IW implicit none type ( information ), target , intent ( inout ) :: infos type ( dft_grid_t ), target , intent ( in ) :: mol_grid type ( scf_conv ), intent ( inout ) :: conv class ( scf_conv_result ), intent ( inout ) :: res type ( scf_energy_t ), intent ( inout ) :: energy integer :: i ! Through accessing the TRAH converger set its parameters: do i = lbound ( conv % sconv , 1 ), ubound ( conv % sconv , 1 ) select type ( sc => conv % sconv ( i )% s ) type is ( trah_converger ) #ifdef OQP_HAVE_OPENTRAH if ( infos % control % trh_impl == 1 ) then ! native Fortran trust-region augmented-Hessian solver (default) call trah_native_run ( infos , mol_grid , sc , res , energy ) else ! external OpenTrustRegion library (explicit trh_impl=otr) call init_trah_solver ( infos , mol_grid , sc , energy ) call run_trah_solver ( res ) end if #else ! OpenTRAH not compiled (-DENABLE_OPENTRAH=OFF): use the native solver for ! every trh_impl (the external gradient/MRSF reference paths are unavailable). if ( infos % control % trh_impl /= 1 ) & write ( IW , '(5X,A)' ) 'NOTE: OpenTRAH (OpenTrustRegion) is not compiled; using native TRAH.' call trah_native_run ( infos , mol_grid , sc , res , energy ) #endif end select end do end subroutine run_otr !> @brief Forms the ROHF Fock matrix in the MO basis using the Guest-Saunders method. !> @detail Transforms alpha and beta Fock matrices from the AO basis to the MO basis, !>         constructs the ROHF Fock matrix following the Guest-Saunders approach, !>         and optionally applies a level shift to virtual orbitals. !>         Reference: M. F. Guest, V. Saunders. Mol. Phys. 28, 819 (1974). !> @author Konstantin Komarov, 2023 !> @param[inout] fock_a_ao Alpha Fock matrix in AO basis (triangular format). !> @param[inout] fock_b_ao Beta Fock matrix in AO basis (triangular format). !> @param[in] mo_a Alpha MO coefficients. !> @param[in] smat_full Full overlap matrix. !> @param[in] nocca Number of occupied alpha orbitals. !> @param[in] noccb Number of occupied beta orbitals. !> @param[in] nbf Number of basis functions. !> @param[in] vshift Level shift parameter for virtual orbitals. !> @param[inout] work1 Work array 1 (nbf x nbf). !> @param[inout] work2 Work array 2 (nbf x nbf). subroutine form_rohf_fock ( fock_a_ao , fock_b_ao , & mo_a , smat_full , & nocca , noccb , nbf , vshift , & work1 , work2 ) use precision , only : dp use mathlib , only : orthogonal_transform_sym , & orthogonal_transform2 , & unpack_matrix , & pack_matrix implicit none real ( kind = dp ), intent ( inout ), dimension (:) :: fock_a_ao real ( kind = dp ), intent ( inout ), dimension (:) :: fock_b_ao real ( kind = dp ), intent ( in ), dimension (:,:) :: mo_a real ( kind = dp ), intent ( in ), dimension (:,:) :: smat_full real ( kind = dp ), intent ( inout ), dimension (:,:) :: work1 real ( kind = dp ), intent ( inout ), dimension (:,:) :: work2 integer , intent ( in ) :: nocca , noccb , nbf real ( kind = dp ), intent ( in ) :: vshift real ( kind = dp ), allocatable , dimension (:) :: fock_mo real ( kind = dp ), allocatable , dimension (:,:) :: & work_matrix , fock , fock_a , fock_b real ( kind = dp ) :: acc , aoo , avv , bcc , boo , bvv integer :: i , nbf_tri acc = 0.5_dp ; aoo = 0.5_dp ; avv = 0.5_dp bcc = 0.5_dp ; boo = 0.5_dp ; bvv = 0.5_dp nbf_tri = nbf * ( nbf + 1 ) / 2 ! Allocate full matrices allocate ( work_matrix ( nbf , nbf ), & fock ( nbf , nbf ), & fock_mo ( nbf_tri ), & fock_a ( nbf , nbf ), & fock_b ( nbf , nbf ), & source = 0.0_dp ) ! Transform alpha and beta Fock matrices to MO basis call orthogonal_transform_sym ( nbf , nbf , fock_a_ao , mo_a , nbf , fock_mo ) fock_a_ao (: nbf_tri ) = fock_mo (: nbf_tri ) call orthogonal_transform_sym ( nbf , nbf , fock_b_ao , mo_a , nbf , fock_mo ) fock_b_ao (: nbf_tri ) = fock_mo (: nbf_tri ) ! Unpack triangular matrices to full matrices call unpack_matrix ( fock_a_ao , fock_a ) call unpack_matrix ( fock_b_ao , fock_b ) ! Construct ROHF Fock matrix in MO basis using Guest-Saunders method associate ( na => nocca & , nb => noccb & ) fock ( 1 : nb , 1 : nb ) = acc * fock_a ( 1 : nb , 1 : nb ) & + bcc * fock_b ( 1 : nb , 1 : nb ) fock ( nb + 1 : na , nb + 1 : na ) = aoo * fock_a ( nb + 1 : na , nb + 1 : na ) & + boo * fock_b ( nb + 1 : na , nb + 1 : na ) fock ( na + 1 : nbf , na + 1 : nbf ) = avv * fock_a ( na + 1 : nbf , na + 1 : nbf ) & + bvv * fock_b ( na + 1 : nbf , na + 1 : nbf ) fock ( 1 : nb , nb + 1 : na ) = fock_b ( 1 : nb , nb + 1 : na ) fock ( nb + 1 : na , 1 : nb ) = fock_b ( nb + 1 : na , 1 : nb ) fock ( 1 : nb , na + 1 : nbf ) = 0.5_dp * ( fock_a ( 1 : nb , na + 1 : nbf ) & + fock_b ( 1 : nb , na + 1 : nbf )) fock ( na + 1 : nbf , 1 : nb ) = 0.5_dp * ( fock_a ( na + 1 : nbf , 1 : nb ) & + fock_b ( na + 1 : nbf , 1 : nb )) fock ( nb + 1 : na , na + 1 : nbf ) = fock_a ( nb + 1 : na , na + 1 : nbf ) fock ( na + 1 : nbf , nb + 1 : na ) = fock_a ( na + 1 : nbf , nb + 1 : na ) ! Apply Vshift to the diagonal do i = nb + 1 , na fock ( i , i ) = fock ( i , i ) + vshift * 0.5_dp end do do i = na + 1 , nbf fock ( i , i ) = fock ( i , i ) + vshift end do end associate ! Back-transform ROHF Fock matrix to AO basis call dsymm ( 'l' , 'u' , nbf , nbf , & 1.0_dp , smat_full , nbf , & mo_a , nbf , & 0.0_dp , work1 , nbf ) call orthogonal_transform2 ( 't' , nbf , nbf , work1 , nbf , fock , nbf , & work_matrix , nbf , work2 ) call pack_matrix ( work_matrix , fock_a_ao ) deallocate ( work_matrix , fock , fock_mo , fock_a , fock_b ) end subroutine form_rohf_fock !> @brief Back-transforms a symmetric operator from the MO basis to the AO basis. !> @detail Computes the transformation Fao = S * V * Fmo * (S * V)&#94;T, !>         where V are the MO coefficients and S is the overlap matrix, !>         typically used for converting the Fock matrix or similar !>         operators from MO to AO representation. !> @param[out] Fao Operator in AO basis (triangular format). !> @param[in] Fmo Operator in MO basis (triangular format). !> @param[in] smat_full Full overlap matrix in AO basis. !> @param[in] v MO coefficients. !> @param[in] nmo Number of molecular orbitals. !> @param[in] nbf Number of basis functions. !> @param[inout] sv Work array for S * V. !> @param[inout] work Work array for intermediate calculations. subroutine mo_to_ao ( fao , fmo , smat_full , v , nmo , nbf , sv , work ) use precision , only : dp use mathlib , only : pack_matrix , unpack_matrix use oqp_linalg implicit none real ( kind = dp ), intent ( out ) :: fao (:) real ( kind = dp ), intent ( in ) :: fmo (:) real ( kind = dp ), intent ( in ) :: smat_full (:,:) real ( kind = dp ), intent ( in ) :: v ( * ) real ( kind = dp ), intent ( in ) :: sv ( * ), work ( * ) integer , intent ( in ) :: nmo , nbf integer :: nbf2 real ( kind = dp ), allocatable :: ftmp (:,:) allocate ( ftmp ( nbf , nbf )) call unpack_matrix ( fmo , ftmp ) ! compute S*V call dsymm ( 'l' , 'u' , nbf , nmo , & 1.0_dp , smat_full , nbf , & v , nbf , & 0.0_dp , sv , nbf ) ! compute (S * V) * Fmo call dsymm ( 'r' , 'u' , nbf , nmo , & 1.0d0 , ftmp , nbf , & sv , nbf , & 0.0d0 , work , nbf ) ! compute ((S * V) * Fmo) * (S * V)&#94;T call dgemm ( 'n' , 't' , nbf , nbf , nmo , & 1.0d0 , work , nbf , & sv , nbf , & 0.0d0 , ftmp , nbf ) nbf2 = nbf * ( nbf + 1 ) / 2 call pack_matrix ( ftmp , fao (: nbf2 )) deallocate ( ftmp ) end subroutine mo_to_ao subroutine rohf_fix ( Mo , E , D , S , na , l0 , nbf ) !, num_swaps) !! In/Out: !!   Mo(nbf,nbf) : MO coefficients (columns are MOs) — columns swapped in place !!   E(nbf)      : orbital energies — elements swapped in place (1..l0 used) !! !! In: !!   D(nbf,nbf)  : AO density (symmetric) !!   S(nbf,nbf)  : AO overlap (symmetric) !!   na          : number of occupied orbitals expected first !!   l0          : number of orbitals in this ROHF block to check (<= nbf) !! !! Out: !!   num_swaps   : total column swaps performed use mathlib , only : unpack_matrix implicit none real ( dp ), intent ( inout ) :: Mo (:,:) real ( dp ), intent ( inout ) :: E (:) real ( dp ), intent ( in ) :: D (:) real ( dp ), intent ( in ) :: S (:,:) integer , intent ( in ) :: na , l0 , nbf integer :: num_swaps integer :: i , j , itiny , ibig real ( dp ), allocatable :: WS (:,:), T (:,:), wrk (:), den (:,:) real ( dp ) :: tiny , big , tmp logical :: need_swap if ( na == 0 . or . na == l0 ) then num_swaps = 0 return end if allocate ( den ( nbf , nbf ), WS ( nbf , l0 ), T ( nbf , l0 ), wrk ( l0 )) call unpack_matrix ( D , den , nbf , 'U' ) call dgemm ( 'N' , 'N' , nbf , l0 , nbf , 1.0_dp , S , nbf , Mo , nbf , 0.0_dp , WS , nbf ) call dgemm ( 'N' , 'N' , nbf , l0 , nbf , 1.0_dp , den , nbf , WS , nbf , 0.0_dp , T , nbf ) do i = 1 , l0 wrk ( i ) = dot_product ( WS (:, i ), T (:, i )) end do num_swaps = 0 do itiny = minloc ( wrk ( 1 : na ), dim = 1 ) tiny = wrk ( itiny ) ibig = maxloc ( wrk ( na + 1 : l0 ), dim = 1 ) + na big = wrk ( ibig ) need_swap = ( itiny > 0 ) . and . ( ibig > 0 ) . and . ( tiny < big ) if ( need_swap ) then Mo (:, [ itiny , ibig ]) = Mo (:, [ ibig , itiny ]) E ([ itiny , ibig ]) = E ([ ibig , itiny ]) wrk ([ itiny , ibig ]) = wrk ([ ibig , itiny ]) num_swaps = num_swaps + 1 else exit endif end do deallocate ( WS , T , wrk ) end subroutine rohf_fix !> @brief Format an SCF energy/delta without fixed-width overflow. !> @detail Large-anion and early-iteration energies can exceed fixed-point !>         fields.  A wide scientific field keeps every finite value !>         printable and is stable for machine-readable logs. function fmt_real17 ( val ) result ( str ) real ( kind = dp ), intent ( in ) :: val character ( len = 23 ) :: str write ( str , '(es23.12)' ) val end function fmt_real17 !> @brief Scientific notation for the 14-char error/gradient columns. function fmt_real14 ( val ) result ( str ) real ( kind = dp ), intent ( in ) :: val character ( len = 14 ) :: str write ( str , '(es14.6)' ) val end function fmt_real14 end module scf","tags":"","url":"sourcefile/scf.f90.html"},{"title":"tdhf_gradient.F90 – OpenQP Fortran API","text":"Source Code module tdhf_gradient_mod use precision , only : dp use grd2 , only : grd2_driver , grd2_compute_data_t use basis_tools , only : basis_set , bas_norm_matrix , build_cart_density use constants , only : HARMONIC_ACTIVE , NUM_CART_BF use types , only : information use io_constants , only : iw !############################################################################### implicit none !############################################################################### character ( len =* ), parameter :: module_name = \"tdhf_gradient_mod\" !############################################################################### public tdhf_gradient !############################################################################### type , extends ( grd2_compute_data_t ) :: grd2_tdhf_compute_data_t real ( kind = dp ), pointer :: d2 (:,:,:) => null () real ( kind = dp ), pointer :: p2 (:,:,:) => null () real ( kind = dp ), pointer :: xpy2 (:,:,:) => null () real ( kind = dp ), pointer :: xmy2 (:,:,:) => null () ! Cartesian-effective (bfnrm-folded) copies + offsets for HARMONIC_ACTIVE. real ( kind = dp ), allocatable :: d_cart (:,:), p_cart (:,:), xpy_cart (:,:), xmy_cart (:,:) integer , allocatable :: cart_off (:) integer :: nbf = 0 contains procedure :: init => grd2_tdhf_compute_data_t_init procedure :: clean => grd2_tdhf_compute_data_t_clean procedure :: get_density => grd2_tdhf_compute_data_t_get_density procedure :: build_cart => grd2_tdhf_build_cart end type contains !############################################################################### subroutine tdhf_gradient_C ( c_handle ) bind ( C , name = \"tdhf_gradient\" ) use c_interop , only : oqp_handle_t , oqp_handle_get_info use strings , only : Cstring implicit none type ( oqp_handle_t ) :: c_handle type ( information ), pointer :: inf inf => oqp_handle_get_info ( c_handle ) call tdhf_gradient ( inf ) end subroutine tdhf_gradient_c !############################################################################### subroutine tdhf_gradient ( infos ) use io_constants , only : iw use oqp_tagarray_driver use types , only : information use strings , only : Cstring , fstring use basis_tools , only : basis_set use messages , only : show_message , with_abort use grd1 , only : eijden , print_gradient use util , only : measure_time use tdhf_lib , only : & iatogen , mntoia use dft , only : dft_initialize , dftclean use mathlib , only : symmetrize_matrix , orthogonal_transform use mod_dft_molgrid , only : dft_grid_t use mod_dft_gridint_tdxc_grad , only : tddft_xc_gradient use mathlib , only : unpack_matrix use printing , only : print_module_info implicit none character ( len =* ), parameter :: subroutine_name = \"tdhf_gradient\" type ( basis_set ), pointer :: basis type ( information ), target , intent ( inout ) :: infos integer :: nbf , nocc type ( dft_grid_t ) :: molGrid ! General data logical :: dft integer :: scf_type , mol_mult real ( kind = dp ), allocatable :: p (:,:,:), d (:,:,:), xpy2 (:,:,:), xmy2 (:,:,:), wrk1 (:,:), wrk2 (:,:) ! tagarray real ( kind = dp ), contiguous , pointer :: & dmat_a (:), mo_a (:,:), td_p (:,:), xpy (:,:), xmy (:,:) character ( len =* ), parameter :: tags_general ( * ) = [ character ( len = 80 ) :: & OQP_TD_XPY , OQP_TD_XMY , OQP_DM_A , OQP_VEC_MO_A , OQP_TD_P ] mol_mult = infos % mol_prop % mult if ( mol_mult /= 1 ) call show_message (& 'RPA-TDDFT are only available for RHF reference' , with_abort ) scf_type = infos % control % scftype if ( scf_type /= 1 ) error stop dft = infos % control % hamilton == 20 ! Files open open ( unit = IW , file = infos % log_filename , position = \"append\" ) ! call print_module_info ( 'TDHF_Grad' , 'Computing Grdient of TDDFT' ) ! write ( iw , '(/5X,\"Gradient options\"/& &5X,18(\"-\")/& &5X,\"Target State: \",I8/)' ) infos % tddft % target_state ! Load basis set basis => infos % basis basis % atoms => infos % atoms call data_has_tags ( infos % dat , tags_general , module_name , subroutine_name , WITH_ABORT ) call tagarray_get_data ( infos % dat , OQP_DM_A , dmat_a ) call tagarray_get_data ( infos % dat , OQP_VEC_MO_A , mo_a ) call tagarray_get_data ( infos % dat , OQP_td_p , td_p ) call tagarray_get_data ( infos % dat , OQP_td_xpy , xpy ) call tagarray_get_data ( infos % dat , OQP_td_xmy , xmy ) ! Allocate H, S ,T and D matrices nbf = basis % nbf nocc = infos % mol_prop % nocc !   Compute 1e gradient call flush ( iw ) call tdhf_1e_grad ( infos , basis ) !call print_gradient(infos) write ( iw , \"(' ..... End Of 1-Eelectron Gradient ......')\" ) call measure_time ( print_total = 1 , log_unit = iw ) call flush ( iw ) allocate ( d ( nbf , nbf , 2 ), & p ( nbf , nbf , 2 ), & xpy2 ( nbf , nbf , 2 ), & xmy2 ( nbf , nbf , 2 ), & wrk1 ( nbf , nbf ), & wrk2 ( nbf , nbf ), & source = 0.0d0 ) call iatogen ( xpy (:, infos % tddft % target_state ), wrk1 , nocc , nocc ) call symmetrize_matrix ( wrk1 , nbf ) wrk1 = wrk1 * 0.5 call orthogonal_transform ( 't' , nbf , mo_a , wrk1 , xpy2 (:,:, 1 ), wrk2 ) call iatogen ( xmy (:, infos % tddft % target_state ), wrk1 , nocc , nocc ) call orthogonal_transform ( 't' , nbf , mo_a , wrk1 , xmy2 (:,:, 1 ), wrk2 ) call unpack_matrix ( td_p (:, 1 ), p (:,:, 1 )) call unpack_matrix ( dmat_a , d (:,:, 1 )) !   Compute xc gradient if ( dft ) then call dft_initialize ( infos , basis , molGrid ) d (:,:, 2 ) = d (:,:, 1 ) p (:,:, 2 ) = p (:,:, 1 ) xpy2 (:,:, 2 ) = xpy2 (:,:, 1 ) call tddft_xc_gradient ( basis = basis , & molGrid = molGrid , & dedft = infos % atoms % grad , & da = d (:,:, 1 ), & pa = p (:,:, 1 : 1 ), & xa = xpy2 (:,:, 1 : 1 ), & nmtx = 1 , & threshold = 1.0d-14 , & infos = infos ) call dftclean ( infos ) call measure_time ( print_total = 1 , log_unit = iw ) call flush ( iw ) end if !   Compute 2e gradient call tdhf_2e_grad ( basis , infos , d (:,:, 1 : 1 ), p (:,:, 1 : 1 ), xpy2 (:,:, 1 : 1 ), xmy2 (:,:, 1 : 1 )) call print_gradient ( infos ) !   Print timings call measure_time ( print_total = 1 , log_unit = iw ) close ( iw ) end subroutine tdhf_gradient !############################################################################### subroutine tdhf_1e_grad ( infos , basis ) use oqp_tagarray_driver use types , only : information use basis_tools , only : basis_set use util , only : measure_time use messages , only : show_message , WITH_ABORT use precision , only : dp use constants , only : tol_int use grd1 , only : eijden , print_gradient , & grad_nn , grad_ee_overlap , & grad_ee_kinetic , grad_en_hellman_feynman , grad_en_pulay , grad_1e_ecp use mathlib , only : symmetrize_matrix implicit none character ( len =* ), parameter :: subroutine_name = \"tdhf_1e_grad\" type ( information ), intent ( inout ) :: infos type ( basis_set ), intent ( inout ) :: basis real ( kind = dp ), allocatable :: dens (:) real ( kind = dp ) :: tol integer :: nbf , nbf2 , ok ! tagarray real ( kind = dp ), pointer :: dmat_a (:), wao (:), td_p (:,:) character ( len =* ), parameter :: tags_general ( * ) = ( / character ( len = 80 ) :: & OQP_DM_A , OQP_WAO , OQP_TD_P / ) nbf = basis % nbf nbf2 = nbf * ( nbf + 1 ) / 2 tol = tol_int * log ( 1 0.0_dp ) !   initial memory allocation allocate ( dens ( nbf2 ), source = 0.0_dp , stat = ok ) if ( ok /= 0 ) call show_message ( 'Cannot allocate memory' , WITH_ABORT ) call data_has_tags ( infos % dat , tags_general , module_name , subroutine_name , WITH_ABORT ) call tagarray_get_data ( infos % dat , OQP_DM_A , dmat_a ) call tagarray_get_data ( infos % dat , OQP_WAO , wao ) call tagarray_get_data ( infos % dat , OQP_td_p , td_p ) associate ( grad => infos % atoms % grad & , xyz => infos % atoms % xyz & , zn => infos % atoms % zn - infos % basis % ecp_zn_num & , p => td_p & , w => wao & , urohf => infos % control % scftype >= 2 & ) !     Zero out gradient grad = 0.0d0 !     Nuclear repulsion force call grad_nn ( infos % atoms , infos % basis % ecp_zn_num ) !     Obtain Lagrangian matrix (`dens`) call eijden ( dens , nbf , infos ) !     Add W matrix: dens = dens - 2 * w !     Overlap gradient call grad_ee_overlap ( basis , dens , grad , logtol = tol ) !     Compute total density matrix, discard Lagrangian dens = dmat_a + 2 * p (:, 1 ) !     Hellmann-Feynman force call grad_en_hellman_feynman ( basis , xyz , zn , dens , grad , logtol = tol ) !     KE gradient call grad_ee_kinetic ( basis , dens , grad , logtol = tol ) !     Pulay force call grad_en_pulay ( basis , xyz , zn , dens , grad , logtol = tol ) !     Effective core potential gradient call grad_1e_ecp ( infos , basis , xyz , dens , grad , logtol = tol ) end associate end subroutine !############################################################################### !> @brief The driver for the two electron gradient subroutine tdhf_2e_grad ( basis , infos , d , p , xpy , xmy ) use basis_tools , only : basis_set use precision , only : dp use messages , only : show_message , WITH_ABORT use types , only : information implicit none type ( information ), target , intent ( inout ) :: infos type ( basis_set ) :: basis real ( kind = dp ), contiguous , target :: p (:,:,:), d (:,:,:), xpy (:,:,:), xmy (:,:,:) logical :: urohf real ( kind = dp ) :: hfscale integer :: ok real ( kind = dp ), allocatable :: de (:,:) class ( grd2_compute_data_t ), allocatable :: gcomp urohf = infos % control % scftype >= 2 hfscale = 1.0d0 if ( infos % control % hamilton . ge . 20 ) hfscale = infos % dft % hfscale allocate ( de ( 3 , ubound ( infos % atoms % zn , 1 )), & source = 0.0d0 , & stat = ok ) if ( ok /= 0 ) call show_message ( 'cannot allocate memory' , WITH_ABORT ) gcomp = grd2_tdhf_compute_data_t ( d2 = d & , p2 = p & , xpy2 = xpy & , xmy2 = xmy & , hfscale = hfscale & , nbf = basis % nbf & ) call gcomp % init () select type ( gcomp ) class is ( grd2_tdhf_compute_data_t ) call gcomp % build_cart ( basis ) end select call grd2_driver ( infos , basis , de , gcomp ) infos % atoms % grad = infos % atoms % grad + de call gcomp % clean () end subroutine !############################################################################### subroutine grd2_tdhf_compute_data_t_init ( this ) !use messages, only: show_message, WITH_ABORT implicit none class ( grd2_tdhf_compute_data_t ), target , intent ( inout ) :: this call this % clean () end subroutine !############################################################################### !> @brief Build Cartesian-effective (bfnrm-folded) copies of the four TDDFT !>   gradient densities (ground d, relaxed p, transition X+Y and X-Y) + !>   Cartesian offsets, for contraction with Cartesian derivative ERIs under !>   HARMONIC_ACTIVE. Transition densities may be non-symmetric; the per-block !>   expansion handles that. subroutine grd2_tdhf_build_cart ( this , basis ) class ( grd2_tdhf_compute_data_t ), intent ( inout ) :: this type ( basis_set ), intent ( in ) :: basis integer , allocatable :: od (:) integer :: nc if (. not . HARMONIC_ACTIVE ) return call tdhf_cart_one ( basis , this % d2 (:,:, 1 ), this % d_cart , this % cart_off , nc ) call tdhf_cart_one ( basis , this % p2 (:,:, 1 ), this % p_cart , od , nc ) call tdhf_cart_one ( basis , this % xpy2 (:,:, 1 ), this % xpy_cart , od , nc ) call tdhf_cart_one ( basis , this % xmy2 (:,:, 1 ), this % xmy_cart , od , nc ) end subroutine grd2_tdhf_build_cart subroutine tdhf_cart_one ( basis , m , m_cart , off , nc ) type ( basis_set ), intent ( in ) :: basis real ( kind = dp ), intent ( in ) :: m (:,:) real ( kind = dp ), allocatable , intent ( out ) :: m_cart (:,:) integer , allocatable , intent ( out ) :: off (:) integer , intent ( out ) :: nc real ( kind = dp ), allocatable :: tmp (:,:) tmp = m call bas_norm_matrix ( tmp , basis % bfnrm , basis % nbf ) call build_cart_density ( basis , tmp , m_cart , off , nc ) end subroutine tdhf_cart_one !############################################################################### subroutine grd2_tdhf_compute_data_t_clean ( this ) implicit none class ( grd2_tdhf_compute_data_t ), target , intent ( inout ) :: this end subroutine !############################################################################### !> @brief Compute density factors for \\Gamma term of 2-electron contribution !>        to TD-DFT gradients subroutine grd2_tdhf_compute_data_t_get_density ( this , basis , id , dab , dabmax ) implicit none class ( grd2_tdhf_compute_data_t ), target , intent ( inout ) :: this type ( basis_set ), intent ( in ) :: basis integer , intent ( in ) :: id ( 4 ) real ( kind = dp ), target , intent ( out ) :: dab ( * ) real ( kind = dp ), intent ( out ) :: dabmax real ( kind = dp ) :: coul , coul2 , coul3 , exch , exch2 , exch3 , exch4 real ( kind = dp ) :: df1 , bfn real ( kind = dp ) :: coulfact , xcfact integer :: i_ , j_ , k_ , l_ integer :: i , j , k , l integer :: loc ( 4 ) integer :: nbf ( 4 ) real ( kind = dp ), pointer :: ab (:,:,:,:) real ( kind = dp ), pointer :: p (:,:), d (:,:), xpy (:,:), xmy (:,:) logical :: usecart coulfact = 4 * this % coulscale xcfact = this % hfscale dabmax = 0 usecart = HARMONIC_ACTIVE if ( usecart ) then p => this % p_cart ; d => this % d_cart ; xpy => this % xpy_cart ; xmy => this % xmy_cart loc = this % cart_off ( id ) - 1 nbf = NUM_CART_BF ( basis % am ( id )) else p => this % p2 (:,:, 1 ); d => this % d2 (:,:, 1 ) xpy => this % xpy2 (:,:, 1 ); xmy => this % xmy2 (:,:, 1 ) loc = basis % ao_offset ( id ) - 1 nbf = basis % naos ( id ) end if ab ( 1 : nbf ( 4 ), 1 : nbf ( 3 ), 1 : nbf ( 2 ), 1 : nbf ( 1 )) => dab ( 1 : product ( nbf )) do i_ = 1 , nbf ( 1 ) i = loc ( 1 ) + i_ do j_ = 1 , nbf ( 2 ) j = loc ( 2 ) + j_ do k_ = 1 , nbf ( 3 ) k = loc ( 3 ) + k_ do l_ = 1 , nbf ( 4 ) l = loc ( 4 ) + l_ coul = & + p ( j , i ) * d ( l , k ) & + p ( l , k ) * d ( j , i ) coul2 = & + xpy ( i , j ) * xpy ( k , l ) coul3 = d ( i , j ) * d ( k , l ) coul = 2 * coul + 8 * coul2 + coul3 df1 = coulfact * coul if ( xcfact /= 0.0_dp ) then exch = & + p ( i , k ) * d ( l , j ) & + p ( j , k ) * d ( l , i ) & + p ( l , i ) * d ( k , j ) & + p ( l , j ) * d ( k , i ) exch2 = & + xpy ( k , i ) * xpy ( l , j ) & + xpy ( l , i ) * xpy ( k , j ) exch3 = & + ( xmy ( i , l ) - xmy ( l , i )) * ( xmy ( j , k ) - xmy ( k , j )) & + ( xmy ( j , l ) - xmy ( l , j )) * ( xmy ( i , k ) - xmy ( k , i )) exch4 = d ( i , k ) * d ( j , l ) & + d ( i , l ) * d ( j , k ) exch = 2 * exch + 8 * exch2 + 2 * exch3 + exch4 df1 = df1 - xcfact * exch end if dabmax = max ( dabmax , abs ( df1 )) bfn = 1.0_dp if (. not . usecart ) bfn = product ( basis % bfnrm ([ i , j , k , l ])) ab ( l_ , k_ , j_ , i_ ) = df1 * bfn end do end do end do end do end subroutine grd2_tdhf_compute_data_t_get_density !############################################################################### end module tdhf_gradient_mod","tags":"","url":"sourcefile/tdhf_gradient.f90.html"},{"title":"dft_gridint.F90 – OpenQP Fortran API","text":"Source Code module mod_dft_gridint use precision , only : fp , i8b !  use params, only: dft_wt_der use basis_tools , only : basis_set use io_constants , only : iw use mod_dft_xc_libxc , only : xc_libxc_t use mod_dft_molgrid , only : dft_grid_t use functionals , only : functional_t use oqp_linalg use blas_wrap , only : oqp_ddot => oqp_ddot_i64 use parallel , only : par_env_t use mod_dft_gridint_phi_cache , only : g_phi_cache , phi_cache_geom_hash implicit none !############################################################################### integer , parameter , public :: & OQP_FUNTYP_LDA = 0 , & OQP_FUNTYP_GGA = 1 , & OQP_FUNTYP_MGGA = 2 integer , parameter , public :: & X__ = 1 , Y__ = 2 , Z__ = 3 integer , parameter , public :: & XX_ = 1 , YY_ = 2 , ZZ_ = 3 , & XY_ = 4 , YZ_ = 5 , XZ_ = 6 integer , parameter , public :: & dXX = 1 , dXY = 2 , dXZ = 3 , & dYX = 4 , dYY = 5 , dYZ = 6 , & dZX = 7 , dZY = 8 , dZZ = 9 integer , parameter , public :: & XXX = 1 , YYY = 2 , ZZZ = 3 , & XXY = 4 , XXZ = 5 , YYX = 6 , YYZ = 7 , & ZZX = 8 , ZZY = 9 , XYZ = 10 ! Convert 'square' XYZ indices to triangular, ! needed in hessian code integer , parameter , public :: & SQ_TO_TR ( 3 , 3 ) = reshape ( [ & XX_ , XY_ , XZ_ & , XY_ , YY_ , YZ_ & , XZ_ , YZ_ , ZZ_ & ], shape ( SQ_TO_TR ) ) !############################################################################### !> @brief Basic type to consume XC values on a grid type , abstract :: xc_consumer_t real ( kind = fp ) :: E_xc real ( kind = fp ) :: E_exch real ( kind = fp ) :: E_corr real ( kind = fp ) :: N_elec real ( kind = fp ) :: E_kin real ( kind = fp ) :: G_total ( 3 ) type ( par_env_t ) :: pe contains procedure ( xc_consumer_parallel_start ), deferred , pass :: parallel_start procedure ( xc_consumer_parallel_stop ), deferred , pass :: parallel_stop procedure ( xc_consumer_update ), deferred , pass :: update procedure ( xc_consumer_postUpdate ), deferred , pass :: postUpdate procedure ( xc_consumer_clean ), deferred , pass :: clean end type !############################################################################### !> @brief Interface structure to set up XC engine options type :: xc_options_t logical :: isGGA = . false . logical :: needTau = . false . logical :: hasBeta = . false . !< .T./.F.  - wfA and wfB are MO vectors/densities logical :: isWFVecs = . true . integer :: numAOs = 0 integer :: maxPts = 0 integer :: limPts = 0 integer :: numAtoms = 0 integer :: maxAngMom = 0 integer :: nDer = 0 integer :: nXCDer = 0 integer :: numAOVecs = 0 integer :: numTmpVec = 0 integer :: numOccAlpha = 0 integer :: numOccBeta = 0 real ( kind = fp ) :: dft_threshold = 0.0d0 real ( kind = fp ) :: ao_threshold = 0.0d0 real ( kind = fp ) :: ao_sparsity_ratio = 0.0d0 !< Opt-in to the cross-iteration collocation-Phi cache (Opt 1). Only the !< repeated SCF energy/Fock build sets this; gated further by env at runtime. logical :: use_phi_cache = . false . !< alpha spin wavefunction real ( KIND = fp ), contiguous , pointer :: wfAlpha (:, :) => null () !< beta spin wavefunction real ( KIND = fp ), contiguous , pointer :: wfBeta (:, :) => null () !< Molecular grid data type ( dft_grid_t ), pointer :: molGrid => null () type ( functional_t ), pointer :: functional !< Per-atom symmetry-reduction weights (orbit size for unique atoms, !< zero for their images); null => no reduction. Set only by the SCF !< XC path; response/gradient consumers never set it. real ( KIND = fp ), contiguous , pointer :: symAtomWeight (:) => null () end type !############################################################################### !> @brief Main class which knows how to compute XC functional values, AO and MO !>   values and gradients on a grid !> @details It is complemented with xc_consumer_t class to use calculation results type :: xc_engine_t !    private real ( KIND = fp ), allocatable :: xyzw (:, :) real ( KIND = fp ), allocatable :: aoMem_ (:) !< AO memory real ( KIND = fp ), allocatable :: moMemA_ (:) !< MO memory (alpha) real ( KIND = fp ), allocatable :: moMemB_ (:) !< MO memory (beta) real ( KIND = fp ), allocatable :: tmpWfAlpha (:) !< tmp alpha spin wavefunction real ( KIND = fp ), allocatable :: tmpWfBeta (:) !< tmp beta spin wavefunction integer , allocatable :: indices_p (:) !< AO significant indices integer , allocatable :: shells_p (:) !< shells surviving the slice-level prescreen integer , allocatable :: deadAOs_ (:) !< AOs of prescreened-out shells integer , allocatable :: liveAOs_ (:) !< AOs of surviving shells logical , allocatable :: aoLive_ (:) !< .true. for AOs of surviving shells real ( KIND = fp ), contiguous , pointer :: & aoMem (:, :, :) => null () & !< AO memory , moMemA (:, :, :) => null () & !< MO memory (alpha) , moMemB (:, :, :) => null () & !< MO memory (beta) , aoV (:, :) => null () & !< AO values , moVA (:, :) => null () & !< MO values (alpha) , moVB (:, :) => null () & !< MO values (beta) , aoG1 (:, :, :) => null () & !< AO gradient , aoG2 (:, :, :) => null () & !< AO 2nd der. , moG1A (:, :, :) => null () & !< MO gradient (alpha) , moG2A (:, :, :) => null () & !< MO 2nd der. (alpha) , moG1B (:, :, :) => null () & !< MO gradient (beta) , moG2B (:, :, :) => null () & !< MO 2nd der. (beta) , wts (:) => null () & !< weights , wfAlpha (:, :) => null () & !< alpha spin wavefunction , wfBeta (:, :) => null () & !< beta spin wavefunction , wfAlpha_p (:, :) => null () & !< pruned alpha spin wavefunction , wfBeta_p (:, :) => null () !< pruned beta spin wavefunction logical :: isGGA = . false . logical :: needTau = . false . logical :: hasBeta = . false . logical :: isWFVecs = . true . !< .TRUE.  - wfA and wfB are MO vectors !< .FALSE. - wfA and wfB are densities integer :: numAOs = 0 !< number of AOs integer :: numAOs_p = 0 !< number of pruned AOs integer :: numShells_p = 0 !< number of shells in shells_p integer :: numDeadAOs = 0 !< number of AOs in deadAOs_ integer :: numLiveAOs = 0 !< number of AOs in liveAOs_ logical :: skip_p = . true . !< skip if no pruned numAOs integer :: numPts = 0 integer :: numAtoms = 0 !< Index of the atom whose atomic grid generated the current slice !< (molGrid%idOrigin(iSlice)); set by the slice driver before each !< consumer update so consumers can associate points with their owning !< atom (e.g. PCM per-atom multipole projection). 0 when not in a slice. integer :: currAtom = 0 integer :: maxPts = 0 integer :: maxAngMom = 0 integer :: nAODer = 0 integer :: nXCDer = 1 integer :: funTyp = 0 !< 0 - LDA, 1 - GGA, 2 - MGGA integer :: numAOVecs = 0 integer :: numTmpVec = 0 integer :: numOccAlpha = 0 integer :: numOccBeta = 0 real ( kind = fp ) :: threshold = 1.0d-15 real ( kind = fp ) :: ao_threshold = 1.0d-15 real ( kind = fp ) :: ao_sparsity_ratio = 0.90d+0 !< Cut off if more than 90% pruned AOs !< (skip_p becomes False). type ( xc_libxc_t ), allocatable :: XCLib integer :: dbgLevel = 0 real ( kind = fp ) :: N_elec = 0.0 real ( kind = fp ) :: E_kin = 0.0 real ( kind = fp ) :: G_total ( 3 ) = 0.0 procedure ( compute_density ), pointer , pass :: compRho => null () procedure ( compute_density_grad ), pointer , pass :: compDRho => null () procedure ( compute_density_tau ), pointer , pass :: compTau => null () contains procedure :: init procedure :: echo => echoVars procedure :: getStats procedure :: resetPointers procedure :: resetOrbPointers procedure :: resetXCPointers procedure :: compAOs procedure :: buildShellList procedure :: pruneAOs procedure :: resetPrunedPointers procedure :: compMOs procedure :: compRMOs procedure :: compRMOGs generic :: compRRho => compRRho_ab , compRRho_a generic :: compRDRho => compRDRho_ab , compRDRho_a generic :: compRTau => compRTau_ab , compRTau_a procedure :: compRhoAll procedure :: compXC procedure , private :: compRRho_ab procedure , private :: compRDRho_ab procedure , private :: compRTau_ab procedure , private :: compRRho_a procedure , private :: compRDRho_a procedure , private :: compRTau_a end type xc_engine_t !############################################################################### abstract interface !> @brief Initialization of the data for XC consumer !> @note This class should handle multithreaded runs by its own means !> @note This subroutine is executed inside the parallel region by master thread only subroutine xc_consumer_parallel_start ( self , xce , nthreads ) import :: xc_consumer_t , xc_engine_t implicit none class ( xc_consumer_t ), target , intent ( inout ) :: self class ( xc_engine_t ), intent ( in ) :: xce integer , intent ( in ) :: nthreads end subroutine !> @brief Finalization of data in parallel run !> @note This subroutine is executed outside of the parallel region subroutine xc_consumer_parallel_stop ( self ) import :: xc_consumer_t implicit none class ( xc_consumer_t ), intent ( inout ) :: self end subroutine !> @brief Release resources of xc_consumer_t !> @note This subroutine is executed outside of the parallel region subroutine xc_consumer_clean ( self ) import :: xc_consumer_t implicit none class ( xc_consumer_t ), intent ( inout ) :: self end subroutine !> @brief Main subroutine to consume XC functional values provided by xc_engine_t !> @note This subroutine is executed inside the parallel region by every thread subroutine xc_consumer_update ( self , xce , mythread ) import :: xc_consumer_t , xc_engine_t implicit none class ( xc_consumer_t ), intent ( inout ) :: self class ( xc_engine_t ), intent ( in ) :: xce integer :: mythread end subroutine !> @note This subroutine is executed inside the parallel region by every thread subroutine xc_consumer_postUpdate ( self , xce , mythread ) import :: xc_consumer_t , xc_engine_t implicit none class ( xc_consumer_t ), intent ( inout ) :: self class ( xc_engine_t ), intent ( in ) :: xce integer :: mythread end subroutine end interface !############################################################################### abstract interface subroutine compute_density ( self , rho ) import class ( xc_engine_t ) :: self real ( kind = fp ), intent ( out ) :: rho (:,:) end subroutine subroutine compute_density_grad ( self , drho , sigma ) import class ( xc_engine_t ) :: self real ( kind = fp ), intent ( out ) :: drho (:,:), sigma (:,:) end subroutine subroutine compute_density_tau ( self , tau ) import class ( xc_engine_t ) :: self real ( kind = fp ), intent ( out ) :: tau (:,:) end subroutine end interface !############################################################################### private public xc_engine_t public xc_consumer_t public xc_options_t public run_xc public run_grid_aos public mo_tran_symm_ public mo_tran_gemm_ public xc_der1 public xc_der2_contr public xc_der3_contr public compAtGradRho public compAtGradDRho public compAtGradTau contains !############################################################################### !############################################################################### subroutine mo_tran_symm_ ( numAOs , nVecs , nPts , A , B , C ) integer , intent ( in ) :: numAOs , nVecs , nPts real ( kind = fp ), intent ( in ) :: A ( * ), B ( * ) real ( kind = fp ), intent ( inout ) :: C ( * ) call dsymm ( 'L' , 'U' , & numAOs , nVecs * nPts , & 1.0_fp , A , numAOs , & B , numAOs , & 0.0_fp , C , numAOs ) end subroutine !############################################################################### subroutine mo_tran_gemm_ ( numMOs , numAOs , nVecs , nPts , numAOs_active , A , B , C ) integer , intent ( in ) :: numMOs , numAOs , nVecs , nPts , numAOs_active real ( kind = fp ), intent ( in ) :: A ( * ), B ( * ) real ( kind = fp ), intent ( inout ) :: C ( * ) call dgemm ( 'T' , 'N' , & numMOs , nVecs * nPts , numAOs , & 1.0_fp , a , numAOs , & b , numAOs , & 0.0_fp , c , numAOs_active ) end subroutine !############################################################################### !> @brief Scale 2d array along 1st dimension by a given !>  vector of weights subroutine scale_2d ( array , weights ) real ( kind = fp ), intent ( inout ) :: array (:,:) real ( kind = fp ), intent ( in ) :: weights (:) integer :: i do i = lbound ( array , 2 ), ubound ( array , 2 ) array (:, i ) = array (:, i ) * weights end do end subroutine !############################################################################### !> @brief Print parameters of the xc_engine_t instance !> @author Vladimir Mironov subroutine echoVars ( self ) class ( xc_engine_t ) :: self real ( kind = fp ) :: exc , ex , ec call self % XCLib % getEnergy ( exc , ex , ec ) write ( * , * ) 'isGGA=' , self % isGGA write ( * , * ) 'needTau =' , self % needTau write ( * , * ) 'hasBeta =' , self % hasBeta write ( * , * ) 'numAOs  =' , self % numAOs write ( * , * ) 'numPts  =' , self % numPts write ( * , * ) 'nAODer  =' , self % nAODer write ( * , * ) 'nXCDer  =' , self % nXCDer write ( * , * ) 'numOccA =' , self % numOccAlpha write ( * , * ) 'N_elec  =' , self % N_elec write ( * , * ) 'E_kin   =' , self % E_kin write ( * , * ) 'G_total =' , self % G_total write ( * , * ) 'E_xc    =' , exc end subroutine !############################################################################### !> @brief Get debug statistics !> @author Vladimir Mironov subroutine getStats ( self , E_xc , E_exch , E_corr , N_elec , E_kin , G_total ) class ( xc_engine_t ) :: self real ( kind = fp ), optional , intent ( out ) :: & E_xc , E_exch , E_corr , N_elec , E_kin , G_total ( 3 ) real ( kind = fp ) :: exc , ex , ec call self % XCLib % getEnergy ( exc , ex , ec ) if ( present ( E_xc )) E_xc = exc if ( present ( E_exch )) E_exch = ex if ( present ( E_corr )) E_corr = ec if ( present ( N_elec )) N_elec = self % N_elec if ( present ( E_kin )) E_kin = self % E_kin if ( present ( G_total )) G_total ( 3 ) = self % G_total ( 3 ) end subroutine !############################################################################### !> @brief Initialize xc_engine_t instance !> @param[in] numAOs    number of atomic orbitals in a basis !> @param[in] nAt       number of atoms in a system !> @param[in] maxAngMom maximum angular momentum of basis functions and their derivatives !> @param[in] maxPts    maximum known number of non-zero points in a slice !> @param[in] limPts    maximum possible number of points (i.e. max(nRad*nAng)) in a slice !> @param[in] nDer      degree of energy derivative needed !> @param[in] hasBeta   .TRUE. if open-shell calculation !> @param[in] isGGA     .TRUE. if GGA/metaGGA functional !> @param[in] needTau   .TRUE. if metaGGA functional !> @param[in] vec_or_dens .TRUE./.FALSE. - wavefunction is MO vectors/density !> @param[in] nOccAlpha number of occupied orbitals, alpha spin !> @param[in] nOccBeta  number of occupied orbitals, beta spin !> @param[in] wfAlpha   wavefunction, alpha spin !> @param[in] wfBeta    wavefunction, beta spin !> @author Vladimir Mironov subroutine init ( self , xco ) implicit none class ( xc_engine_t ), target , intent ( inout ) :: self type ( xc_options_t ), target , intent ( in ) :: xco !   Will be possibly needed to use LibXC: integer , parameter :: nAOVecs ( 0 : 3 ) = [ 1 , 4 , 10 , 20 ] logical :: reqSigma self % funTyp = OQP_FUNTYP_LDA if ( xco % isGGA ) self % funTyp = OQP_FUNTYP_GGA if ( xco % needTau ) self % funTyp = OQP_FUNTYP_MGGA self % nAODer = xco % nDer if ( self % funTyp /= OQP_FUNTYP_LDA ) self % nAODer = self % nAODer + 1 self % nXCDer = max ( 1 , xco % nXCDer ) ! at least 1st derivative !   Find out the amount of memory needed if ( self % nAODer < 0 . or . self % nAODer > 3 ) then write ( * , * ) 'Invalid grad level in xc_engine_t % INIT' stop end if self % numAOVecs = nAOVecs ( self % nAODer ) self % numTmpVec = 1 if ( xco % needTau ) self % numTmpVec = 4 !   Allocate memory for XC calculations allocate ( & self % aoMem_ ( xco % numAOs * self % numAOVecs * xco % maxPts ), & self % moMemA_ ( xco % numAOs * self % numAOVecs * xco % maxPts ), & self % tmpWfAlpha ( xco % numAOs * xco % numAOs ), & self % tmpWfBeta ( xco % numAOs * xco % numAOs ), & !     Allocate memory for grid points storage self % xyzw ( xco % limPts , 4 ) & ) if ( xco % hasBeta ) allocate ( self % moMemB_ ( xco % numAOs * self % numAOVecs * xco % maxPts )) !   Allocate memory for AO significant indicis allocate ( self % indices_p ( xco % numAOs )) !< AO significant indices self % maxAngMom = xco % maxAngMom + self % nAODer !   Set up other runtime options self % numAOs = xco % numAOs self % numAtoms = xco % numAtoms self % maxPts = xco % maxPts self % isGGA = xco % isGGA self % needTau = xco % needTau self % hasBeta = xco % hasBeta !   Manage density/MO vectors self % isWFVecs = xco % isWFVecs self % wfAlpha => xco % wfAlpha self % numOccAlpha = xco % numOccAlpha if ( self % isWFVecs ) then self % compRho => compRhoMO self % compDRho => compDRhoMO self % compTau => compTauMO else self % compRho => compRhoAO self % compDRho => compDRhoAO self % compTau => compTauAO end if if ( self % hasBeta ) then self % numOccBeta = xco % numOccBeta self % wfBeta => xco % wfBeta else self % numOccBeta = xco % numOccAlpha self % wfBeta => xco % wfAlpha end if self % threshold = xco % dft_threshold self % ao_threshold = xco % ao_threshold self % ao_sparsity_ratio = xco % ao_sparsity_ratio !   Initialize XC library allocate ( self % XCLib ) reqSigma = self % funTyp /= OQP_FUNTYP_LDA call self % XCLib % init ( reqSigma , self % needTau , . false ., self % hasBeta , self % maxPts , self % nXCDer ) end subroutine !> @brief Adjust internal memory storage for a given !>  number of grid points !> @param[in] numPts    number of grid points !> @author Vladimir Mironov subroutine resetPointers ( self , numPts ) class ( xc_engine_t ) :: self integer , intent ( in ) :: numPts self % numPts = numPts call self % resetOrbPointers call self % resetXCPointers call self % XCLib % setPts ( numPts ) end subroutine !############################################################################### !> @brief Adjust XC memory storage for a given !>  number of grid points !> @author Vladimir Mironov subroutine resetXCPointers ( self ) class ( xc_engine_t ), target :: self associate ( numPts => self % numPts & ) self % wts ( 1 : numPts ) => self % xyzw ( 1 : numPts , 4 ) end associate end subroutine !############################################################################### !> @brief Adjust internal AO/MO memory storage for a given !>  number of grid points !> @author Vladimir Mironov subroutine resetOrbPointers ( self ) class ( xc_engine_t ), target :: self associate ( numAOs => self % numAOs & , numPts => self % numPts & , numAOVecs => self % numAOVecs & ) self % aoMem ( 1 : numAOs , 1 : numPts , 1 : numAOVecs ) => self % aoMem_ ( 1 :) self % moMemA ( 1 : numAOs , 1 : numPts , 1 : numAOVecs ) => self % moMemA_ ( 1 :) if ( self % hasBeta ) then self % moMemB ( 1 : numAOs , 1 : numPts , 1 : numAOVecs ) => self % moMemB_ ( 1 :) end if end associate select case ( self % nAODer ) case ( 0 ) self % aoV => self % aoMem (:, :, 1 ) self % moVA => self % moMemA (:, :, 1 ) if ( self % hasBeta ) then self % moVB => self % moMemB (:, :, 1 ) end if case ( 1 ) self % aoV => self % aoMem (:, :, 1 ) self % aoG1 => self % aoMem (:, :, 2 : 4 ) self % moVA => self % moMemA (:, :, 1 ) self % moG1A => self % moMemA (:, :, 2 : 4 ) if ( self % hasBeta ) then self % moVB => self % moMemB (:, :, 1 ) self % moG1B => self % moMemB (:, :, 2 : 4 ) end if case ( 2 ) self % aoV => self % aoMem (:, :, 1 ) self % aoG1 => self % aoMem (:, :, 2 : 4 ) self % aoG2 => self % aoMem (:, :, 5 : 10 ) self % moVA => self % moMemA (:, :, 1 ) self % moG1A => self % moMemA (:, :, 2 : 4 ) self % moG2A => self % moMemA (:, :, 5 : 10 ) if ( self % hasBeta ) then self % moVB => self % moMemB (:, :, 1 ) self % moG1B => self % moMemB (:, :, 2 : 4 ) self % moG2B => self % moMemB (:, :, 5 : 10 ) end if end select end subroutine !############################################################################### !> @brief Build the list of shells that can be nonzero anywhere in the !>  current slice of grid points !> @details The slice is enclosed in a bounding sphere and a shell !>  survives if the closest approach of the sphere to the shell origin !>  is within the shell extent (shell_mx_dist2).  AO evaluation then !>  loops only over surviving shells, and the AOs of screened-out !>  shells are known-zero without being touched. !> @param[in] basis  atomic basis set !> @param[in] xyz    absolute coordinates of the slice points subroutine buildShellList ( self , basis , xyz ) class ( xc_engine_t ) :: self type ( basis_set ), intent ( in ) :: basis real ( kind = fp ), intent ( in ) :: xyz (:,:) real ( kind = fp ) :: cmin ( 3 ), cmax ( 3 ), c ( 3 ), rad , dmr integer :: i , ish , n , nd , nl , off , nao if (. not . allocated ( self % shells_p )) then allocate ( self % shells_p ( basis % nshell )) allocate ( self % deadAOs_ ( self % numAOs )) allocate ( self % liveAOs_ ( self % numAOs )) allocate ( self % aoLive_ ( self % numAOs )) end if ! Bounding sphere of the slice cmin = xyz ( 1 , 1 : 3 ) cmax = cmin do i = 2 , ubound ( xyz , 1 ) cmin = min ( cmin , xyz ( i , 1 : 3 )) cmax = max ( cmax , xyz ( i , 1 : 3 )) end do c = 0.5_fp * ( cmin + cmax ) rad = 0.5_fp * sqrt ( sum (( cmax - cmin ) ** 2 )) n = 0 nd = 0 nl = 0 do ish = 1 , basis % nshell off = basis % ao_offset ( ish ) nao = basis % naos ( ish ) dmr = max ( 0.0_fp , & sqrt ( sum (( basis % atoms % xyz (: 3 , basis % origin ( ish )) - c ) ** 2 )) - rad ) if ( dmr * dmr <= basis % shell_mx_dist2 ( ish )) then n = n + 1 self % shells_p ( n ) = ish do i = off , off + nao - 1 nl = nl + 1 self % liveAOs_ ( nl ) = i end do self % aoLive_ ( off : off + nao - 1 ) = . true . else do i = off , off + nao - 1 nd = nd + 1 self % deadAOs_ ( nd ) = i end do self % aoLive_ ( off : off + nao - 1 ) = . false . end if end do self % numShells_p = n self % numDeadAOs = nd self % numLiveAOs = nl end subroutine !> @brief Compute atomic orbital values/gradient/hessian in a grid point !> @param[in]  iPtIn      index of the point in self%xyzw array !> @param[in]  iPtOut     index of the point in AO/MO arrays !> @param[out] nnz        number of non-zero AOs in the point !> @author Vladimir Mironov subroutine compAOs ( self , basis , nDer , xyz ) class ( xc_engine_t ) :: self type ( basis_set ), intent ( in ) :: basis integer , intent ( in ) :: nDer real ( kind = fp ), intent ( in ) :: xyz (:,:) integer :: nnz , ipt real ( kind = fp ) :: ptxyz ( 3 ) ! Screen out shells which are out of range for the whole slice; ! their AO entries are left untouched (known zero), see pruneAOs call self % buildShellList ( basis , xyz ) associate ( shells => self % shells_p ( 1 : self % numShells_p )) select case ( nDer ) case ( 0 ) do iPt = 1 , ubound ( xyz , 1 ) ptxyz = xyz ( iPt , 1 : 3 ) call basis % aoval ( ptxyz , nnz , & self % aoV (:, iPt ), shells = shells ) end do case ( 1 ) do iPt = 1 , ubound ( xyz , 1 ) ptxyz = xyz ( iPt , 1 : 3 ) call basis % aoval ( ptxyz , nnz , & self % aoV (:, iPt ), & self % aoG1 (:, iPt , X__ ), & self % aoG1 (:, iPt , Y__ ), & self % aoG1 (:, iPt , Z__ ), shells = shells ) end do case ( 2 ) do iPt = 1 , ubound ( xyz , 1 ) ptxyz = xyz ( iPt , 1 : 3 ) call basis % aoval ( ptxyz , nnz , & self % aoV (:, iPt ), & self % aoG1 (:, iPt , X__ ), & self % aoG1 (:, iPt , Y__ ), & self % aoG1 (:, iPt , Z__ ), & self % aoG2 (:, iPt , XX_ ), & self % aoG2 (:, iPt , YY_ ), & self % aoG2 (:, iPt , ZZ_ ), & self % aoG2 (:, iPt , XY_ ), & self % aoG2 (:, iPt , YZ_ ), & self % aoG2 (:, iPt , XZ_ ), shells = shells ) end do case default write ( * , '(\"Invalid grad level=\",I2,\" in xc_engine_t % COMPAOS\")' ) nDer stop end select end associate end subroutine subroutine pruneAOs ( self , skip ) class ( xc_engine_t ), target :: self logical :: skip integer :: i , j , l , v , numAOs_p real ( kind = fp ) :: aoVMax ( self % numLiveAOs ) real ( kind = fp ) :: aoMaxAll , thr ! Per-AO maximum over all points, for the AOs of shells surviving ! the slice-level prescreen only (entries of screened-out shells ! were never evaluated and hold stale values), accumulated by ! column sweeps (aoV rows are strided by numAOs) aoVMax = 0.0_fp do j = 1 , self % numPts do l = 1 , self % numLiveAOs aoVMax ( l ) = max ( aoVMax ( l ), abs ( self % aoV ( self % liveAOs_ ( l ), j ))) end do end do ! All grid quantities are bilinear in the AOs, so an AO whose ! strongest possible pair product |ao_i|*max|ao| stays below the ! threshold cannot contribute above it: when the largest AO value ! in the slice is < 1 this sharpens the per-AO threshold. aoMaxAll = 0.0_fp do l = 1 , self % numLiveAOs aoMaxAll = max ( aoMaxAll , aoVMax ( l )) end do thr = self % ao_threshold if ( aoMaxAll > 0.0_fp . and . aoMaxAll < 1.0_fp ) thr = thr / aoMaxAll numAOs_p = 0 ! Save significant indices do l = 1 , self % numLiveAOs if ( aoVMax ( l ) > thr ) then numAOs_p = numAOs_p + 1 self % indices_p ( numAOs_p ) = self % liveAOs_ ( l ) end if end do ! Cycle if all AOs are pruned skip = numAOs_p == 0 if ( skip ) return ! Check if the number of runed AOs is less ! than the prune cutoff (approximately 90%); if so, then ! grid pruning should be skipped. self % skip_p = real ( numAOs_p ) / real ( self % numAOs ) > self % ao_sparsity_ratio if ( self % skip_p ) then ! Set the full number of AOs since we skip pruning AOs self % numAOs_p = self % numAOs ! The full (uncompressed) AO arrays are used downstream, so the ! never-evaluated entries of prescreened-out shells must be ! zeroed.  Few shells are dead here, since most AOs survived. if ( self % numDeadAOs > 0 ) then do v = 1 , ubound ( self % aoMem , 3 ) do j = 1 , self % numPts self % aoMem ( self % deadAOs_ ( 1 : self % numDeadAOs ), j , v ) = 0.0_fp end do end do end if self % wfAlpha_p => self % wfAlpha if ( self % hasbeta ) & self % wfBeta_p => self % wfBeta else ! Set the number of pruned AOs self % numAOs_p = numAOs_p call self % ResetPrunedPointers end if end subroutine !############################################################################### !> @brief Adjust XC memory storage for a given !>  number of pruned grid points !> @author Konstantin Komarov subroutine resetPrunedPointers ( self , gather ) class ( xc_engine_t ), target :: self !> When .false. (Phi-cache replay), skip the geometry-only AO gather/compaction !> -- the cached Phi block is already in pruned layout -- but still recompute !> the density-dependent wavefunction compression and (re)set all pointers. logical , intent ( in ), optional :: gather real ( kind = fp ), pointer , dimension (:,:,:) :: reorderable_data logical :: do_gather do_gather = . true . if ( present ( gather )) do_gather = gather associate ( numAOs => self % numAOs & , numAOs_p => self % numAOs_p & , numPts => self % numPts & , hasBeta => self % hasBeta & , isWFVecs => self % isWFVecs & , numAOVecs => self % numAOVecs & , numTmpVec => self % numTmpVec & , indices => self % indices_p & ) ! Setup the pointer for reorderable data (source of the AO gather) if ( do_gather ) reorderable_data => self % aoMem (:, :, :) ! Update pointers with pruned AOs self % aoMem ( 1 : numAOs_p , 1 : numPts , 1 : numAOVecs ) => self % aoMem_ ( 1 :) if ( isWFVecs ) then ! Only the occupied MO coefficient columns are referenced in ! compMOs, so compress just those instead of all numAOs columns associate ( nOccA => self % numOccAlpha , nOccB => self % numOccBeta ) ! Set pointer for pruned self % wfAlpha_p ( 1 : numAOs_p , 1 : nOccA ) => self % tmpWfAlpha ( 1 : numAOs_p * nOccA ) ! Compress array self % wfAlpha_p (: numAOs_p ,:) = self % wfAlpha ( indices (: numAOs_p ),: nOccA ) if ( hasBeta ) then ! Set pointer for pruned self % wfBeta_p ( 1 : numAOs_p , 1 : nOccB ) => self % tmpWfBeta ( 1 : numAOs_p * nOccB ) ! Compress array self % wfBeta_p (: numAOs_p , :) = self % wfBeta ( indices (: numAOs_p ),: nOccB ) end if end associate else ! Set pointer for pruned self % moMemA ( 1 : numAOs_p , 1 : numPts , 1 : numAOVecs ) => self % moMemA_ ( 1 :) self % wfAlpha_p ( 1 : numAOs_p , 1 : numAOs_p ) => self % tmpWfAlpha ( 1 : numAOs_p * numAOs_p ) ! Compress array self % wfAlpha_p (: numAOs_p , : numAOs_p ) = self % wfAlpha ( indices (: numAOs_p ), indices (: numAOs_p )) if ( hasBeta ) then ! Set pointer for pruned self % moMemB ( 1 : numAOs_p , 1 : numPts , 1 : numAOVecs ) => self % moMemB_ ( 1 :) self % wfBeta_p ( 1 : numAOs_p , 1 : numAOs_p ) => self % tmpWfBeta ( 1 : numAOs_p * numAOs_p ) ! Compress array self % wfBeta_p (: numAOs_p , : numAOs_p ) = self % wfBeta ( indices (: numAOs_p ), indices (: numAOs_p )) end if end if select case ( self % nAODer ) case ( 0 ) ! Compress array if ( do_gather ) & self % aoMem ( 1 : numAOs_p , :, 1 : 1 ) = reorderable_data ( indices ( 1 : numAOs_p ), :, 1 : 1 ) ! Update pointers for pruned self % aoV => self % aoMem (:, :, 1 ) self % moVA => self % moMemA (:, :, 1 ) if ( hasBeta ) & self % moVB => self % moMemB (:, :, 1 ) case ( 1 ) ! Compress array if ( do_gather ) & self % aoMem ( 1 : numAOs_p , :, 1 : 4 ) = reorderable_data ( indices ( 1 : numAOs_p ), :, 1 : 4 ) ! Update pointers for pruned self % aoV => self % aoMem (:, :, 1 ) self % aoG1 => self % aoMem (:, :, 2 : 4 ) self % moVA => self % moMemA (:, :, 1 ) self % moG1A => self % moMemA (:, :, 2 : 4 ) if ( hasBeta ) then self % moVB => self % moMemB (:, :, 1 ) self % moG1B => self % moMemB (:, :, 2 : 4 ) end if case ( 2 ) ! Compress array if ( do_gather ) & self % aoMem ( 1 : numAOs_p , :, 1 : 10 ) = reorderable_data ( indices ( 1 : numAOs_p ), :, 1 : 10 ) ! Update pointers for pruned self % aoV => self % aoMem (:, :, 1 ) self % aoG1 => self % aoMem (:, :, 2 : 4 ) self % aoG2 => self % aoMem (:, :, 5 : 10 ) self % moVA => self % moMemA (:, :, 1 ) self % moG1A => self % moMemA (:, :, 2 : 4 ) self % moG2A => self % moMemA (:, :, 5 : 10 ) if ( hasBeta ) then self % moVB => self % moMemB (:, :, 1 ) self % moG1B => self % moMemB (:, :, 2 : 4 ) self % moG2B => self % moMemB (:, :, 5 : 10 ) end if end select end associate end subroutine !############################################################################### !> @brief Transform AOs to \"MOs\" !> @details Multiply AO vector to the MO coefficient matrix or density matrix. !>  True MOs are only obtained in the former case. !> @author Vladimir Mironov subroutine compMOs ( self ) class ( xc_engine_t ) :: self integer :: nVecs , nPts nVecs = min ( self % numAOVecs , 4 ) ! Don't transform second derivatives nPts = ubound ( self % aoMem , 2 ) associate ( nAlpha => self % numOccAlpha & , nBeta => self % numOccBeta & , isWFVecs => self % isWFVecs & , numAOs => self % numAOs & , numAOs_p => self % numAOs_p & , hasBeta => self % hasBeta & ) if ( isWFVecs ) then call mo_tran_gemm_ ( nAlpha , numAOs_p , nVecs , nPts , numAOs , self % wfAlpha_p , self % aoMem , self % moMemA ) else call mo_tran_symm_ ( numAOs_p , nVecs , nPts , self % wfAlpha_p , self % aoMem , self % moMemA ) end if if (. not . hasBeta ) return if ( isWFVecs ) then call mo_tran_gemm_ ( nBeta , numAOs_p , nVecs , nPts , numAOs , self % wfBeta_p , self % aoMem , self % moMemB ) else call mo_tran_symm_ ( numAOs_p , nVecs , nPts , self % wfBeta_p , self % aoMem , self % moMemB ) end if end associate end subroutine !############################################################################### subroutine compRhoAll ( self , skip ) class ( xc_engine_t ) :: self logical , intent ( out ) :: skip real ( kind = fp ) :: rhoab skip = . false . ! electronic density call self % compRho ( self % XCLib % rho ) rhoab = dot_product ( self % wts , sum ( self % XCLib % rho , dim = 1 )) if ( rhoab < 1.0d-12 ) then skip = . true . return end if self % N_elec = self % N_elec + rhoab if ( self % funTyp /= OQP_FUNTYP_LDA ) then ! electronic density 1st derivative CALL self % compDRho ( self % XCLib % drho , self % XCLib % sig ) ! The total electron density gradient if ( self % dbgLevel > 1 ) then self % G_total ( 1 ) = self % G_total ( 1 ) & + dot_product ( self % wts , self % XCLib % sig ( 1 ,:)) self % G_total ( 2 ) = self % G_total ( 2 ) & + dot_product ( self % wts , self % XCLib % sig ( 2 ,:)) self % G_total ( 3 ) = self % G_total ( 3 ) & + dot_product ( self % wts , self % XCLib % sig ( 3 ,:)) end if end if if ( self % funTyp == OQP_FUNTYP_MGGA ) then ! electronic density 2nd derivative call self % compTau ( self % XCLib % tau ) if ( self % dbgLevel > 1 ) then self % E_kin = self % E_kin & + dot_product ( self % wts , sum ( self % XCLib % tau , dim = 1 )) end if end if end subroutine subroutine compRMOs ( xce , da , mo ) class ( xc_engine_t ) :: xce real ( kind = fp ) :: da (:,:,:) real ( kind = fp ) :: mo (:,:,:) integer :: nPts , nMtx , i nMtx = ubound ( da , 3 ) nPts = xce % numPts do i = 1 , nMtx call mo_tran_symm_ ( & xce % numAOs_p , 1 , nPts , da (:,:, i ), xce % aoV , mo (:,:, i )) end do end subroutine subroutine compRMOGs ( xce , da , moG1 ) class ( xc_engine_t ) :: xce real ( kind = fp ) :: da (:,:,:) real ( kind = fp ) :: moG1 (:,:,:,:) integer :: nPts , nMtx , i , j nMtx = ubound ( da , 3 ) nPts = xce % numPts do i = 1 , nMtx do j = 1 , 3 call mo_tran_symm_ (& xce % numAOs_p , 1 , nPts , da (:,:, i ), & xce % aoG1 (:,:, j ), moG1 (:,:, j , i )) end do end do end subroutine !> @brief Compute electronic density in a grid point, density-driven calculation !> @param[in]  xce      XC engine, parameters !> @param[in]  mo       \"Molecular orbitals\" !> @param[out] rho      electronic density !> @author Vladimir Mironov subroutine compRRho_ab ( xce , mo , rho ) class ( xc_engine_t ) :: xce real ( kind = fp ), contiguous , intent ( out ) :: rho (:,:,:) real ( kind = fp ), contiguous , intent ( in ) :: mo (:,:,:,:) integer :: i , j , k , m , nMtx , nSpin nMtx = ubound ( mo , 3 ) nSpin = ubound ( mo , 4 ) m = xce % numAOs_p do k = 1 , nSpin do j = 1 , nMtx do i = 1 , xce % numPts rho ( k , i , j ) = oqp_ddot ( m , xce % aoV (:, i ), 1 , mo (:, i , j , k ), 1 ) end do end do end do end subroutine !> @brief Compute electronic density gradient in a grid point, density-driven calculation !> @param[in]  xce      XC engine, parameters !> @param[in]  mo       \"Molecular orbitals\" !> @param[out] drho     density directional derivative (along X, Y, and Z axes) !> @param[out] drrho    dRho/d[x,y,z] vector and its dot product with `drho` !> @author Vladimir Mironov subroutine compRDRho_ab ( xce , mo , drrho ) class ( xc_engine_t ) :: xce real ( kind = fp ), contiguous , intent ( in ) :: mo (:,:,:,:) real ( kind = fp ), contiguous , intent ( out ) :: drrho (:,:,:,:) integer :: i , j , k , m , ldg , nMtx , nSpin real ( kind = fp ) :: d3 ( 3 ) nMtx = ubound ( mo , 3 ) nSpin = ubound ( mo , 4 ) m = xce % numAOs_p ! aoG1 X/Y/Z planes are equidistant in memory: treat them as the ! columns of an m x 3 matrix and get all three derivatives from ! a single dgemv ldg = size ( xce % aoG1 , 1 ) * size ( xce % aoG1 , 2 ) do k = 1 , nSpin do j = 1 , nMtx do i = 1 , xce % numPts call dgemv ( 'T' , m , 3 , 2.0_fp , xce % aoG1 (:, i , 1 ), ldg , & mo (:, i , j , k ), 1 , 0.0_fp , d3 , 1 ) drrho ( 1 : 3 , k , i , j ) = d3 end do end do end do end subroutine !> @brief Compute tau: (MO)' times (AO)' !> @param[in]  xce      XC engine, parameters !> @param[in]  mog1    MO directional derivatives !> @param[out] rtau     kinetic energy density !> @author Vladimir Mironov subroutine compRTau_ab ( xce , moG1 , rtau ) class ( xc_engine_t ) :: xce real ( kind = fp ), contiguous , intent ( out ) :: rtau (:,:,:) real ( kind = fp ), contiguous , intent ( in ) :: moG1 (:,:,:,:,:) integer :: i , j , k , d , m , nSpin , nMtx real ( kind = fp ) :: t nSpin = ubound ( moG1 , 5 ) nMtx = ubound ( moG1 , 4 ) m = xce % numAOs_p do k = 1 , nSpin do j = 1 , nMtx do i = 1 , xce % numPts t = 0 do d = 1 , 3 t = t + oqp_ddot ( m , xce % aoG1 (:, i , d ), 1 , moG1 (:, i , d , j , k ), 1 ) end do rtau ( k , i , j ) = 0.5 * t end do end do end do end subroutine !> @brief Compute electronic density in a grid point, density-driven calculation !> @param[in]  xce      XC engine, parameters !> @param[in]  mo       \"Molecular orbitals\" !> @param[out] rho      electronic density !> @author Vladimir Mironov subroutine compRRho_a ( xce , mo , rho ) class ( xc_engine_t ) :: xce real ( kind = fp ), contiguous , intent ( out ) :: rho (:,:) real ( kind = fp ), contiguous , intent ( in ) :: mo (:,:,:) integer :: j , i , m , nMtx nMtx = ubound ( mo , 3 ) m = xce % numAOs_p do j = 1 , nMtx do i = 1 , xce % numPts rho ( i , j ) = oqp_ddot ( m , xce % aoV (:, i ), 1 , mo (:, i , j ), 1 ) end do end do end subroutine !> @brief Compute electronic density gradient in a grid point, density-driven calculation !> @param[in]  xce      XC engine, parameters !> @param[in]  mo       \"Molecular orbitals\" !> @param[out] drho     density directional derivative (along X, Y, and Z axes) !> @param[out] drrho    dRho/d[x,y,z] vector and its dot product with `drho` !> @author Vladimir Mironov subroutine compRDRho_a ( xce , mo , drrho ) class ( xc_engine_t ) :: xce real ( kind = fp ), contiguous , intent ( in ) :: mo (:,:,:) real ( kind = fp ), contiguous , intent ( out ) :: drrho (:,:,:) integer :: i , j , m , ldg , nMtx real ( kind = fp ) :: d3 ( 3 ) nMtx = ubound ( mo , 3 ) m = xce % numAOs_p ! aoG1 X/Y/Z planes as columns of an m x 3 matrix, see compRDRho_ab ldg = size ( xce % aoG1 , 1 ) * size ( xce % aoG1 , 2 ) do j = 1 , nMtx do i = 1 , xce % numPts call dgemv ( 'T' , m , 3 , 2.0_fp , xce % aoG1 (:, i , 1 ), ldg , & mo (:, i , j ), 1 , 0.0_fp , d3 , 1 ) drrho ( 1 : 3 , i , j ) = d3 end do end do end subroutine !> @brief Compute tau: (MO)' times (AO)' !> @param[in]  xce     XC engine, parameters !> @param[in]  mog1    MO directional derivatives !> @param[out] tau     kinetic energy density !> @author Vladimir Mironov subroutine compRTau_a ( xce , moG1 , tau ) class ( xc_engine_t ) :: xce real ( kind = fp ), contiguous , intent ( out ) :: tau (:,:) real ( kind = fp ), contiguous , intent ( in ) :: moG1 (:,:,:,:) integer :: i , j , d , m real ( kind = fp ) :: t m = xce % numAOs_p do j = 1 , ubound ( moG1 , 4 ) do i = 1 , xce % numPts t = 0 do d = 1 , 3 t = t + oqp_ddot ( m , xce % aoG1 (:, i , d ), 1 , moG1 (:, i , d , j ), 1 ) end do tau ( i , j ) = 0.5 * t end do end do end subroutine !############################################################################### !> @brief Compute XC contribution to the energy !> @param[inout]  bfGrad     array of gradient contributinos per basis function !> @param[inout]  exec       XC energy integral !> @param[inout]  ecorl      correlation energy integral !> @param[inout]  totele     density integral == number of electrons !> @param[inout]  totkin     kinetic energy integral !> @param[inout]  togradxyz  density gradient integral !> @author Vladimir Mironov subroutine compXC ( self , functional , skip ) class ( xc_engine_t ) :: self type ( functional_t ) :: functional logical :: skip !   Compute MOs call self % compMOs call self % compRhoAll ( skip ) if ( skip ) return call self % XCLib % compute ( functional , self % wts ) end subroutine !############################################################################### !> @brief Compute electronic density in a grid point, AO-driven calculation !> @param[out] rho     electronic density, alpha-spin !> @author Vladimir Mironov subroutine compRhoAO ( self , rho ) class ( xc_engine_t ) :: self real ( kind = fp ), intent ( out ) :: rho (:,:) integer :: i , m m = self % numAOs_p if ( self % hasBeta ) then do i = 1 , self % numPts rho ( 1 , i ) = oqp_ddot ( m , self % aoV (:, i ), 1 , self % moVA (:, i ), 1 ) rho ( 2 , i ) = oqp_ddot ( m , self % aoV (:, i ), 1 , self % moVB (:, i ), 1 ) end do else do i = 1 , self % numPts rho ( 1 , i ) = 0.5_fp * oqp_ddot ( m , self % aoV (:, i ), 1 , self % moVA (:, i ), 1 ) rho ( 2 , i ) = rho ( 1 , i ) end do end if end subroutine !############################################################################### !> @brief Compute electronic density in a grid point, MO-driven calculation !> @param[out] rho     electronic density, alpha-spin !> @author Vladimir Mironov subroutine compRhoMO ( self , rho ) class ( xc_engine_t ) :: self real ( kind = fp ), intent ( out ) :: rho (:,:) integer :: i , noa , nob noa = self % numOccAlpha nob = self % numOccBeta if ( self % hasBeta ) then do i = 1 , self % numPts rho ( 1 , i ) = oqp_ddot ( noa , self % moVA (:, i ), 1 , self % moVA (:, i ), 1 ) rho ( 2 , i ) = oqp_ddot ( nob , self % moVB (:, i ), 1 , self % moVB (:, i ), 1 ) end do else do i = 1 , self % numPts rho ( 1 , i ) = oqp_ddot ( noa , self % moVA (:, i ), 1 , self % moVA (:, i ), 1 ) rho ( 2 , i ) = rho ( 1 , i ) end do end if end subroutine !############################################################################### !> @brief Compute electronic density gradient in a grid point, AO-driven calculation !> @param[out] drhoa   dRho, alpha-spin !> @param[out] drhob   dRho, beta-spin !> @author Vladimir Mironov subroutine compDRhoAO ( self , drho , sigma ) class ( xc_engine_t ) :: self real ( kind = fp ), intent ( out ) :: drho (:,:), sigma (:,:) integer :: i , m , ldg real ( kind = fp ) :: drhoa ( 3 ), drhob ( 3 ) m = self % numAOs_p ! aoG1 X/Y/Z planes as columns of an m x 3 matrix, see compRDRho_ab ldg = size ( self % aoG1 , 1 ) * size ( self % aoG1 , 2 ) do i = 1 , self % numPts if ( self % hasBeta ) then call dgemv ( 'T' , m , 3 , 2.0_fp , self % aoG1 (:, i , 1 ), ldg , & self % moVA (:, i ), 1 , 0.0_fp , drhoa , 1 ) call dgemv ( 'T' , m , 3 , 2.0_fp , self % aoG1 (:, i , 1 ), ldg , & self % moVB (:, i ), 1 , 0.0_fp , drhob , 1 ) else call dgemv ( 'T' , m , 3 , 1.0_fp , self % aoG1 (:, i , 1 ), ldg , & self % moVA (:, i ), 1 , 0.0_fp , drhoa , 1 ) drhob = drhoa end if drho ( 1 : 3 , i ) = drhoa drho ( 4 : 6 , i ) = drhob sigma ( 1 , i ) = dot_product ( drhoa , drhoa ) sigma ( 2 , i ) = dot_product ( drhoa , drhob ) sigma ( 3 , i ) = dot_product ( drhob , drhob ) end do end subroutine !############################################################################### !> @brief Compute electronic density gradient in a grid point, MO-driven calculation !> @param[out] drhoa   dRho, alpha-spin !> @param[out] drhob   dRho, beta-spin !> @author Vladimir Mironov subroutine compDRhoMO ( self , drho , sigma ) class ( xc_engine_t ) :: self real ( kind = fp ), intent ( out ) :: drho (:,:), sigma (:,:) integer :: i , lda , ldb , noa , nob real ( kind = fp ) :: drhoa ( 3 ), drhob ( 3 ) noa = self % numOccAlpha nob = self % numOccBeta ! moG1 X/Y/Z planes as columns of an (nocc) x 3 matrix, see compRDRho_ab lda = size ( self % moG1A , 1 ) * size ( self % moG1A , 2 ) ldb = lda if ( self % hasBeta ) ldb = size ( self % moG1B , 1 ) * size ( self % moG1B , 2 ) ! dgemv quick-returns without touching y when m == 0 drhoa = 0 drhob = 0 do i = 1 , self % numPts call dgemv ( 'T' , noa , 3 , 2.0_fp , self % moG1A (:, i , 1 ), lda , & self % moVA (:, i ), 1 , 0.0_fp , drhoa , 1 ) if ( self % hasBeta ) then call dgemv ( 'T' , nob , 3 , 2.0_fp , self % moG1B (:, i , 1 ), ldb , & self % moVB (:, i ), 1 , 0.0_fp , drhob , 1 ) else drhob = drhoa end if drho ( 1 : 3 , i ) = drhoa drho ( 4 : 6 , i ) = drhob sigma ( 1 , i ) = dot_product ( drhoa , drhoa ) sigma ( 2 , i ) = dot_product ( drhoa , drhob ) sigma ( 3 , i ) = dot_product ( drhob , drhob ) end do end subroutine !############################################################################### !> @brief Compute electronic density 2nd derivatives in a grid point, AO-driven calculation !> @param[out] taua   d&#94;2(Rho) alpha-spin !> @param[out] taub   d&#94;2(Rho), beta-spin !> @author Vladimir Mironov subroutine compTauAO ( self , tau ) class ( xc_engine_t ) :: self real ( kind = fp ), intent ( out ) :: tau (:,:) real ( kind = fp ) :: taua ( 3 ), taub ( 3 ) integer :: i , j , m m = self % numAOs_p do i = 1 , self % numPts if ( self % hasBeta ) then do j = 1 , 3 taua ( j ) = oqp_ddot ( m , self % aoG1 (:, i , j ), 1 , self % moG1A (:, i , j ), 1 ) taub ( j ) = oqp_ddot ( m , self % aoG1 (:, i , j ), 1 , self % moG1B (:, i , j ), 1 ) end do else do j = 1 , 3 taua ( j ) = 0.5_fp * oqp_ddot ( m , self % aoG1 (:, i , j ), 1 , self % moG1A (:, i , j ), 1 ) end do taub = taua end if tau ( 1 , i ) = 0.5 * sum ( taua ) tau ( 2 , i ) = 0.5 * sum ( taub ) end do end subroutine !############################################################################### !> @brief Compute electronic density 2nd derivatives in a grid point, AO-driven calculation !> @param[out] taua   d&#94;2(Rho) alpha-spin !> @param[out] taub   d&#94;2(Rho), beta-spin !> @author Vladimir Mironov subroutine compTauMO ( self , tau ) class ( xc_engine_t ) :: self real ( kind = fp ), intent ( out ) :: tau (:,:) real ( kind = fp ) :: taua ( 3 ), taub ( 3 ) integer :: i , j , noa , nob noa = self % numOccAlpha nob = self % numOccBeta do i = 1 , self % numPts if ( self % hasBeta ) then do j = 1 , 3 taua ( j ) = oqp_ddot ( noa , self % moG1A (:, i , j ), 1 , self % moG1A (:, i , j ), 1 ) taub ( j ) = oqp_ddot ( nob , self % moG1B (:, i , j ), 1 , self % moG1B (:, i , j ), 1 ) end do else do j = 1 , 3 taua ( j ) = oqp_ddot ( noa , self % moG1A (:, i , j ), 1 , self % moG1A (:, i , j ), 1 ) end do taub = taua end if tau ( 1 , i ) = 0.5 * sum ( taua ) tau ( 2 , i ) = 0.5 * sum ( taub ) end do end subroutine !############################################################################### !> @brief Compute XC contributions to the gradient from a grid point, LDA part !> @param[in]    iPt      index of a grid point !> @param[inout] bfGrad   array of gradient contributions per basis function !> @param[in]    fgrad    XC gradient !> @param[in]    moV      MO-like orbital values !> @author Vladimir Mironov subroutine compAtGradRho ( bfGrad , fgrad , moV , aoG1 , nPts ) real ( kind = fp ), contiguous , intent ( in ) :: moV (:,:), aoG1 (:,:,:) real ( kind = fp ), intent ( inout ) :: bfGrad (:,:) real ( kind = fp ), intent ( in ) :: fGrad (:) integer , intent ( in ) :: nPts integer :: i , j real ( kind = fp ), allocatable :: w (:) allocate ( w ( size ( bfGrad , 1 ))) do i = 1 , nPts !       Scaled orbital values are shared by the three Cartesian directions w = moV (:, i ) * ( fGrad ( i ) * 2.0_fp ) do j = 1 , 3 bfGrad (:, j ) = bfGrad (:, j ) + aoG1 (:, i , j ) * w end do end do end subroutine !------------------------------------------------------------------------------- !> @brief Compute XC contributions to the gradient from a grid point, GGA part !> @param[inout] bfGrad   array of gradient contributions per basis function !> @param[in]    fgrad    XC gradient !> @param[in]    moV      MO-like orbital values !> @param[in]    moG1     MO-like orbital gradients !> @author Vladimir Mironov subroutine compAtGradDRho ( bfGrad , fGrad , moV , moG1 , aoG1 , aoG2 , nPts ) real ( kind = fp ), intent ( in ) :: fGrad (:,:) real ( kind = fp ), intent ( inout ) :: bfGrad (:,:) real ( kind = fp ), contiguous , intent ( in ) :: moV (:,:), moG1 (:,:,:) real ( kind = fp ), contiguous , intent ( in ) :: aoG1 (:,:,:), aoG2 (:,:,:) integer , intent ( in ) :: npts integer :: i , j1 real ( kind = fp ) :: f ( 3 ) real ( kind = fp ), allocatable :: s (:), t (:) allocate ( s ( size ( bfGrad , 1 )), t ( size ( bfGrad , 1 ))) do i = 1 , nPts f = fGrad ( i ,:) * 2.0_fp !     s = sum_j2 f(j2)*moG1(:,i,j2) is shared by the three output directions; !     contracting aoG2/moG1 with f first halves the number of full-vector !     passes compared to the straightforward 3x3 (j1,j2) loop. s = f ( 1 ) * moG1 (:, i , 1 ) + f ( 2 ) * moG1 (:, i , 2 ) + f ( 3 ) * moG1 (:, i , 3 ) do j1 = 1 , 3 ! X__ Y__ Z__ t = f ( 1 ) * aoG2 (:, i , SQ_TO_TR ( j1 , 1 )) & + f ( 2 ) * aoG2 (:, i , SQ_TO_TR ( j1 , 2 )) & + f ( 3 ) * aoG2 (:, i , SQ_TO_TR ( j1 , 3 )) bfGrad (:, j1 ) = bfGrad (:, j1 ) + t * moV (:, i ) + aoG1 (:, i , j1 ) * s end do end do end subroutine !> @brief Compute XC contributions to the gradient from a grid point, mGGA part !> @param[in]    iPt      index of a grid point !> @param[inout] bfGrad   array of gradient contributinos per basis function !> @param[in]    dedta    XC energy, mGGA contribution, alpha-spin !> @param[in]    dedtb    XC energy, mGGA contribution, beta-spin !> @author Vladimir Mironov subroutine compAtGradTau ( bfGrad , fgrad , moG1 , aoG2 , npts ) real ( kind = fp ), intent ( in ) :: fgrad (:) real ( kind = fp ), intent ( inout ) :: bfGrad (:,:) real ( kind = fp ), contiguous , intent ( in ) :: moG1 (:,:,:) real ( kind = fp ), contiguous , intent ( in ) :: aoG2 (:,:,:) integer , intent ( in ) :: npts integer :: i , j1 real ( kind = fp ), allocatable :: w (:,:) allocate ( w ( size ( bfGrad , 1 ), 3 )) do i = 1 , npts !       Pre-scale the orbital gradients once per point; the three scaled !       vectors are then reused by all three output directions. w = moG1 (:, i ,:) * fgrad ( i ) do j1 = 1 , 3 ! x__ y__ z__ bfgrad (:, j1 ) = bfgrad (:, j1 ) & + aoG2 (:, i , sq_to_tr ( j1 , 1 )) * w (:, 1 ) & + aoG2 (:, i , sq_to_tr ( j1 , 2 )) * w (:, 2 ) & + aoG2 (:, i , sq_to_tr ( j1 , 3 )) * w (:, 3 ) end do end do end subroutine !> @brief Get first derivative of the XC functional !> @param[in] xce    XC engine !> @param[in] beta   Whether to return spin-polarized quantities !> @param[out] d_r   dE_xc / d_rho (alpha, beta) !> @param[out] d_s   dE_xc / d_sigma (alpha-alpha, beta-beta, alpha-beta) !> @param[out] d_t   dE_xc / d_tau (alpha, beta) subroutine xc_der1 ( xce , beta , ipt , & d_r , d_s , d_t ) class ( xc_engine_t ) :: xce logical :: beta real ( kind = fp ), intent ( out ) :: d_r ( 2 ), d_s ( 3 ), d_t ( 2 ) integer , intent ( in ) :: ipt associate ( xc => xce % XCLib , ids => xce % XCLib % ids , i => ipt ) if ( beta ) then d_r ( 1 ) = xc % d1dr ( ids % ra , i ) d_r ( 2 ) = xc % d1dr ( ids % rb , i ) d_s ( 1 ) = xc % d1ds ( ids % ga , i ) d_s ( 2 ) = xc % d1ds ( ids % gb , i ) d_s ( 3 ) = xc % d1ds ( ids % gc , i ) d_t ( 1 ) = xc % d1dt ( ids % ta , i ) d_t ( 2 ) = xc % d1dt ( ids % tb , i ) else d_r = xc % d1dr ( ids % ra , i ) d_s ( 1 : 2 ) = xc % d1ds ( ids % ga , i ) d_s ( 3 ) = xc % d1ds ( ids % gc , i ) d_t = xc % d1dt ( ids % ta , i ) end if end associate end subroutine !############################################################################### !> @brief Get second derivative of the XC functional contracted with response densities !> @param[in] xce    XC engine !> @param[in] beta   Whether to return spin-polarized quantities !> @param[in] d_r    \\delta_rho (alpha, beta) !> @param[in] d_s    \\delta_sigma (alpha-alpha, beta-beta, alpha-beta) !> @param[in] d_t    \\delta_tau (alpha, beta) !> @param[out] f_r   \\sum_i d2E_xc / (d_rho   * d_zeta_i) (alpha, beta) !> @param[out] f_s   \\sum_i d2E_xc / (d_sigma * d_zeta_i) (alpha-alpha, beta-beta, alpha-beta) !> @param[out] f_t   \\sum_i d2E_xc / (d_tau   * d_zeta_i) (alpha, beta) subroutine xc_der2_contr ( xce , beta , ipt , & dr , ds , dt , & f_r , f_s , f_t ) class ( xc_engine_t ) :: xce real ( kind = fp ), intent ( in ) :: dr ( 2 ), ds ( 3 ), dt ( 2 ) real ( kind = fp ), intent ( out ) :: f_r ( 2 ), f_s ( 3 ), f_t ( 2 ) integer , intent ( in ) :: ipt logical , intent ( in ) :: beta if ( beta ) then call xc_ab_der2_contr ( xce , ipt , & dr , ds , dt , & f_r , f_s , f_t ) else call xc_a_der2_contr ( xce , ipt , & dr ( 1 ), ds ( 1 ), dt ( 1 ), & f_r , f_s , f_t ) end if end subroutine !############################################################################### !> @brief Get second derivative of the XC functional contracted with response densities, !>  spin-polarized version !> @param[in] xce    XC engine !> @param[in] d_r    \\delta_rho (alpha, beta) !> @param[in] d_s    \\delta_sigma (alpha-alpha, beta-beta, alpha-beta) !> @param[in] d_t    \\delta_tau (alpha, beta) !> @param[out] f_r   \\sum_i d2E_xc / (d_rho   * d_zeta_i) (alpha, beta) !> @param[out] f_s   \\sum_i d2E_xc / (d_sigma * d_zeta_i) (alpha-alpha, beta-beta, alpha-beta) !> @param[out] f_t   \\sum_i d2E_xc / (d_tau   * d_zeta_i) (alpha, beta) subroutine xc_ab_der2_contr ( xce , ipt , & dr , ds , dt , & f_r , f_s , f_t ) class ( xc_engine_t ) :: xce real ( kind = fp ), intent ( in ) :: dr ( 2 ), ds ( 3 ), dt ( 2 ) real ( kind = fp ), intent ( out ) :: f_r ( 2 ), f_s ( 3 ), f_t ( 2 ) integer , intent ( in ) :: ipt real ( kind = fp ) :: cr_r ( 2 ) real ( kind = fp ) :: cr_s ( 2 ), cs_r ( 3 ), cs_s ( 3 ) real ( kind = fp ) :: cr_t ( 2 ), cs_t ( 3 ), ct_r ( 2 ), ct_s ( 2 ), ct_t ( 2 ) associate ( xc => xce % XCLib , ids => xce % XCLib % ids , i => ipt ) f_r = 0 f_s = 0 f_t = 0 cr_r ( 1 ) = xc % d2r2 ( ids % rara , i ) * dr ( 1 ) & + xc % d2r2 ( ids % rarb , i ) * dr ( 2 ) cr_r ( 2 ) = xc % d2r2 ( ids % rarb , i ) * dr ( 1 ) & + xc % d2r2 ( ids % rbrb , i ) * dr ( 2 ) f_r = f_r + cr_r if ( xce % funTyp /= OQP_FUNTYP_LDA ) then cr_s ( 1 ) = xc % d2rs ( ids % raga , i ) * ds ( 1 ) & + xc % d2rs ( ids % ragb , i ) * ds ( 2 ) & + xc % d2rs ( ids % ragc , i ) * ds ( 3 ) cr_s ( 2 ) = xc % d2rs ( ids % rbga , i ) * ds ( 1 ) & + xc % d2rs ( ids % rbgb , i ) * ds ( 2 ) & + xc % d2rs ( ids % rbgc , i ) * ds ( 3 ) f_r = f_r + cr_s cs_r ( 1 ) = xc % d2rs ( ids % raga , i ) * dr ( 1 ) & + xc % d2rs ( ids % rbga , i ) * dr ( 2 ) cs_r ( 2 ) = xc % d2rs ( ids % ragb , i ) * dr ( 1 ) & + xc % d2rs ( ids % rbgb , i ) * dr ( 2 ) cs_r ( 3 ) = xc % d2rs ( ids % ragc , i ) * dr ( 1 ) & + xc % d2rs ( ids % rbgc , i ) * dr ( 2 ) f_s = f_s + cs_r cs_s ( 1 ) = xc % d2s2 ( ids % gaga , i ) * ds ( 1 ) & + xc % d2s2 ( ids % gagb , i ) * ds ( 2 ) & + xc % d2s2 ( ids % gagc , i ) * ds ( 3 ) cs_s ( 2 ) = xc % d2s2 ( ids % gagb , i ) * ds ( 1 ) & + xc % d2s2 ( ids % gbgb , i ) * ds ( 2 ) & + xc % d2s2 ( ids % gbgc , i ) * ds ( 3 ) cs_s ( 3 ) = xc % d2s2 ( ids % gagc , i ) * ds ( 1 ) & + xc % d2s2 ( ids % gbgc , i ) * ds ( 2 ) & + xc % d2s2 ( ids % gcgc , i ) * ds ( 3 ) f_s = f_s + cs_s if ( xce % funTyp == OQP_FUNTYP_MGGA ) then cr_t ( 1 ) = xc % d2rt ( ids % rata , i ) * dt ( 1 ) & + xc % d2rt ( ids % ratb , i ) * dt ( 2 ) cr_t ( 2 ) = xc % d2rt ( ids % rbta , i ) * dt ( 1 ) & + xc % d2rt ( ids % rbtb , i ) * dt ( 2 ) f_r = f_r + cr_t cs_t ( 1 ) = xc % d2st ( ids % gata , i ) * dt ( 1 ) & + xc % d2st ( ids % gatb , i ) * dt ( 2 ) cs_t ( 2 ) = xc % d2st ( ids % gbta , i ) * dt ( 1 ) & + xc % d2st ( ids % gbtb , i ) * dt ( 2 ) cs_t ( 3 ) = xc % d2st ( ids % gcta , i ) * dt ( 1 ) & + xc % d2st ( ids % gctb , i ) * dt ( 2 ) f_s = f_s + cs_t ct_r ( 1 ) = xc % d2rt ( ids % rata , i ) * dr ( 1 ) & + xc % d2rt ( ids % rbta , i ) * dr ( 2 ) ct_r ( 2 ) = xc % d2rt ( ids % ratb , i ) * dr ( 1 ) & + xc % d2rt ( ids % rbtb , i ) * dr ( 2 ) f_t = f_t + ct_r ct_s ( 1 ) = xc % d2st ( ids % gata , i ) * ds ( 1 ) & + xc % d2st ( ids % gbta , i ) * ds ( 2 ) & + xc % d2st ( ids % gcta , i ) * ds ( 3 ) ct_s ( 2 ) = xc % d2st ( ids % gatb , i ) * ds ( 1 ) & + xc % d2st ( ids % gbtb , i ) * ds ( 2 ) & + xc % d2st ( ids % gctb , i ) * ds ( 3 ) f_t = f_t + ct_s ct_t ( 1 ) = xc % d2t2 ( ids % tata , i ) * dt ( 1 ) & + xc % d2t2 ( ids % tatb , i ) * dt ( 2 ) ct_t ( 2 ) = xc % d2t2 ( ids % tatb , i ) * dt ( 1 ) & + xc % d2t2 ( ids % tbtb , i ) * dt ( 2 ) f_t = f_t + ct_t end if end if end associate end subroutine !############################################################################### !> @brief Get second derivative of the XC functional contracted with response densities, !>   not spin-polarized version !> @param[in] xce    XC engine !> @param[in] d_r    \\delta_rho (alpha, beta) !> @param[in] d_s    \\delta_sigma (alpha-alpha, beta-beta, alpha-beta) !> @param[in] d_t    \\delta_tau (alpha, beta) !> @param[out] f_r   \\sum_i d2E_xc / (d_rho   * d_zeta_i) (alpha, beta) !> @param[out] f_s   \\sum_i d2E_xc / (d_sigma * d_zeta_i) (alpha-alpha, beta-beta, alpha-beta) !> @param[out] f_t   \\sum_i d2E_xc / (d_tau   * d_zeta_i) (alpha, beta) subroutine xc_a_der2_contr ( xce , ipt , & dr , ds , dt , & f_r , f_s , f_t ) class ( xc_engine_t ) :: xce real ( kind = fp ), intent ( in ) :: dr , ds , dt real ( kind = fp ), intent ( out ) :: f_r ( 2 ), f_s ( 3 ), f_t ( 2 ) integer , intent ( in ) :: ipt real ( kind = fp ) :: cr_r ( 2 ) real ( kind = fp ) :: cr_s ( 2 ), cs_r ( 3 ), cs_s ( 3 ) real ( kind = fp ) :: cr_t ( 2 ), cs_t ( 3 ), ct_r ( 2 ), ct_s ( 2 ), ct_t ( 2 ) associate ( xc => xce % XCLib , ids => xce % XCLib % ids , i => ipt ) f_r = 0 f_s = 0 f_t = 0 cr_r ( 1 : 2 ) = xc % d2r2 ( ids % rara , i ) * dr & + xc % d2r2 ( ids % rarb , i ) * dr f_r = f_r + cr_r if ( xce % funTyp /= OQP_FUNTYP_LDA ) then cr_s = xc % d2rs ( ids % raga , i ) * ds & + xc % d2rs ( ids % ragb , i ) * ds & + xc % d2rs ( ids % ragc , i ) * ds f_r = f_r + cr_s cs_r ( 1 ) = xc % d2rs ( ids % raga , i ) * dr & + xc % d2rs ( ids % rbga , i ) * dr cs_r ( 2 ) = cs_r ( 1 ) cs_r ( 3 ) = xc % d2rs ( ids % ragc , i ) * dr & + xc % d2rs ( ids % rbgc , i ) * dr f_s = f_s + cs_r cs_s ( 1 ) = xc % d2s2 ( ids % gaga , i ) * ds & + xc % d2s2 ( ids % gagb , i ) * ds & + xc % d2s2 ( ids % gagc , i ) * ds cs_s ( 2 ) = cs_s ( 1 ) cs_s ( 3 ) = xc % d2s2 ( ids % gagc , i ) * ds & + xc % d2s2 ( ids % gbgc , i ) * ds & + xc % d2s2 ( ids % gcgc , i ) * ds f_s = f_s + cs_s if ( xce % funTyp == OQP_FUNTYP_MGGA ) then cr_t = xc % d2rt ( ids % rata , i ) * dt & + xc % d2rt ( ids % ratb , i ) * dt f_r = f_r + cr_t cs_t ( 1 ) = xc % d2st ( ids % gata , i ) * dt & + xc % d2st ( ids % gatb , i ) * dt cs_t ( 2 ) = cs_t ( 1 ) cs_t ( 3 ) = xc % d2st ( ids % gcta , i ) * dt & + xc % d2st ( ids % gctb , i ) * dt f_s = f_s + cs_t ct_r = xc % d2rt ( ids % rata , i ) * dr & + xc % d2rt ( ids % rbta , i ) * dr f_t = f_t + ct_r ct_s = xc % d2st ( ids % gata , i ) * ds & + xc % d2st ( ids % gbta , i ) * ds & + xc % d2st ( ids % gcta , i ) * ds f_t = f_t + ct_s ct_t = xc % d2t2 ( ids % tata , i ) * dt & + xc % d2t2 ( ids % tatb , i ) * dt f_t = f_t + ct_t end if end if end associate end subroutine !############################################################################### !> @brief Get third derivative of the XC functional contracted with response densities, !>  spin-polarized version !> @param[in] xce    XC engine !> @param[in] d_r    \\delta_rho (alpha, beta) !> @param[in] d_s    \\delta_sigma (alpha-alpha, beta-beta, alpha-beta) !> @param[in] d_t    \\delta_tau (alpha, beta) !> @param[in] ss     (\\nabla\\rho(T)*\\nabla\\rho(T)) (alpha-alpha, beta-beta, alpha-beta) !> @param[out] g_r   \\sum_i,j d2E_xc / (d_rho   * d_zeta_i*d_zeta_j) (alpha, beta) !> @param[out] g_s   \\sum_i,j d2E_xc / (d_sigma * d_zeta_i*d_zeta_j) (alpha-alpha, beta-beta, alpha-beta) !> @param[out] g_t   \\sum_i,j d2E_xc / (d_tau   * d_zeta_i*d_zeta_j) (alpha, beta) subroutine xc_der3_contr ( xce , ipt , & dr , ds , dt , & ss , & f_s , & g_r , g_s , g_t ) class ( xc_engine_t ) :: xce real ( kind = fp ), intent ( in ) :: dr ( 2 ), ds ( 3 ), dt ( 2 ) real ( kind = fp ), intent ( in ) :: ss ( 3 ) real ( kind = fp ), intent ( out ) :: f_s ( 3 ) real ( kind = fp ), intent ( out ) :: g_r ( 2 ), g_s ( 3 ), g_t ( 2 ) integer , intent ( in ) :: ipt real ( kind = fp ) :: cr ( 2 ), cs ( 3 ), ct ( 2 ) associate ( xc => xce % XCLib , ids => xce % XCLib % ids , i => ipt ) f_s = 0 g_r = 0 g_s = 0 g_t = 0 cr ( 1 ) = xc % d3r3 ( ids % rarara , i ) * dr ( 1 ) * dr ( 1 ) & + xc % d3r3 ( ids % rararb , i ) * dr ( 1 ) * dr ( 2 ) & + xc % d3r3 ( ids % rararb , i ) * dr ( 2 ) * dr ( 1 ) & + xc % d3r3 ( ids % rarbrb , i ) * dr ( 2 ) * dr ( 2 ) cr ( 2 ) = xc % d3r3 ( ids % rararb , i ) * dr ( 1 ) * dr ( 1 ) & + xc % d3r3 ( ids % rarbrb , i ) * dr ( 1 ) * dr ( 2 ) & + xc % d3r3 ( ids % rarbrb , i ) * dr ( 2 ) * dr ( 1 ) & + xc % d3r3 ( ids % rbrbrb , i ) * dr ( 2 ) * dr ( 2 ) g_r = g_r + cr if ( xce % funTyp /= OQP_FUNTYP_LDA ) then cs ( 1 ) = xc % d2rs ( ids % raga , i ) * dr ( 1 ) & + xc % d2rs ( ids % rbga , i ) * dr ( 2 ) cs ( 2 ) = xc % d2rs ( ids % ragb , i ) * dr ( 1 ) & + xc % d2rs ( ids % rbgb , i ) * dr ( 2 ) cs ( 3 ) = xc % d2rs ( ids % ragc , i ) * dr ( 1 ) & + xc % d2rs ( ids % rbgc , i ) * dr ( 2 ) f_s = f_s + cs cs ( 1 ) = xc % d2s2 ( ids % gaga , i ) * ds ( 1 ) & + xc % d2s2 ( ids % gagb , i ) * ds ( 2 ) & + xc % d2s2 ( ids % gagc , i ) * ds ( 3 ) cs ( 2 ) = xc % d2s2 ( ids % gagb , i ) * ds ( 1 ) & + xc % d2s2 ( ids % gbgb , i ) * ds ( 2 ) & + xc % d2s2 ( ids % gbgc , i ) * ds ( 3 ) cs ( 3 ) = xc % d2s2 ( ids % gagc , i ) * ds ( 1 ) & + xc % d2s2 ( ids % gbgc , i ) * ds ( 2 ) & + xc % d2s2 ( ids % gcgc , i ) * ds ( 3 ) f_s = f_s + cs cr ( 1 ) = xc % d2rs ( ids % raga , i ) * ss ( 1 ) & + xc % d2rs ( ids % ragb , i ) * ss ( 2 ) & + xc % d2rs ( ids % ragc , i ) * ss ( 3 ) cr ( 2 ) = xc % d2rs ( ids % rbga , i ) * ss ( 1 ) & + xc % d2rs ( ids % rbgb , i ) * ss ( 2 ) & + xc % d2rs ( ids % rbgc , i ) * ss ( 3 ) g_r = g_r + cr cs ( 1 ) = xc % d2s2 ( ids % gaga , i ) * ss ( 1 ) & + xc % d2s2 ( ids % gagb , i ) * ss ( 2 ) & + xc % d2s2 ( ids % gagc , i ) * ss ( 3 ) cs ( 2 ) = xc % d2s2 ( ids % gagb , i ) * ss ( 1 ) & + xc % d2s2 ( ids % gbgb , i ) * ss ( 2 ) & + xc % d2s2 ( ids % gbgc , i ) * ss ( 3 ) cs ( 3 ) = xc % d2s2 ( ids % gagc , i ) * ss ( 1 ) & + xc % d2s2 ( ids % gbgc , i ) * ss ( 2 ) & + xc % d2s2 ( ids % gcgc , i ) * ss ( 3 ) g_s = g_s + cs cr ( 1 ) = xc % d3r2s ( ids % raraga , i ) * dr ( 1 ) * ds ( 1 ) & + xc % d3r2s ( ids % rarbga , i ) * dr ( 2 ) * ds ( 1 ) & + xc % d3r2s ( ids % raragb , i ) * dr ( 1 ) * ds ( 2 ) & + xc % d3r2s ( ids % rarbgb , i ) * dr ( 2 ) * ds ( 2 ) & + xc % d3r2s ( ids % raragc , i ) * dr ( 1 ) * ds ( 3 ) & + xc % d3r2s ( ids % rarbgc , i ) * dr ( 2 ) * ds ( 3 ) cr ( 2 ) = xc % d3r2s ( ids % rarbga , i ) * dr ( 1 ) * ds ( 1 ) & + xc % d3r2s ( ids % rbrbga , i ) * dr ( 2 ) * ds ( 1 ) & + xc % d3r2s ( ids % rarbgb , i ) * dr ( 1 ) * ds ( 2 ) & + xc % d3r2s ( ids % rbrbgb , i ) * dr ( 2 ) * ds ( 2 ) & + xc % d3r2s ( ids % rarbgc , i ) * dr ( 1 ) * ds ( 3 ) & + xc % d3r2s ( ids % rbrbgc , i ) * dr ( 2 ) * ds ( 3 ) g_r = g_r + 2 * cr cr ( 1 ) = xc % d3rs2 ( ids % ragaga , i ) * ds ( 1 ) * ds ( 1 ) & + xc % d3rs2 ( ids % ragagb , i ) * ds ( 1 ) * ds ( 2 ) & + xc % d3rs2 ( ids % ragagc , i ) * ds ( 1 ) * ds ( 3 ) & + xc % d3rs2 ( ids % ragagb , i ) * ds ( 2 ) * ds ( 1 ) & + xc % d3rs2 ( ids % ragbgb , i ) * ds ( 2 ) * ds ( 2 ) & + xc % d3rs2 ( ids % ragbgc , i ) * ds ( 2 ) * ds ( 3 ) & + xc % d3rs2 ( ids % ragagc , i ) * ds ( 3 ) * ds ( 1 ) & + xc % d3rs2 ( ids % ragbgc , i ) * ds ( 3 ) * ds ( 2 ) & + xc % d3rs2 ( ids % ragcgc , i ) * ds ( 3 ) * ds ( 3 ) cr ( 2 ) = xc % d3rs2 ( ids % rbgaga , i ) * ds ( 1 ) * ds ( 1 ) & + xc % d3rs2 ( ids % rbgagb , i ) * ds ( 1 ) * ds ( 2 ) & + xc % d3rs2 ( ids % rbgagc , i ) * ds ( 1 ) * ds ( 3 ) & + xc % d3rs2 ( ids % rbgagb , i ) * ds ( 2 ) * ds ( 1 ) & + xc % d3rs2 ( ids % rbgbgb , i ) * ds ( 2 ) * ds ( 2 ) & + xc % d3rs2 ( ids % rbgbgc , i ) * ds ( 2 ) * ds ( 3 ) & + xc % d3rs2 ( ids % rbgagc , i ) * ds ( 3 ) * ds ( 1 ) & + xc % d3rs2 ( ids % rbgbgc , i ) * ds ( 3 ) * ds ( 2 ) & + xc % d3rs2 ( ids % rbgcgc , i ) * ds ( 3 ) * ds ( 3 ) g_r = g_r + cr cs ( 1 ) = xc % d3r2s ( ids % raraga , i ) * dr ( 1 ) * dr ( 1 ) & + xc % d3r2s ( ids % rarbga , i ) * dr ( 1 ) * dr ( 2 ) & + xc % d3r2s ( ids % rarbga , i ) * dr ( 2 ) * dr ( 1 ) & + xc % d3r2s ( ids % rbrbga , i ) * dr ( 2 ) * dr ( 2 ) cs ( 2 ) = xc % d3r2s ( ids % raragb , i ) * dr ( 1 ) * dr ( 1 ) & + xc % d3r2s ( ids % rarbgb , i ) * dr ( 1 ) * dr ( 2 ) & + xc % d3r2s ( ids % rarbgb , i ) * dr ( 2 ) * dr ( 1 ) & + xc % d3r2s ( ids % rbrbgb , i ) * dr ( 2 ) * dr ( 2 ) cs ( 3 ) = xc % d3r2s ( ids % raragc , i ) * dr ( 1 ) * dr ( 1 ) & + xc % d3r2s ( ids % rarbgc , i ) * dr ( 1 ) * dr ( 2 ) & + xc % d3r2s ( ids % rarbgc , i ) * dr ( 2 ) * dr ( 1 ) & + xc % d3r2s ( ids % rbrbgc , i ) * dr ( 2 ) * dr ( 2 ) g_s = g_s + cs cs ( 1 ) = xc % d3rs2 ( ids % ragaga , i ) * dr ( 1 ) * ds ( 1 ) & + xc % d3rs2 ( ids % ragagb , i ) * dr ( 1 ) * ds ( 2 ) & + xc % d3rs2 ( ids % ragagc , i ) * dr ( 1 ) * ds ( 3 ) & + xc % d3rs2 ( ids % rbgaga , i ) * dr ( 2 ) * ds ( 1 ) & + xc % d3rs2 ( ids % rbgagb , i ) * dr ( 2 ) * ds ( 2 ) & + xc % d3rs2 ( ids % rbgagc , i ) * dr ( 2 ) * ds ( 3 ) cs ( 2 ) = xc % d3rs2 ( ids % ragagb , i ) * dr ( 1 ) * ds ( 1 ) & + xc % d3rs2 ( ids % ragbgb , i ) * dr ( 1 ) * ds ( 2 ) & + xc % d3rs2 ( ids % ragbgc , i ) * dr ( 1 ) * ds ( 3 ) & + xc % d3rs2 ( ids % rbgagb , i ) * dr ( 2 ) * ds ( 1 ) & + xc % d3rs2 ( ids % rbgbgb , i ) * dr ( 2 ) * ds ( 2 ) & + xc % d3rs2 ( ids % rbgbgc , i ) * dr ( 2 ) * ds ( 3 ) cs ( 3 ) = xc % d3rs2 ( ids % ragagc , i ) * dr ( 1 ) * ds ( 1 ) & + xc % d3rs2 ( ids % ragbgc , i ) * dr ( 1 ) * ds ( 2 ) & + xc % d3rs2 ( ids % ragcgc , i ) * dr ( 1 ) * ds ( 3 ) & + xc % d3rs2 ( ids % rbgagc , i ) * dr ( 2 ) * ds ( 1 ) & + xc % d3rs2 ( ids % rbgbgc , i ) * dr ( 2 ) * ds ( 2 ) & + xc % d3rs2 ( ids % rbgcgc , i ) * dr ( 2 ) * ds ( 3 ) g_s = g_s + 2 * cs cs ( 1 ) = xc % d3s3 ( ids % gagaga , i ) * ds ( 1 ) * ds ( 1 ) & + xc % d3s3 ( ids % gagagb , i ) * ds ( 1 ) * ds ( 2 ) & + xc % d3s3 ( ids % gagagc , i ) * ds ( 1 ) * ds ( 3 ) & + xc % d3s3 ( ids % gagagb , i ) * ds ( 2 ) * ds ( 1 ) & + xc % d3s3 ( ids % gagbgb , i ) * ds ( 2 ) * ds ( 2 ) & + xc % d3s3 ( ids % gagbgc , i ) * ds ( 2 ) * ds ( 3 ) & + xc % d3s3 ( ids % gagagc , i ) * ds ( 3 ) * ds ( 1 ) & + xc % d3s3 ( ids % gagbgc , i ) * ds ( 3 ) * ds ( 2 ) & + xc % d3s3 ( ids % gagcgc , i ) * ds ( 3 ) * ds ( 3 ) cs ( 2 ) = xc % d3s3 ( ids % gagagb , i ) * ds ( 1 ) * ds ( 1 ) & + xc % d3s3 ( ids % gagbgb , i ) * ds ( 1 ) * ds ( 2 ) & + xc % d3s3 ( ids % gagbgc , i ) * ds ( 1 ) * ds ( 3 ) & + xc % d3s3 ( ids % gagbgb , i ) * ds ( 2 ) * ds ( 1 ) & + xc % d3s3 ( ids % gbgbgb , i ) * ds ( 2 ) * ds ( 2 ) & + xc % d3s3 ( ids % gbgbgc , i ) * ds ( 2 ) * ds ( 3 ) & + xc % d3s3 ( ids % gagbgc , i ) * ds ( 3 ) * ds ( 1 ) & + xc % d3s3 ( ids % gbgbgc , i ) * ds ( 3 ) * ds ( 2 ) & + xc % d3s3 ( ids % gbgcgc , i ) * ds ( 3 ) * ds ( 3 ) cs ( 3 ) = xc % d3s3 ( ids % gagagc , i ) * ds ( 1 ) * ds ( 1 ) & + xc % d3s3 ( ids % gagbgc , i ) * ds ( 1 ) * ds ( 2 ) & + xc % d3s3 ( ids % gagcgc , i ) * ds ( 1 ) * ds ( 3 ) & + xc % d3s3 ( ids % gagbgc , i ) * ds ( 2 ) * ds ( 1 ) & + xc % d3s3 ( ids % gbgbgc , i ) * ds ( 2 ) * ds ( 2 ) & + xc % d3s3 ( ids % gbgcgc , i ) * ds ( 2 ) * ds ( 3 ) & + xc % d3s3 ( ids % gagcgc , i ) * ds ( 3 ) * ds ( 1 ) & + xc % d3s3 ( ids % gbgcgc , i ) * ds ( 3 ) * ds ( 2 ) & + xc % d3s3 ( ids % gcgcgc , i ) * ds ( 3 ) * ds ( 3 ) g_s = g_s + cs if ( xce % funTyp == OQP_FUNTYP_MGGA ) then cs ( 1 ) = xc % d2st ( ids % gata , i ) * dt ( 1 ) & + xc % d2st ( ids % gatb , i ) * dt ( 2 ) cs ( 2 ) = xc % d2st ( ids % gbta , i ) * dt ( 1 ) & + xc % d2st ( ids % gbtb , i ) * dt ( 2 ) cs ( 3 ) = xc % d2st ( ids % gcta , i ) * dt ( 1 ) & + xc % d2st ( ids % gctb , i ) * dt ( 2 ) f_s = f_s + cs ct ( 1 ) = xc % d2st ( ids % gata , i ) * ss ( 1 ) & + xc % d2st ( ids % gbta , i ) * ss ( 2 ) & + xc % d2st ( ids % gcta , i ) * ss ( 3 ) ct ( 2 ) = xc % d2st ( ids % gatb , i ) * ss ( 1 ) & + xc % d2st ( ids % gbtb , i ) * ss ( 2 ) & + xc % d2st ( ids % gctb , i ) * ss ( 3 ) g_t = g_t + ct cr ( 1 ) = xc % d3r2t ( ids % rarata , i ) * dr ( 1 ) * dt ( 1 ) & + xc % d3r2t ( ids % rarbta , i ) * dr ( 2 ) * dt ( 1 ) & + xc % d3r2t ( ids % raratb , i ) * dr ( 1 ) * dt ( 2 ) & + xc % d3r2t ( ids % rarbtb , i ) * dr ( 2 ) * dt ( 2 ) cr ( 2 ) = xc % d3r2t ( ids % rarbta , i ) * dr ( 1 ) * dt ( 1 ) & + xc % d3r2t ( ids % rbrbta , i ) * dr ( 2 ) * dt ( 1 ) & + xc % d3r2t ( ids % rarbtb , i ) * dr ( 1 ) * dt ( 2 ) & + xc % d3r2t ( ids % rbrbtb , i ) * dr ( 2 ) * dt ( 2 ) g_r = g_r + 2 * cr cr ( 1 ) = xc % d3rst ( ids % ragata , i ) * ds ( 1 ) * dt ( 1 ) & + xc % d3rst ( ids % ragbta , i ) * ds ( 2 ) * dt ( 1 ) & + xc % d3rst ( ids % ragcta , i ) * ds ( 3 ) * dt ( 1 ) & + xc % d3rst ( ids % ragatb , i ) * ds ( 1 ) * dt ( 2 ) & + xc % d3rst ( ids % ragbtb , i ) * ds ( 2 ) * dt ( 2 ) & + xc % d3rst ( ids % ragctb , i ) * ds ( 3 ) * dt ( 2 ) cr ( 2 ) = xc % d3rst ( ids % rbgata , i ) * ds ( 1 ) * dt ( 1 ) & + xc % d3rst ( ids % rbgbta , i ) * ds ( 2 ) * dt ( 1 ) & + xc % d3rst ( ids % rbgcta , i ) * ds ( 3 ) * dt ( 1 ) & + xc % d3rst ( ids % rbgatb , i ) * ds ( 1 ) * dt ( 2 ) & + xc % d3rst ( ids % rbgbtb , i ) * ds ( 2 ) * dt ( 2 ) & + xc % d3rst ( ids % rbgctb , i ) * ds ( 3 ) * dt ( 2 ) g_r = g_r + 2 * cr cr ( 1 ) = xc % d3rt2 ( ids % ratata , i ) * dt ( 1 ) * dt ( 1 ) & + xc % d3rt2 ( ids % ratatb , i ) * dt ( 2 ) * dt ( 1 ) & + xc % d3rt2 ( ids % ratatb , i ) * dt ( 1 ) * dt ( 2 ) & + xc % d3rt2 ( ids % ratbtb , i ) * dt ( 2 ) * dt ( 2 ) cr ( 2 ) = xc % d3rt2 ( ids % ratatb , i ) * dt ( 1 ) * dt ( 1 ) & + xc % d3rt2 ( ids % rbtatb , i ) * dt ( 2 ) * dt ( 1 ) & + xc % d3rt2 ( ids % ratbtb , i ) * dt ( 1 ) * dt ( 2 ) & + xc % d3rt2 ( ids % rbtbtb , i ) * dt ( 2 ) * dt ( 2 ) g_r = g_r + cr cs ( 1 ) = xc % d3rst ( ids % ragata , i ) * dr ( 1 ) * dt ( 1 ) & + xc % d3rst ( ids % rbgata , i ) * dr ( 2 ) * dt ( 1 ) & + xc % d3rst ( ids % ragatb , i ) * dr ( 1 ) * dt ( 2 ) & + xc % d3rst ( ids % rbgatb , i ) * dr ( 2 ) * dt ( 2 ) cs ( 2 ) = xc % d3rst ( ids % ragbta , i ) * dr ( 1 ) * dt ( 1 ) & + xc % d3rst ( ids % rbgbta , i ) * dr ( 2 ) * dt ( 1 ) & + xc % d3rst ( ids % ragbtb , i ) * dr ( 1 ) * dt ( 2 ) & + xc % d3rst ( ids % rbgbtb , i ) * dr ( 2 ) * dt ( 2 ) cs ( 3 ) = xc % d3rst ( ids % ragcta , i ) * dr ( 1 ) * dt ( 1 ) & + xc % d3rst ( ids % rbgcta , i ) * dr ( 2 ) * dt ( 1 ) & + xc % d3rst ( ids % ragctb , i ) * dr ( 1 ) * dt ( 2 ) & + xc % d3rst ( ids % rbgctb , i ) * dr ( 2 ) * dt ( 2 ) g_s = g_s + 2 * cs cs ( 1 ) = xc % d3s2t ( ids % gagata , i ) * ds ( 1 ) * dt ( 1 ) & + xc % d3s2t ( ids % gagbta , i ) * ds ( 2 ) * dt ( 1 ) & + xc % d3s2t ( ids % gagcta , i ) * ds ( 3 ) * dt ( 1 ) & + xc % d3s2t ( ids % gagatb , i ) * ds ( 1 ) * dt ( 2 ) & + xc % d3s2t ( ids % gagbtb , i ) * ds ( 2 ) * dt ( 2 ) & + xc % d3s2t ( ids % gagctb , i ) * ds ( 3 ) * dt ( 2 ) cs ( 2 ) = xc % d3s2t ( ids % gagbta , i ) * ds ( 1 ) * dt ( 1 ) & + xc % d3s2t ( ids % gbgbta , i ) * ds ( 2 ) * dt ( 1 ) & + xc % d3s2t ( ids % gbgcta , i ) * ds ( 3 ) * dt ( 1 ) & + xc % d3s2t ( ids % gagbtb , i ) * ds ( 1 ) * dt ( 2 ) & + xc % d3s2t ( ids % gbgbtb , i ) * ds ( 2 ) * dt ( 2 ) & + xc % d3s2t ( ids % gbgctb , i ) * ds ( 3 ) * dt ( 2 ) cs ( 3 ) = xc % d3s2t ( ids % gagcta , i ) * ds ( 1 ) * dt ( 1 ) & + xc % d3s2t ( ids % gbgcta , i ) * ds ( 2 ) * dt ( 1 ) & + xc % d3s2t ( ids % gcgcta , i ) * ds ( 3 ) * dt ( 1 ) & + xc % d3s2t ( ids % gagctb , i ) * ds ( 1 ) * dt ( 2 ) & + xc % d3s2t ( ids % gbgctb , i ) * ds ( 2 ) * dt ( 2 ) & + xc % d3s2t ( ids % gcgctb , i ) * ds ( 3 ) * dt ( 2 ) g_s = g_s + 2 * cs cs ( 1 ) = xc % d3st2 ( ids % gatata , i ) * dt ( 1 ) * dt ( 1 ) & + xc % d3st2 ( ids % gatatb , i ) * dt ( 2 ) * dt ( 1 ) & + xc % d3st2 ( ids % gatatb , i ) * dt ( 1 ) * dt ( 2 ) & + xc % d3st2 ( ids % gatbtb , i ) * dt ( 2 ) * dt ( 2 ) cs ( 2 ) = xc % d3st2 ( ids % gbtata , i ) * dt ( 1 ) * dt ( 1 ) & + xc % d3st2 ( ids % gbtatb , i ) * dt ( 2 ) * dt ( 1 ) & + xc % d3st2 ( ids % gbtatb , i ) * dt ( 1 ) * dt ( 2 ) & + xc % d3st2 ( ids % gbtbtb , i ) * dt ( 2 ) * dt ( 2 ) cs ( 3 ) = xc % d3st2 ( ids % gctata , i ) * dt ( 1 ) * dt ( 1 ) & + xc % d3st2 ( ids % gctatb , i ) * dt ( 2 ) * dt ( 1 ) & + xc % d3st2 ( ids % gctatb , i ) * dt ( 1 ) * dt ( 2 ) & + xc % d3st2 ( ids % gctbtb , i ) * dt ( 2 ) * dt ( 2 ) g_s = g_s + cs ct ( 1 ) = xc % d3r2t ( ids % rarata , i ) * dr ( 1 ) * dr ( 1 ) & + xc % d3r2t ( ids % rarbta , i ) * dr ( 1 ) * dr ( 2 ) & + xc % d3r2t ( ids % rarbta , i ) * dr ( 2 ) * dr ( 1 ) & + xc % d3r2t ( ids % rbrbta , i ) * dr ( 2 ) * dr ( 2 ) ct ( 2 ) = xc % d3r2t ( ids % raratb , i ) * dr ( 1 ) * dr ( 1 ) & + xc % d3r2t ( ids % rarbtb , i ) * dr ( 1 ) * dr ( 2 ) & + xc % d3r2t ( ids % rarbtb , i ) * dr ( 2 ) * dr ( 1 ) & + xc % d3r2t ( ids % rbrbtb , i ) * dr ( 2 ) * dr ( 2 ) g_t = g_t + ct ct ( 1 ) = xc % d3rst ( ids % ragata , i ) * dr ( 1 ) * ds ( 1 ) & + xc % d3rst ( ids % rbgata , i ) * dr ( 2 ) * ds ( 1 ) & + xc % d3rst ( ids % ragbta , i ) * dr ( 1 ) * ds ( 2 ) & + xc % d3rst ( ids % rbgbta , i ) * dr ( 2 ) * ds ( 2 ) & + xc % d3rst ( ids % ragcta , i ) * dr ( 1 ) * ds ( 3 ) & + xc % d3rst ( ids % rbgcta , i ) * dr ( 2 ) * ds ( 3 ) ct ( 2 ) = xc % d3rst ( ids % ragatb , i ) * dr ( 1 ) * ds ( 1 ) & + xc % d3rst ( ids % rbgatb , i ) * dr ( 2 ) * ds ( 1 ) & + xc % d3rst ( ids % ragbtb , i ) * dr ( 1 ) * ds ( 2 ) & + xc % d3rst ( ids % rbgbtb , i ) * dr ( 2 ) * ds ( 2 ) & + xc % d3rst ( ids % ragctb , i ) * dr ( 1 ) * ds ( 3 ) & + xc % d3rst ( ids % rbgctb , i ) * dr ( 2 ) * ds ( 3 ) g_t = g_t + 2 * ct ct ( 1 ) = xc % d3s2t ( ids % gagata , i ) * ds ( 1 ) * ds ( 1 ) & + xc % d3s2t ( ids % gagbta , i ) * ds ( 1 ) * ds ( 2 ) & + xc % d3s2t ( ids % gagcta , i ) * ds ( 1 ) * ds ( 3 ) & + xc % d3s2t ( ids % gagbta , i ) * ds ( 2 ) * ds ( 1 ) & + xc % d3s2t ( ids % gbgbta , i ) * ds ( 2 ) * ds ( 2 ) & + xc % d3s2t ( ids % gbgcta , i ) * ds ( 2 ) * ds ( 3 ) & + xc % d3s2t ( ids % gagcta , i ) * ds ( 3 ) * ds ( 1 ) & + xc % d3s2t ( ids % gbgcta , i ) * ds ( 3 ) * ds ( 2 ) & + xc % d3s2t ( ids % gcgcta , i ) * ds ( 3 ) * ds ( 3 ) ct ( 2 ) = xc % d3s2t ( ids % gagatb , i ) * ds ( 1 ) * ds ( 1 ) & + xc % d3s2t ( ids % gagbtb , i ) * ds ( 1 ) * ds ( 2 ) & + xc % d3s2t ( ids % gagctb , i ) * ds ( 1 ) * ds ( 3 ) & + xc % d3s2t ( ids % gagbtb , i ) * ds ( 2 ) * ds ( 1 ) & + xc % d3s2t ( ids % gbgbtb , i ) * ds ( 2 ) * ds ( 2 ) & + xc % d3s2t ( ids % gbgctb , i ) * ds ( 2 ) * ds ( 3 ) & + xc % d3s2t ( ids % gagctb , i ) * ds ( 3 ) * ds ( 1 ) & + xc % d3s2t ( ids % gbgctb , i ) * ds ( 3 ) * ds ( 2 ) & + xc % d3s2t ( ids % gcgctb , i ) * ds ( 3 ) * ds ( 3 ) g_t = g_t + ct ct ( 1 ) = xc % d3rt2 ( ids % ratata , i ) * dr ( 1 ) * dt ( 1 ) & + xc % d3rt2 ( ids % ratatb , i ) * dr ( 1 ) * dt ( 2 ) & + xc % d3rt2 ( ids % rbtata , i ) * dr ( 2 ) * dt ( 1 ) & + xc % d3rt2 ( ids % rbtatb , i ) * dr ( 2 ) * dt ( 2 ) ct ( 2 ) = xc % d3rt2 ( ids % ratatb , i ) * dr ( 1 ) * dt ( 1 ) & + xc % d3rt2 ( ids % ratbtb , i ) * dr ( 1 ) * dt ( 2 ) & + xc % d3rt2 ( ids % rbtatb , i ) * dr ( 2 ) * dt ( 1 ) & + xc % d3rt2 ( ids % rbtbtb , i ) * dr ( 2 ) * dt ( 2 ) g_t = g_t + 2 * ct ct ( 1 ) = xc % d3st2 ( ids % gatata , i ) * ds ( 1 ) * dt ( 1 ) & + xc % d3st2 ( ids % gbtata , i ) * ds ( 2 ) * dt ( 1 ) & + xc % d3st2 ( ids % gctata , i ) * ds ( 3 ) * dt ( 1 ) & + xc % d3st2 ( ids % gatatb , i ) * ds ( 1 ) * dt ( 2 ) & + xc % d3st2 ( ids % gbtatb , i ) * ds ( 2 ) * dt ( 2 ) & + xc % d3st2 ( ids % gctatb , i ) * ds ( 3 ) * dt ( 2 ) ct ( 2 ) = xc % d3st2 ( ids % gatatb , i ) * ds ( 1 ) * dt ( 1 ) & + xc % d3st2 ( ids % gbtatb , i ) * ds ( 2 ) * dt ( 1 ) & + xc % d3st2 ( ids % gctatb , i ) * ds ( 3 ) * dt ( 1 ) & + xc % d3st2 ( ids % gatbtb , i ) * ds ( 1 ) * dt ( 2 ) & + xc % d3st2 ( ids % gbtbtb , i ) * ds ( 2 ) * dt ( 2 ) & + xc % d3st2 ( ids % gctbtb , i ) * ds ( 3 ) * dt ( 2 ) g_t = g_t + 2 * ct ct ( 1 ) = xc % d3t3 ( ids % tatata , i ) * dt ( 1 ) * dt ( 1 ) & + xc % d3t3 ( ids % tatatb , i ) * dt ( 1 ) * dt ( 2 ) & + xc % d3t3 ( ids % tatatb , i ) * dt ( 2 ) * dt ( 1 ) & + xc % d3t3 ( ids % tatbtb , i ) * dt ( 2 ) * dt ( 2 ) ct ( 2 ) = xc % d3t3 ( ids % tatatb , i ) * dt ( 1 ) * dt ( 1 ) & + xc % d3t3 ( ids % tatbtb , i ) * dt ( 1 ) * dt ( 2 ) & + xc % d3t3 ( ids % tatbtb , i ) * dt ( 2 ) * dt ( 1 ) & + xc % d3t3 ( ids % tbtbtb , i ) * dt ( 2 ) * dt ( 2 ) g_t = g_t + ct end if end if end associate end subroutine !############################################################################### subroutine run_xc ( xc_opts , xc_dat , basis ) use basis_tools , only : basis_set use blas_thread , only : blas_thread_count , blas_thread_set use , intrinsic :: iso_c_binding , only : c_int64_t !$  use omp_lib, only: omp_get_num_threads, omp_get_thread_num, & !$                     omp_get_max_threads, omp_get_num_procs, omp_get_wtime implicit none class ( xc_consumer_t ), intent ( inout ) :: xc_dat type ( xc_options_t ), intent ( in ) :: xc_opts type ( basis_set ), intent ( in ) :: basis type ( xc_engine_t ), allocatable :: xce logical :: skip real ( KIND = fp ) :: exc , totgradxyz ( 3 ), totele , totkin real ( KIND = fp ) :: dftthr , wcutoff integer :: next integer :: iSlice integer :: iAtom real ( KIND = fp ) :: symw integer :: npt integer :: i integer :: numNzPts logical :: done integer :: myjob integer :: iChunk , chunkSize integer :: myThread , numThreads integer ( c_int64_t ) :: nBlasThreads ! Opt 1: collocation-Phi cache (geometry-only reuse across SCF iterations) integer , parameter :: nAOVecs_tbl ( 0 : 3 ) = [ 1 , 4 , 10 , 20 ] logical :: cache_on , cache_replay integer :: nAODer_c , numAOVecs_c , naop_c logical :: skip_p_c integer ( i8b ) :: ghash ! Env-gated phase timing (OQP_XC_TIMING): geometry/Phi vs density-driven XC logical :: do_timing character ( len = 8 ) :: tenv integer :: tst , tln real ( KIND = fp ) :: t_geom , t_xc , tic t_geom = 0.0_fp t_xc = 0.0_fp tic = 0.0_fp !   The slice loop below issues many small BLAS calls from inside the !   OpenMP parallel region.  A BLAS-internal thread pool (e.g. pthread !   builds of OpenBLAS) is unaware of the surrounding parallelism, so !   when all cores are already busy with OpenMP threads it oversubscribes !   the machine and serializes on its pool lock.  Cap the BLAS threads !   such that OpenMP x BLAS does not exceed the core count. nBlasThreads = - 1 !$  if (omp_get_max_threads() > 1) then !$    nBlasThreads = blas_thread_count() !$    if (nBlasThreads > 0) then !$      call blas_thread_set(int(max(1, & !$               omp_get_num_procs()/omp_get_max_threads()), c_int64_t)) !$    end if !$  end if next = - 1 myjob = - 1 npt = xc_opts % molGrid % nMolPts !   Set cut-offs for the weight WCUTOFF !   WCUTOFF is a cell volume and we set it to a fixed value. !   Most cells have large volume (about 97% have volume >1e-14) dftthr = 1.0d-04 / npt if ( xc_opts % dft_threshold > 0.0d0 ) dftthr = xc_opts % dft_threshold wcutoff = 1.0d-15 if ( dftthr > 1.1d-15 ) wcutoff = 1.0d-08 / npt exc = 0 totele = 0 totgradxyz = 0 totkin = 0 ! --- Opt 1: configure the collocation-Phi cache for this build ------------ ! Only the repeated SCF energy/Fock build opts in (use_phi_cache); gated ! further by the env var. The same numAOVecs formula as xc_engine_t%init. nAODer_c = xc_opts % nDer if ( xc_opts % isGGA . or . xc_opts % needTau ) nAODer_c = nAODer_c + 1 numAOVecs_c = nAOVecs_tbl ( nAODer_c ) cache_on = xc_opts % use_phi_cache ghash = 0_i8b if ( cache_on ) ghash = phi_cache_geom_hash ( basis % atoms % xyz ) call g_phi_cache % begin_run ( cache_on , xc_opts % molGrid % nSlices , & xc_opts % molGrid % nMolPts , xc_opts % numAOs , & numAOVecs_c , xc_opts % numAtoms , ghash , dftthr ) cache_replay = g_phi_cache % active . and . g_phi_cache % replay ! --- Env-gated per-build phase timing ------------------------------------ call get_environment_variable ( 'OQP_XC_TIMING' , tenv , length = tln , status = tst ) do_timing = ( tst == 0 . and . tln > 0 . and . & ( tenv ( 1 : 1 ) == '1' . or . tenv ( 1 : 1 ) == 't' . or . tenv ( 1 : 1 ) == 'T' . or . & tenv ( 1 : 1 ) == 'y' . or . tenv ( 1 : 1 ) == 'Y' . or . & tenv ( 1 : 1 ) == 'o' . or . tenv ( 1 : 1 ) == 'O' )) !$omp parallel & !$omp   private(iChunk, chunkSize, numThreads, done) & !$omp   private(iSlice, numNzPts, xce) & !$omp   private(myThread), & !$omp   private(i), & !$omp   private(iAtom, symw), & !$omp   private(skip), & !$omp   private(naop_c, skip_p_c, tic) & !$omp   reduction(+:exc, totele, totgradxyz, totkin, t_geom, t_xc) numThreads = 1 myThread = 1 !$  numThreads = omp_get_num_threads() !$  myThread = omp_get_thread_num()+1 chunkSize = max ( 1 , xc_opts % molGrid % nSlices / ( xc_dat % pe % size * 4 )) if ( chunkSize / numThreads > 40 ) then chunkSize = 40 * numThreads end if allocate ( xce ) call xce % init ( xc_opts ) !$omp master call xc_dat % parallel_start ( xce , numThreads ) !$omp end master !$omp barrier done = . false . do iChunk = 1 , xc_opts % molGrid % nSlices , chunkSize if ( mod ( iChunk / chunkSize , xc_dat % pe % size ) /= xc_dat % pe % rank ) cycle !$omp do schedule(dynamic) slc : do iSlice = iChunk , min ( xc_opts % molGrid % nSlices , iChunk - 1 + chunkSize ) !$      if (do_timing) tic = omp_get_wtime() iAtom = xc_opts % molGrid % idOrigin ( iSlice ) ! Symmetry reduction: integrate only unique atoms' slices, with ! quadrature weights scaled by the atom-orbit size. Geometry-only, so ! it is recomputed identically on a cache replay (the cached weights ! already include the symw scaling baked in during the build pass). symw = 1.0_fp if ( associated ( xc_opts % symAtomWeight )) then symw = xc_opts % symAtomWeight ( iAtom ) if ( symw == 0.0_fp ) CYCLE end if if ( cache_replay ) then ! ---- Opt 1 REPLAY: restore the cached geometry-only Phi block ----- call g_phi_cache % get_meta ( iSlice , skip , numNzPts , naop_c , skip_p_c ) if ( skip ) CYCLE call xce % resetPointers ( numNzPts ) xce % numAOs_p = naop_c xce % skip_p = skip_p_c call g_phi_cache % get_bulk ( iSlice , xce % indices_p , xce % aoMem_ , xce % xyzw (:, 4 )) if ( skip_p_c ) then ! dense slice: full AO layout from resetPointers; wf is uncompressed xce % wfAlpha_p => xce % wfAlpha if ( xce % hasBeta ) xce % wfBeta_p => xce % wfBeta else ! sparse slice: cached Phi already pruned; recompute wf compression ! and (re)set pruned pointers, but skip the geometry-only AO gather call xce % resetPrunedPointers ( gather = . false .) end if else ! ---- BUILD: compute Phi as usual (and store it when caching) ------ call xc_opts % molgrid % getSliceNonZero ( wcutoff , iSlice , xce % xyzw , numNzPts ) if ( numNzPts == 0 ) then if ( cache_on ) call g_phi_cache % store ( iSlice , . true ., 0 , 0 , . true ., & xce % indices_p , xce % aoMem_ , xce % xyzw (:, 4 )) CYCLE end if if ( symw /= 1.0_fp ) xce % xyzw ( 1 : numNzPts , 4 ) = symw * xce % xyzw ( 1 : numNzPts , 4 ) call xce % resetPointers ( numNzPts ) do i = 1 , numNzPts xce % xyzw ( i ,: 3 ) = & xce % xyzw ( i ,: 3 ) + basis % atoms % xyz (: 3 , iAtom ) end do call xce % compAOs ( basis , xce % nAODer , xce % xyzw (: numNzPts ,: 3 )) call xce % pruneAOs ( skip ) IF ( skip ) then if ( cache_on ) call g_phi_cache % store ( iSlice , . true ., 0 , 0 , . true ., & xce % indices_p , xce % aoMem_ , xce % xyzw (:, 4 )) CYCLE end if if ( cache_on ) call g_phi_cache % store ( iSlice , . false ., xce % numPts , & xce % numAOs_p , xce % skip_p , xce % indices_p , & xce % aoMem_ , xce % xyzw (:, 4 )) end if !$      if (do_timing) then !$        t_geom = t_geom + omp_get_wtime() - tic !$        tic = omp_get_wtime() !$      end if xce % currAtom = iAtom call xce % compXC ( xc_opts % functional , skip ) IF ( skip ) CYCLE call xc_dat % update ( xce , myThread ) call xc_dat % postUpdate ( xce , myThread ) !$      if (do_timing) t_xc = t_xc + omp_get_wtime() - tic end do slc !$omp end do nowait end do call xce % getStats ( & E_xc = exc , & N_elec = totele , & E_kin = totkin , & G_total = totgradxyz ) deallocate ( xce ) !$omp end parallel ! Finalize the Phi cache build pass (mark ready, tally footprint). call g_phi_cache % finish_run () if ( do_timing ) then ! Phase times below are aggregate THREAD-seconds (summed over threads), ! used to show the geomPhi(build)->geomPhi(replay) drop and the ! geom-vs-density composition. The authoritative per-build WALL time is ! the serial [SCFTIME] wall_XCbuild printed by calc_jk_xc. write ( iw , '(1x,a,a8,a,i7,a,f9.4,a,f9.4,a,f9.4,a,f8.1,a)' ) & '[XCTIME] phi-cache=' , merge ( 'replay' , merge ( 'build ' , 'off   ' , cache_on ), cache_replay ), & ' nz_pts=' , npt , & '  thrS_geomPhi=' , t_geom , 's  thrS_xc=' , t_xc , & 's  thrS_xcbuild=' , t_geom + t_xc , 's  cacheMB=' , real ( g_phi_cache % nbytes , fp ) / 1.048576d6 , ' ' end if call blas_thread_set ( nBlasThreads ) ! no-op if nBlasThreads == -1 call xc_dat % parallel_stop () call xc_dat % pe % allreduce ( exc , 1 ) call xc_dat % pe % allreduce ( totele , 1 ) call xc_dat % pe % allreduce ( totkin , 1 ) call xc_dat % pe % allreduce ( totgradxyz , 1 ) xc_dat % E_xc = exc xc_dat % N_elec = totele xc_dat % E_kin = totkin xc_dat % G_total = totgradxyz end subroutine !> @brief Drive a grid loop that only evaluates AO values on the molecular grid. !> !> This is a stripped-down variant of run_xc used by guesses that need !> one-electron operators integrated numerically on the DFT grid (e.g. the !> superposition-of-atomic-potentials guess). It performs the same slice !> loop, coordinate shift, AO evaluation and AO pruning as run_xc, but skips !> the exchange-correlation evaluation (compXC) entirely, so no functional is !> required. The consumer's update/postUpdate hooks see xce%aoV, xce%wts and !> xce%xyzw (absolute point coordinates) for the pruned points. subroutine run_grid_aos ( xc_opts , xc_dat , basis ) use basis_tools , only : basis_set use blas_thread , only : blas_thread_count , blas_thread_set use , intrinsic :: iso_c_binding , only : c_int64_t !$  use omp_lib, only: omp_get_num_threads, omp_get_thread_num, & !$                     omp_get_max_threads, omp_get_num_procs implicit none class ( xc_consumer_t ), intent ( inout ) :: xc_dat type ( xc_options_t ), intent ( in ) :: xc_opts type ( basis_set ), intent ( in ) :: basis type ( xc_engine_t ), allocatable :: xce logical :: skip real ( KIND = fp ) :: dftthr , wcutoff integer :: iSlice , iAtom , npt , i , numNzPts real ( KIND = fp ) :: symw integer :: iChunk , chunkSize integer :: myThread , numThreads integer ( c_int64_t ) :: nBlasThreads !   Cap BLAS threads inside the slice-parallel region, see run_xc nBlasThreads = - 1 !$  if (omp_get_max_threads() > 1) then !$    nBlasThreads = blas_thread_count() !$    if (nBlasThreads > 0) then !$      call blas_thread_set(int(max(1, & !$               omp_get_num_procs()/omp_get_max_threads()), c_int64_t)) !$    end if !$  end if npt = xc_opts % molGrid % nMolPts dftthr = 1.0d-04 / npt if ( xc_opts % dft_threshold > 0.0d0 ) dftthr = xc_opts % dft_threshold wcutoff = 1.0d-15 if ( dftthr > 1.1d-15 ) wcutoff = 1.0d-08 / npt !$omp parallel & !$omp   private(iChunk, chunkSize, numThreads) & !$omp   private(iSlice, numNzPts, xce) & !$omp   private(myThread), & !$omp   private(i), & !$omp   private(iAtom, symw), & !$omp   private(skip) numThreads = 1 myThread = 1 !$  numThreads = omp_get_num_threads() !$  myThread = omp_get_thread_num()+1 chunkSize = max ( 1 , xc_opts % molGrid % nSlices / ( xc_dat % pe % size * 4 )) if ( chunkSize / numThreads > 40 ) then chunkSize = 40 * numThreads end if allocate ( xce ) call xce % init ( xc_opts ) !$omp master call xc_dat % parallel_start ( xce , numThreads ) !$omp end master !$omp barrier do iChunk = 1 , xc_opts % molGrid % nSlices , chunkSize if ( mod ( iChunk / chunkSize , xc_dat % pe % size ) /= xc_dat % pe % rank ) cycle !$omp do schedule(dynamic) slc : do iSlice = iChunk , min ( xc_opts % molGrid % nSlices , iChunk - 1 + chunkSize ) iAtom = xc_opts % molGrid % idOrigin ( iSlice ) ! Symmetry reduction: integrate only unique atoms' slices, with ! quadrature weights scaled by the atom-orbit size. symw = 1.0_fp if ( associated ( xc_opts % symAtomWeight )) then symw = xc_opts % symAtomWeight ( iAtom ) if ( symw == 0.0_fp ) CYCLE end if call xc_opts % molgrid % getSliceNonZero ( wcutoff , iSlice , xce % xyzw , numNzPts ) if ( numNzPts == 0 ) CYCLE if ( symw /= 1.0_fp ) xce % xyzw ( 1 : numNzPts , 4 ) = symw * xce % xyzw ( 1 : numNzPts , 4 ) call xce % resetPointers ( numNzPts ) do i = 1 , numNzPts xce % xyzw ( i ,: 3 ) = & xce % xyzw ( i ,: 3 ) + basis % atoms % xyz (: 3 , iAtom ) end do call xce % compAOs ( basis , xce % nAODer , xce % xyzw (: numNzPts ,: 3 )) call xce % pruneAOs ( skip ) IF ( skip ) CYCLE xce % currAtom = iAtom call xc_dat % update ( xce , myThread ) call xc_dat % postUpdate ( xce , myThread ) end do slc !$omp end do nowait end do deallocate ( xce ) !$omp end parallel call blas_thread_set ( nBlasThreads ) ! no-op if nBlasThreads == -1 call xc_dat % parallel_stop () end subroutine end module mod_dft_gridint","tags":"","url":"sourcefile/dft_gridint.f90.html"},{"title":"nlopt.F90 – OpenQP Fortran API","text":"Source Code module nlopt ! external nlopt declarations omitted for API generation end module nlopt","tags":"","url":"sourcefile/nlopt.f90.html"},{"title":"dft_gridint_giao.F90 – OpenQP Fortran API","text":"Source Code module mod_dft_gridint_giao use precision , only : fp use mod_dft_gridint , only : xc_engine_t , xc_consumer_t , OQP_FUNTYP_LDA use oqp_linalg implicit none !------------------------------------------------------------------------------- ! London (GIAO) derivative of the exchange-correlation potential (the ! \"vxc_giao\" term) in the first-order magnetic Hamiltonian for GIAO NMR. ! Per spin, accumulates three real matrices V(:,:,t); the caller antisymmetrizes ! (V - V&#94;T) and subtracts from h1. !   V_t[mu,nu] += aow_mu * ig_t,nu  +  aoV_mu * sum_g wv_g ipig_{g,t},nu !   ig_t,nu       = 0.5 (R_nu x r)_t aoV_nu                       (London AO value derivative) !   ipig_{g,t},nu = 0.5[(R_nu x r)_t aoG1_nu,g + (R_nu x e_g)_t aoV_nu] (London AO gradient derivative) !   aow_mu        = vrho*aoV_mu + sum_g wv_g aoG1_mu,g ! NOTE: d1dr/d1ds already carry the grid weight (XCLib%compute(.,wts)). ! NOTE: when xce%skip_p (no AO pruning) numAOs_p==numAOs and the AOs are in !   natural order, so the full AO index is k itself; indices_p(k) is only valid !   for the pruned (skip_p == .false.) case. !------------------------------------------------------------------------------- type , extends ( xc_consumer_t ) :: xc_consumer_giao_t real ( kind = fp ), allocatable :: aocent (:,:) real ( kind = fp ), allocatable :: va2 (:,:), vb2 (:,:) real ( kind = fp ), allocatable :: vmat_ (:,:), igs_ (:,:), aow_ (:,:) contains procedure :: parallel_start procedure :: parallel_stop procedure :: update procedure :: postUpdate procedure :: clean procedure :: getPtr end type private public xc_consumer_giao_t public giao_vxc contains subroutine parallel_start ( self , xce , nthreads ) class ( xc_consumer_giao_t ), target , intent ( inout ) :: self class ( xc_engine_t ), intent ( in ) :: xce integer , intent ( in ) :: nthreads integer :: nSpin nSpin = 1 if ( xce % hasBeta ) nSpin = 2 allocate ( self % va2 ( xce % numAOs * xce % numAOs * 3 , nthreads ), source = 0.0_fp ) if ( xce % hasBeta ) allocate ( self % vb2 ( xce % numAOs * xce % numAOs * 3 , nthreads ), source = 0.0_fp ) allocate ( self % vmat_ ( xce % numAOs * xce % numAOs * 3 * nSpin , nthreads ), source = 0.0_fp ) allocate ( self % igs_ ( xce % numAOs * xce % maxPts * 3 , nthreads ), source = 0.0_fp ) allocate ( self % aow_ ( xce % numAOs * xce % maxPts , nthreads ), source = 0.0_fp ) end subroutine subroutine parallel_stop ( self ) class ( xc_consumer_giao_t ), intent ( inout ) :: self if ( ubound ( self % va2 , 2 ) /= 1 ) self % va2 (:, 1 ) = sum ( self % va2 , dim = 2 ) call self % pe % allreduce ( self % va2 (:, 1 ), size ( self % va2 (:, 1 ))) if ( allocated ( self % vb2 )) then if ( ubound ( self % vb2 , 2 ) /= 1 ) self % vb2 (:, 1 ) = sum ( self % vb2 , dim = 2 ) call self % pe % allreduce ( self % vb2 (:, 1 ), size ( self % vb2 (:, 1 ))) end if end subroutine subroutine clean ( self ) class ( xc_consumer_giao_t ), intent ( inout ) :: self if ( allocated ( self % va2 )) deallocate ( self % va2 ) if ( allocated ( self % vb2 )) deallocate ( self % vb2 ) if ( allocated ( self % vmat_ )) deallocate ( self % vmat_ ) if ( allocated ( self % igs_ )) deallocate ( self % igs_ ) if ( allocated ( self % aow_ )) deallocate ( self % aow_ ) if ( allocated ( self % aocent )) deallocate ( self % aocent ) end subroutine subroutine getPtr ( self , nAOp , nPts , nSpin , mythread , vmat , ig , aow ) class ( xc_consumer_giao_t ), target , intent ( inout ) :: self integer , intent ( in ) :: nAOp , nPts , nSpin , mythread real ( kind = fp ), pointer , intent ( out ) :: vmat (:,:,:,:), ig (:,:,:), aow (:,:) vmat ( 1 : nAOp , 1 : nAOp , 1 : 3 , 1 : nSpin ) => self % vmat_ ( 1 : nAOp * nAOp * 3 * nSpin , mythread ) ig ( 1 : nAOp , 1 : nPts , 1 : 3 ) => self % igs_ ( 1 : nAOp * nPts * 3 , mythread ) aow ( 1 : nAOp , 1 : nPts ) => self % aow_ ( 1 : nAOp * nPts , mythread ) end subroutine subroutine update ( self , xce , mythread ) class ( xc_consumer_giao_t ), intent ( inout ) :: self class ( xc_engine_t ), intent ( in ) :: xce integer :: mythread real ( kind = fp ), pointer :: vmat (:,:,:,:), ig (:,:,:), aow (:,:) real ( kind = fp ), allocatable :: g2 (:,:), rc (:,:) integer :: nSpin , sp , i , k , t real ( kind = fp ) :: R ( 3 ), r3 ( 3 ), wv ( 3 ), cr ( 3 ), cre ( 3 , 3 ) nSpin = 1 if ( xce % hasBeta ) nSpin = 2 associate ( nAOp => xce % numAOs_p , nPts => xce % numPts , & aoV => xce % aoV , aoG1 => xce % aoG1 , & d1dr => xce % XCLib % d1dr , d1ds => xce % XCLib % d1ds , & drho => xce % XCLib % drho , ra => xce % XCLib % ids % ra , & rb => xce % XCLib % ids % rb , ga => xce % XCLib % ids % ga , & gb => xce % XCLib % ids % gb , gc => xce % XCLib % ids % gc , & indices => xce % indices_p ) call self % getPtr ( nAOp , nPts , nSpin , mythread , vmat , ig , aow ) vmat = 0.0_fp ! Cache the AO centers in pruned order (skip_p -> natural order k). allocate ( rc ( 3 , nAOp )) do k = 1 , nAOp if ( xce % skip_p ) then rc (:, k ) = self % aocent (:, k ) else rc (:, k ) = self % aocent (:, indices ( k )) end if end do ! GIAO value weight ig_t,nu = 0.5 (R_nu x r)_t aoV_nu do i = 1 , nPts r3 = xce % xyzw ( i , 1 : 3 ) do k = 1 , nAOp R = rc (:, k ) cr ( 1 ) = R ( 2 ) * r3 ( 3 ) - R ( 3 ) * r3 ( 2 ) cr ( 2 ) = R ( 3 ) * r3 ( 1 ) - R ( 1 ) * r3 ( 3 ) cr ( 3 ) = R ( 1 ) * r3 ( 2 ) - R ( 2 ) * r3 ( 1 ) ig ( k , i , 1 ) = 0.5_fp * cr ( 1 ) * aoV ( k , i ) ig ( k , i , 2 ) = 0.5_fp * cr ( 2 ) * aoV ( k , i ) ig ( k , i , 3 ) = 0.5_fp * cr ( 3 ) * aoV ( k , i ) end do end do if ( xce % funTyp /= OQP_FUNTYP_LDA ) allocate ( g2 ( nAOp , nPts )) do sp = 1 , nSpin do i = 1 , nPts if ( sp == 1 ) then aow (:, i ) = d1dr ( ra , i ) * aoV (:, i ) else aow (:, i ) = d1dr ( rb , i ) * aoV (:, i ) end if end do if ( xce % funTyp /= OQP_FUNTYP_LDA ) then do i = 1 , nPts if ( sp == 1 ) then wv = 2.0_fp * d1ds ( ga , i ) * drho ( 1 : 3 , i ) + d1ds ( gc , i ) * drho ( 4 : 6 , i ) else wv = 2.0_fp * d1ds ( gb , i ) * drho ( 4 : 6 , i ) + d1ds ( gc , i ) * drho ( 1 : 3 , i ) end if aow (:, i ) = aow (:, i ) + wv ( 1 ) * aoG1 (:, i , 1 ) + wv ( 2 ) * aoG1 (:, i , 2 ) + wv ( 3 ) * aoG1 (:, i , 3 ) end do end if do t = 1 , 3 call dgemm ( 'N' , 'T' , nAOp , nAOp , nPts , 1.0_fp , & aow , nAOp , ig (:,:, t ), nAOp , 1.0_fp , vmat (:,:, t , sp ), nAOp ) end do if ( xce % funTyp /= OQP_FUNTYP_LDA ) then do t = 1 , 3 do i = 1 , nPts r3 = xce % xyzw ( i , 1 : 3 ) if ( sp == 1 ) then wv = 2.0_fp * d1ds ( ga , i ) * drho ( 1 : 3 , i ) + d1ds ( gc , i ) * drho ( 4 : 6 , i ) else wv = 2.0_fp * d1ds ( gb , i ) * drho ( 4 : 6 , i ) + d1ds ( gc , i ) * drho ( 1 : 3 , i ) end if do k = 1 , nAOp R = rc (:, k ) cr ( 1 ) = R ( 2 ) * r3 ( 3 ) - R ( 3 ) * r3 ( 2 ) cr ( 2 ) = R ( 3 ) * r3 ( 1 ) - R ( 1 ) * r3 ( 3 ) cr ( 3 ) = R ( 1 ) * r3 ( 2 ) - R ( 2 ) * r3 ( 1 ) cre ( 1 , 1 ) = 0.0_fp ; cre ( 2 , 1 ) = R ( 3 ); cre ( 3 , 1 ) =- R ( 2 ) cre ( 1 , 2 ) =- R ( 3 ); cre ( 2 , 2 ) = 0.0_fp ; cre ( 3 , 2 ) = R ( 1 ) cre ( 1 , 3 ) = R ( 2 ); cre ( 2 , 3 ) =- R ( 1 ); cre ( 3 , 3 ) = 0.0_fp g2 ( k , i ) = 0.5_fp * ( wv ( 1 ) * ( cr ( t ) * aoG1 ( k , i , 1 ) + cre ( t , 1 ) * aoV ( k , i )) & + wv ( 2 ) * ( cr ( t ) * aoG1 ( k , i , 2 ) + cre ( t , 2 ) * aoV ( k , i )) & + wv ( 3 ) * ( cr ( t ) * aoG1 ( k , i , 3 ) + cre ( t , 3 ) * aoV ( k , i )) ) end do end do call dgemm ( 'N' , 'T' , nAOp , nAOp , nPts , 1.0_fp , & aoV , nAOp , g2 , nAOp , 1.0_fp , vmat (:,:, t , sp ), nAOp ) end do end if end do if ( allocated ( g2 )) deallocate ( g2 ) deallocate ( rc ) end associate end subroutine subroutine postUpdate ( self , xce , mythread ) class ( xc_consumer_giao_t ), intent ( inout ) :: self class ( xc_engine_t ), intent ( in ) :: xce integer :: mythread real ( kind = fp ), pointer :: vmat (:,:,:,:), ig (:,:,:), aow (:,:) real ( kind = fp ), pointer :: va (:,:,:), vb (:,:,:) integer :: nSpin , t , nAO nSpin = 1 if ( xce % hasBeta ) nSpin = 2 nAO = xce % numAOs associate ( nAOp => xce % numAOs_p , indices => xce % indices_p ) call self % getPtr ( nAOp , max ( xce % numPts , 1 ), nSpin , mythread , vmat , ig , aow ) call mapfull ( self % va2 (:, mythread ), nAO , va ) if ( xce % hasBeta ) call mapfull ( self % vb2 (:, mythread ), nAO , vb ) if ( xce % skip_p ) then do t = 1 , 3 va (:,:, t ) = va (:,:, t ) + vmat (:,:, t , 1 ) if ( xce % hasBeta ) vb (:,:, t ) = vb (:,:, t ) + vmat (:,:, t , 2 ) end do else do t = 1 , 3 va ( indices ( 1 : nAOp ), indices ( 1 : nAOp ), t ) = & va ( indices ( 1 : nAOp ), indices ( 1 : nAOp ), t ) + vmat (:,:, t , 1 ) if ( xce % hasBeta ) & vb ( indices ( 1 : nAOp ), indices ( 1 : nAOp ), t ) = & vb ( indices ( 1 : nAOp ), indices ( 1 : nAOp ), t ) + vmat (:,:, t , 2 ) end do end if end associate contains subroutine mapfull ( buf , n , p ) real ( kind = fp ), target , intent ( inout ) :: buf (:) integer , intent ( in ) :: n real ( kind = fp ), pointer , intent ( out ) :: p (:,:,:) p ( 1 : n , 1 : n , 1 : 3 ) => buf ( 1 : n * n * 3 ) end subroutine end subroutine !------------------------------------------------------------------------------- subroutine giao_vxc ( basis , molGrid , infos , coeffa , coeffb , urohf , & vmata , vmatb , mxAngMom , nbf , dft_threshold ) use mod_dft_molgrid , only : dft_grid_t use basis_tools , only : basis_set use mod_dft_gridint , only : xc_options_t , run_xc use types , only : information type ( dft_grid_t ), target , intent ( in ) :: molGrid type ( information ), target , intent ( in ) :: infos type ( basis_set ) :: basis logical , intent ( in ) :: urohf integer , intent ( in ) :: mxAngMom , nbf real ( kind = fp ), target , intent ( inout ) :: coeffa ( nbf , * ), coeffb ( nbf , * ) real ( kind = fp ), intent ( out ) :: vmata ( 3 , nbf , nbf ), vmatb ( 3 , nbf , nbf ) real ( kind = fp ), intent ( in ) :: dft_threshold type ( xc_consumer_giao_t ) :: dat type ( xc_options_t ) :: xc_opts integer :: i , j , t , ish , k , ao real ( kind = fp ), allocatable :: full (:,:,:) do j = 1 , nbf coeffa (:, j ) = coeffa (:, j ) * basis % bfnrm (:) end do if ( urohf ) then do j = 1 , nbf coeffb (:, j ) = coeffb (:, j ) * basis % bfnrm (:) end do end if allocate ( dat % aocent ( 3 , nbf )) do ish = 1 , basis % nshell do k = 1 , basis % naos ( ish ) ao = basis % ao_offset ( ish ) + k - 1 dat % aocent (:, ao ) = basis % shell_centers ( ish , 1 : 3 ) end do end do xc_opts % isGGA = infos % functional % needGrd xc_opts % needTau = . false . xc_opts % functional => infos % functional xc_opts % hasBeta = urohf xc_opts % isWFVecs = . true . xc_opts % numAOs = nbf xc_opts % maxPts = molGrid % maxSlicePts xc_opts % limPts = molGrid % maxNRadTimesNAng xc_opts % numAtoms = infos % mol_prop % natom xc_opts % maxAngMom = mxAngMom xc_opts % nDer = 0 xc_opts % numOccAlpha = infos % mol_prop % nelec_A xc_opts % numOccBeta = infos % mol_prop % nelec_B xc_opts % wfAlpha => coeffa (:, 1 : nbf ) xc_opts % wfBeta => coeffb (:, 1 : nbf ) xc_opts % molGrid => molGrid xc_opts % dft_threshold = dft_threshold xc_opts % ao_threshold = infos % dft % grid_ao_threshold xc_opts % ao_sparsity_ratio = infos % dft % grid_ao_sparsity_ratio if ( infos % dft % grid_pruned ) xc_opts % ao_sparsity_ratio = 0.0_fp call dat % pe % init ( infos % mpiinfo % comm , infos % mpiinfo % usempi ) call run_xc ( xc_opts , dat , basis ) do j = 1 , nbf coeffa (:, j ) = coeffa (:, j ) / basis % bfnrm (:) end do if ( urohf ) then do j = 1 , nbf coeffb (:, j ) = coeffb (:, j ) / basis % bfnrm (:) end do end if allocate ( full ( nbf , nbf , 3 )) full = reshape ( dat % va2 ( 1 : nbf * nbf * 3 , 1 ), [ nbf , nbf , 3 ]) do t = 1 , 3 do i = 1 , nbf do j = 1 , nbf vmata ( t , i , j ) = ( full ( i , j , t ) - full ( j , i , t )) * basis % bfnrm ( i ) * basis % bfnrm ( j ) end do end do end do if ( urohf ) then full = reshape ( dat % vb2 ( 1 : nbf * nbf * 3 , 1 ), [ nbf , nbf , 3 ]) do t = 1 , 3 do i = 1 , nbf do j = 1 , nbf vmatb ( t , i , j ) = ( full ( i , j , t ) - full ( j , i , t )) * basis % bfnrm ( i ) * basis % bfnrm ( j ) end do end do end do end if deallocate ( full ) call dat % clean () end subroutine end module mod_dft_gridint_giao","tags":"","url":"sourcefile/dft_gridint_giao.f90.html"},{"title":"dft_gridint_energy.F90 – OpenQP Fortran API","text":"Source Code module mod_dft_gridint_energy use precision , only : fp use mod_dft_gridint , only : xc_engine_t , xc_consumer_t , OQP_FUNTYP_LDA , OQP_FUNTYP_MGGA use oqp_linalg implicit none !------------------------------------------------------------------------------- type , extends ( xc_consumer_t ) :: xc_consumer_ks_t real ( kind = fp ), allocatable :: fa2 (:,:) real ( kind = fp ), allocatable :: fb2 (:,:) real ( kind = fp ), allocatable :: focks_ (:,:) real ( kind = fp ), allocatable :: tmp_ (:,:) contains procedure :: parallel_start procedure :: parallel_stop procedure :: resetOrbPointers procedure :: update procedure :: postUpdate procedure :: clean end type !------------------------------------------------------------------------------- private public dmatd_blk , dmatd_density_blk !------------------------------------------------------------------------------- contains !------------------------------------------------------------------------------- subroutine parallel_start ( self , xce , nthreads ) implicit none class ( xc_consumer_ks_t ), target , intent ( inout ) :: self class ( xc_engine_t ), intent ( in ) :: xce integer , intent ( in ) :: nthreads integer :: nSpin call self % clean () nSpin = 1 if ( xce % hasBeta ) nSpin = 2 allocate ( self % fa2 ( xce % numAOs * xce % numAOs , nthreads ) & , self % focks_ ( xce % numAOs * xce % numAOs * nSpin , nthreads ) & , self % tmp_ ( xce % numAOs * xce % maxPts * xce % numTmpVec , nthreads ) & , source = 0.0d0 ) if ( xce % hasBeta ) then allocate ( self % fb2 ( xce % numAOs * xce % numAOs , nthreads ), source = 0.0d0 ) end if end subroutine !------------------------------------------------------------------------------- subroutine parallel_stop ( self ) implicit none class ( xc_consumer_ks_t ), intent ( inout ) :: self if ( ubound ( self % fa2 , 2 ) /= 1 ) then self % fa2 (:, lbound ( self % fa2 , 2 )) = sum ( self % fa2 , dim = size ( shape ( self % fa2 ))) end if call self % pe % allreduce ( self % fa2 (:, 1 ), & size ( self % fa2 (:, 1 ))) if ( allocated ( self % fb2 )) then if ( ubound ( self % fa2 , 2 ) /= 1 ) then self % fb2 (:, lbound ( self % fb2 , 2 )) = sum ( self % fb2 , dim = size ( shape ( self % fb2 ))) end if call self % pe % allreduce ( self % fb2 (:, 1 ), & size ( self % fb2 (:, 1 ))) end if end subroutine !------------------------------------------------------------------------------- subroutine clean ( self ) implicit none class ( xc_consumer_ks_t ), intent ( inout ) :: self if ( allocated ( self % fa2 )) deallocate ( self % fa2 ) if ( allocated ( self % fb2 )) deallocate ( self % fb2 ) if ( allocated ( self % focks_ )) deallocate ( self % focks_ ) if ( allocated ( self % tmp_ )) deallocate ( self % tmp_ ) end subroutine !------------------------------------------------------------------------------- !> @brief Adjust internal memory storage for a given !>  number of pruned grid points !> @author Konstantin Komarov subroutine resetOrbPointers ( self , xce , focks , tmp , fock_a , fock_b , myThread ) class ( xc_consumer_ks_t ), target , intent ( inout ) :: self class ( xc_engine_t ), intent ( in ) :: xce real ( kind = fp ), intent ( out ), pointer :: focks (:,:,:) real ( kind = fp ), intent ( out ), pointer , optional :: tmp (:,:,:) real ( kind = fp ), intent ( out ), pointer , optional :: fock_a (:,:) real ( kind = fp ), intent ( out ), pointer , optional :: fock_b (:,:) integer , intent ( in ) :: myThread integer :: nSpin associate ( numAOs => xce % numAOs & , numAOs_p => xce % numAOs_p & , numPts => xce % numPts & , TmpVec => xce % numTmpVec & , hasBeta => xce % hasBeta & ) nSpin = 1 if ( hasBeta ) nSpin = 2 focks ( 1 : numAOs_p , 1 : numAOs_p , 1 : nSpin ) => self % focks_ ( 1 : numAOs_p * numAOs_p * nSpin , myThread ) if ( present ( tmp )) & tmp ( 1 : numAOs_p , 1 : numPts , 1 : TmpVec ) => self % tmp_ ( 1 : numAOs_p * numPts * TmpVec , myThread ) if ( present ( fock_a )) fock_a ( 1 : numAOs , 1 : numAOs ) => self % fa2 ( 1 : numAOs * numAOs , myThread ) if ( present ( fock_b )) fock_b ( 1 : numAOs , 1 : numAOs ) => self % fb2 ( 1 : numAOs * numAOs , myThread ) end associate end subroutine !------------------------------------------------------------------------------- subroutine update ( self , xce , mythread ) implicit none class ( xc_consumer_ks_t ), intent ( inout ) :: self class ( xc_engine_t ), intent ( in ) :: xce integer :: mythread integer :: i , j real ( kind = fp ) :: c ( 3 ) real ( kind = fp ), pointer :: focks (:,:,:) real ( kind = fp ), pointer :: tmp (:,:,:) call self % resetOrbPointers ( xce , focks = focks , tmp = tmp , myThread = myThread ) associate ( d1dr => xce % XCLib % d1dr & , d1ds => xce % XCLib % d1ds & , d1dt => xce % XCLib % d1dt & , ra => xce % XCLib % ids % ra & , rb => xce % XCLib % ids % rb & , ga => xce % XCLib % ids % ga & , gb => xce % XCLib % ids % gb & , gc => xce % XCLib % ids % gc & , ta => xce % XCLib % ids % ta & , tb => xce % XCLib % ids % tb & , drho => xce % XCLib % drho & , aoV => xce % aoV & , aoG1 => xce % aoG1 & , numAOs => xce % numAOs_p & ! number of pruned AOs , numPts => xce % numPts & ) if ( xce % funTyp == OQP_FUNTYP_LDA ) then do i = 1 , numPts tmp (:, i , 1 ) = 0.5 * d1dr ( ra , i ) * aoV (:, i ) end do else ! LDA and GGA terms in a single pass over tmp do i = 1 , numPts c = 2 * d1ds ( ga , i ) * drho ( 1 : 3 , i ) + d1ds ( gc , i ) * drho ( 4 : 6 , i ) tmp (:, i , 1 ) = 0.5 * d1dr ( ra , i ) * aoV (:, i ) & + c ( 1 ) * aoG1 (:, i , 1 ) & + c ( 2 ) * aoG1 (:, i , 2 ) & + c ( 3 ) * aoG1 (:, i , 3 ) end do end if call dsyr2k ( 'U' , 'N' , numAOs , numPts , 1.0_fp , & aoV , numAOs , & tmp (:,:, 1 ), numAOs , & 0.0_fp , focks (:,:, 1 ), numAOs ) ! metaGGA case if ( xce % funTyp == OQP_FUNTYP_MGGA ) then do i = 1 , numPts tmp (:, i , 2 : 4 ) = d1dt ( ta , i ) * aoG1 (:, i , 1 : 3 ) end do do j = 1 , 3 call dsyr2k ( 'U' , 'N' , numAOs , numPts , 0.25_fp , & aoG1 (:,:, j ), numAOs , & tmp (:,:, j + 1 ), numAOs , & 1.0_fp , focks (:,:, 1 ), numAOs ) end do end if if ( xce % hasBeta ) then if ( xce % funTyp == OQP_FUNTYP_LDA ) then do i = 1 , numPts tmp (:, i , 1 ) = 0.5 * d1dr ( rb , i ) * aoV (:, i ) end do else ! LDA and GGA terms in a single pass over tmp do i = 1 , numPts c = 2 * d1ds ( gb , i ) * drho ( 4 : 6 , i ) + d1ds ( gc , i ) * drho ( 1 : 3 , i ) tmp (:, i , 1 ) = 0.5 * d1dr ( rb , i ) * aoV (:, i ) & + c ( 1 ) * aoG1 (:, i , 1 ) & + c ( 2 ) * aoG1 (:, i , 2 ) & + c ( 3 ) * aoG1 (:, i , 3 ) end do end if call dsyr2k ( 'U' , 'N' , numAOs , numPts , 1.0_fp , & aoV , numAOs , & tmp (:,:, 1 ), numAOs , & 0.0_fp , focks (:,:, 2 ), numAOs ) ! metaGGA case if ( xce % funTyp == OQP_FUNTYP_MGGA ) then do i = 1 , numPts tmp (:, i , 2 : 4 ) = d1dt ( tb , i ) * aoG1 (:, i , 1 : 3 ) end do do j = 1 , 3 call dsyr2k ( 'U' , 'N' , numAOs , numPts , 0.25_fp , & aoG1 (:,:, j ), numAOs , & tmp (:,:, j + 1 ), numAOs , & 1.0_fp , focks (:,:, 2 ), numAOs ) end do end if end if end associate end subroutine subroutine postUpdate ( self , xce , mythread ) implicit none class ( xc_consumer_ks_t ), intent ( inout ) :: self class ( xc_engine_t ), intent ( in ) :: xce integer :: mythread real ( kind = fp ), pointer :: focks (:,:,:) real ( kind = fp ), pointer :: fock_a (:,:) real ( kind = fp ), pointer :: fock_b (:,:) integer :: i , j , jj call self % resetOrbPointers ( xce , focks = focks , fock_a = fock_a , & fock_b = fock_b , myThread = myThread ) associate ( numAOs => xce % numAOs_p & ! number of pruned AOs , indices => xce % indices_p & ) ! Only the upper triangle of focks is valid (dsyr2k 'U' in update) ! and only the upper triangle of fock_a/fock_b is consumed in ! dmatd_blk, so accumulate just that part.  The indices are ! ascending, hence the scatter keeps upper triangle upper. if ( xce % skip_p ) then do j = 1 , numAOs fock_a ( 1 : j , j ) = fock_a ( 1 : j , j ) + focks ( 1 : j , j , 1 ) end do if ( xce % hasBeta ) then do j = 1 , numAOs fock_b ( 1 : j , j ) = fock_b ( 1 : j , j ) + focks ( 1 : j , j , 2 ) end do end if else do j = 1 , numAOs jj = indices ( j ) do i = 1 , j fock_a ( indices ( i ), jj ) = fock_a ( indices ( i ), jj ) + focks ( i , j , 1 ) end do end do if ( xce % hasBeta ) then do j = 1 , numAOs jj = indices ( j ) do i = 1 , j fock_b ( indices ( i ), jj ) = fock_b ( indices ( i ), jj ) + focks ( i , j , 2 ) end do end do end if end if end associate end subroutine !------------------------------------------------------------------------------- !> @brief Compute grid XC contribution to the Kohn-Sham matrix !> @param[in]    coeffa     MO coefficients, alpha-spin !> @param[in]    coeffb     MO coefficients, beta-spin !> @param[inout] fa         KS matrix, alpha-spin !> @param[inout] fb         KS matrix, beta-spin !> @param[out]   exc        XC energy !> @param[out]   totele     electronic denisty integral !> @param[out]   totkin     kinetic energy integral !> @param[in]    mxAngMom   max. needed ang. mom. value (incl. derivatives) !> @param[in]    nbf         basis set size !> @param[in]    urohf      .TRUE. if open-shell calculation !> @author Vladimir Mironov subroutine dmatd_blk ( basis , molGrid , coeffa , coeffb , fa , fb , & exc , totele , totkin , & mxAngMom , nbf , dft_threshold , urohf , infos , & sym_atom_weight ) !$  use omp_lib, only: omp_get_num_threads, omp_get_thread_num use mod_dft_molgrid , only : dft_grid_t use basis_tools , only : basis_set use mod_dft_gridint , only : xc_options_t , run_xc use types , only : information implicit none type ( dft_grid_t ), target , intent ( in ) :: molGrid type ( information ), target , intent ( in ) :: infos type ( basis_set ) :: basis logical , intent ( IN ) :: urohf integer , intent ( IN ) :: mxAngMom , nbf real ( kind = fp ), intent ( inout ) :: exc , totele , totkin real ( kind = fp ), target , intent ( inout ) :: coeffa ( nbf , * ), coeffb ( nbf , * ) real ( kind = fp ), intent ( inout ) :: fa ( * ), fb ( * ) real ( kind = fp ), intent ( in ) :: dft_threshold !> Optional symmetry-reduction atom weights (orbit size or zero). real ( kind = fp ), intent ( in ), optional , contiguous , target :: sym_atom_weight (:) type ( xc_consumer_ks_t ) :: dat type ( xc_options_t ) :: xc_opts integer :: i0 , i , j do j = 1 , nbf coeffa (:, j ) = coeffa (:, j ) * basis % bfnrm (:) end do if ( urohf ) then do j = 1 , nbf coeffb (:, j ) = coeffb (:, j ) * basis % bfnrm (:) end do end if xc_opts % isGGA = infos % functional % needGrd xc_opts % needTau = infos % functional % needTau xc_opts % functional => infos % functional xc_opts % hasBeta = urohf xc_opts % isWFVecs = . true . xc_opts % numAOs = nbf xc_opts % maxPts = molGrid % maxSlicePts xc_opts % limPts = molGrid % maxNRadTimesNAng xc_opts % numAtoms = infos % mol_prop % natom xc_opts % maxAngMom = mxAngMom xc_opts % nDer = 0 xc_opts % numOccAlpha = infos % mol_prop % nelec_A xc_opts % numOccBeta = infos % mol_prop % nelec_B xc_opts % wfAlpha => coeffa (:, 1 : nbf ) xc_opts % wfBeta => coeffb (:, 1 : nbf ) xc_opts % molGrid => molGrid xc_opts % dft_threshold = dft_threshold xc_opts % ao_threshold = infos % dft % grid_ao_threshold xc_opts % ao_sparsity_ratio = infos % dft % grid_ao_sparsity_ratio ! skip ao_prune_grid if it is pruned grid (SG1) if ( infos % dft % grid_pruned ) xc_opts % ao_sparsity_ratio = 0.0_fp if ( present ( sym_atom_weight )) xc_opts % symAtomWeight => sym_atom_weight ! NB: the Phi cache is deliberately NOT opted-in here. dmatd_blk is reached by ! one-shot callers (e.g. finite-difference Hessian via dftexcor, each at a new ! displaced geometry) where the per-slice cache would be built but never ! replayed -- pure memory/copy overhead. The repeated SCF Fock build reaches ! the grid through dmatd_density_blk, which is where the opt-in lives. call dat % pe % init ( infos % mpiinfo % comm , infos % mpiinfo % usempi ) call run_xc ( xc_opts , dat , basis ) exc = dat % E_xc totele = dat % N_elec totkin = dat % E_kin !   Normalize KS matrices do j = 1 , nbf coeffa (:, j ) = coeffa (:, j ) / basis % bfnrm (:) end do i0 = 0 do i = 1 , nbf fa ( i0 + 1 : i0 + i ) = fa ( i0 + 1 : i0 + i ) + & dat % fa2 (( i - 1 ) * nbf + 1 :( i - 1 ) * nbf + i , 1 ) & * basis % bfnrm ( i ) & * basis % bfnrm ( 1 : i ) i0 = i0 + i end do if ( urohf ) then do j = 1 , nbf coeffb (:, j ) = coeffb (:, j ) / basis % bfnrm (:) end do i0 = 0 do i = 1 , nbf fb ( i0 + 1 : i0 + i ) = fb ( i0 + 1 : i0 + i ) + & dat % fb2 (( i - 1 ) * nbf + 1 :( i - 1 ) * nbf + i , 1 ) & * basis % bfnrm ( i ) & * basis % bfnrm ( 1 : i ) i0 = i0 + i end do end if call dat % clean () end subroutine dmatd_blk !------------------------------------------------------------------------------- subroutine dmatd_density_blk ( basis , molGrid , dena , denb , fa , fb , & exc , totele , totkin , & mxAngMom , nbf , dft_threshold , urohf , infos ) use mod_dft_molgrid , only : dft_grid_t use basis_tools , only : basis_set use mod_dft_gridint , only : xc_options_t , run_xc use types , only : information implicit none type ( dft_grid_t ), target , intent ( in ) :: molGrid type ( information ), target , intent ( in ) :: infos type ( basis_set ) :: basis logical , intent ( in ) :: urohf integer , intent ( in ) :: mxAngMom , nbf real ( kind = fp ), intent ( out ) :: exc , totele , totkin real ( kind = fp ), target , intent ( in ) :: dena ( nbf , nbf ), denb ( nbf , nbf ) real ( kind = fp ), intent ( inout ) :: fa ( * ), fb ( * ) real ( kind = fp ), intent ( in ) :: dft_threshold type ( xc_consumer_ks_t ) :: dat type ( xc_options_t ) :: xc_opts real ( kind = fp ), target , allocatable :: da2 (:,:), db2 (:,:) integer :: i0 , i , j , nang allocate ( da2 ( nbf , nbf ), source = 0.0_fp ) do j = 1 , nbf da2 (:, j ) = dena (:, j ) * basis % bfnrm ( j ) * basis % bfnrm ( 1 : nbf ) end do if ( urohf ) then allocate ( db2 ( nbf , nbf ), source = 0.0_fp ) do j = 1 , nbf db2 (:, j ) = denb (:, j ) * basis % bfnrm ( j ) * basis % bfnrm ( 1 : nbf ) end do end if nang = maxval ( basis % am ) + 1 + 1 fa ( 1 : nbf * ( nbf + 1 ) / 2 ) = 0.0_fp if ( urohf ) fb ( 1 : nbf * ( nbf + 1 ) / 2 ) = 0.0_fp exc = 0.0_fp totele = 0.0_fp totkin = 0.0_fp xc_opts % isGGA = infos % functional % needGrd xc_opts % needTau = infos % functional % needTau xc_opts % functional => infos % functional xc_opts % hasBeta = urohf xc_opts % isWFVecs = . false . xc_opts % numAOs = nbf xc_opts % maxPts = molGrid % maxSlicePts xc_opts % limPts = molGrid % maxNRadTimesNAng xc_opts % numAtoms = infos % mol_prop % natom xc_opts % maxAngMom = nang xc_opts % nDer = 0 xc_opts % numOccAlpha = infos % mol_prop % nelec_A xc_opts % numOccBeta = infos % mol_prop % nelec_B xc_opts % wfAlpha => da2 if ( urohf ) xc_opts % wfBeta => db2 xc_opts % molGrid => molGrid xc_opts % dft_threshold = dft_threshold xc_opts % ao_threshold = infos % dft % grid_ao_threshold xc_opts % ao_sparsity_ratio = 0.0_fp ! Opt 1: the SCF Fock build reaches the grid through this density-driven path ! (calc_fock passes the packed density as dens_in). Enable the cross-iteration ! Phi cache from [scf] xc_phi_cache (infos%control%xc_phi_cache). xc_opts % use_phi_cache = ( infos % control % xc_phi_cache /= 0 ) call dat % pe % init ( infos % mpiinfo % comm , infos % mpiinfo % usempi ) call run_xc ( xc_opts , dat , basis ) exc = dat % E_xc totele = dat % N_elec totkin = dat % E_kin i0 = 0 do i = 1 , nbf fa ( i0 + 1 : i0 + i ) = fa ( i0 + 1 : i0 + i ) + & dat % fa2 (( i - 1 ) * nbf + 1 :( i - 1 ) * nbf + i , 1 ) & * basis % bfnrm ( i ) & * basis % bfnrm ( 1 : i ) i0 = i0 + i end do if ( urohf ) then i0 = 0 do i = 1 , nbf fb ( i0 + 1 : i0 + i ) = fb ( i0 + 1 : i0 + i ) + & dat % fb2 (( i - 1 ) * nbf + 1 :( i - 1 ) * nbf + i , 1 ) & * basis % bfnrm ( i ) & * basis % bfnrm ( 1 : i ) i0 = i0 + i end do end if call dat % clean () if ( allocated ( da2 )) deallocate ( da2 ) if ( allocated ( db2 )) deallocate ( db2 ) end subroutine dmatd_density_blk !------------------------------------------------------------------------------- end module mod_dft_gridint_energy","tags":"","url":"sourcefile/dft_gridint_energy.f90.html"},{"title":"tdhf_mrsf_energy.F90 – OpenQP Fortran API","text":"Source Code module tdhf_mrsf_energy_mod implicit none character ( len =* ), parameter :: module_name = \"tdhf_mrsf_energy_mod\" contains subroutine tdhf_mrsf_energy_C ( c_handle ) bind ( C , name = \"tdhf_mrsf_energy\" ) use c_interop , only : oqp_handle_t , oqp_handle_get_info use types , only : information type ( oqp_handle_t ) :: c_handle type ( information ), pointer :: inf inf => oqp_handle_get_info ( c_handle ) inf % tddft % umrsf = . false . call tdhf_mrsf_energy_with_restart ( inf ) end subroutine tdhf_mrsf_energy_C subroutine tdhf_umrsf_energy_C ( c_handle ) bind ( C , name = \"tdhf_umrsf_energy\" ) use c_interop , only : oqp_handle_t , oqp_handle_get_info use types , only : information type ( oqp_handle_t ) :: c_handle type ( information ), pointer :: inf logical :: previous_umrsf inf => oqp_handle_get_info ( c_handle ) previous_umrsf = inf % tddft % umrsf inf % tddft % umrsf = . true . call tdhf_mrsf_energy_with_restart ( inf ) inf % tddft % umrsf = previous_umrsf end subroutine tdhf_umrsf_energy_C ! Run the MRSF Davidson and, if it fails to converge, auto-restart with a ! larger subspace (maxvec) and more iterations (maxit_dav).  Re-invoking the ! driver reallocates a fresh, larger Krylov subspace, so no inner-loop state ! is reused.  The user's maxvec/maxit_dav are restored afterwards. subroutine tdhf_mrsf_energy_with_restart ( infos ) use types , only : information use io_constants , only : iw type ( information ), intent ( inout ) :: infos integer , parameter :: max_restarts = 2 integer :: attempt , maxvec0 , maxit0 maxvec0 = infos % tddft % maxvec maxit0 = infos % control % maxit_dav do attempt = 0 , max_restarts call tdhf_mrsf_energy ( infos ) if ( infos % mol_energy % Davidson_converged ) exit if ( attempt < max_restarts ) then infos % tddft % maxvec = 2 * infos % tddft % maxvec infos % control % maxit_dav = 2 * infos % control % maxit_dav ! The energy routine closes the log on exit; reopen to record the restart. open ( unit = iw , file = infos % log_filename , position = \"append\" ) write ( iw , '(/,2X,\"MRSF Davidson not converged; auto-restart #\",I0, & &\" with larger subspace (maxvec=\",I0,\", maxit_dav=\",I0,\")\"/)' ) & attempt + 1 , infos % tddft % maxvec , infos % control % maxit_dav close ( iw ) end if end do infos % tddft % maxvec = maxvec0 infos % control % maxit_dav = maxit0 end subroutine tdhf_mrsf_energy_with_restart subroutine tdhf_mrsf_energy ( infos ) use io_constants , only : iw use oqp_tagarray_driver use types , only : information use strings , only : cstring , fstring use basis_tools , only : basis_set use messages , only : show_message , with_abort use util , only : measure_time use precision , only : dp use int2_compute , only : int2_compute_t use tdhf_mrsf_lib , only : int2_mrsf_data_t , int2_umrsf_data_t use tdhf_lib , only : sym_response_project , & int2_td_data_t use tdhf_lib , only : & iatogen , mntoia , rparedms , rpaeig , rpavnorm , & rpaechk , rpanewb , & rpaprint , inivec use tdhf_sf_lib , only : sfresvec , sfqvec , sfdmat , trfrmb , & get_transition_density , get_transitions , & get_transition_dipole , print_results , get_spin_square use tdhf_mrsf_lib , only : & mrinivec , mrsfcbc , umrsfcbc , mrsfmntoia , umrsfmntoia , mrsfesum , & mrsfqroesum , get_mrsf_transitions , & get_mrsf_transition_density , get_jacobi , umrsfssqu , mrsf_set_fp32 use mathlib , only : orthogonal_transform , orthogonal_transform_sym , & unpack_matrix use oqp_linalg use int1 , only : multipole_integrals use printing , only : print_module_info use iso_c_binding , only : c_f_pointer , c_int implicit none character ( len =* ), parameter :: subroutine_name = \"tdhf_mrsf_energy\" type ( basis_set ), pointer :: basis type ( information ), target , intent ( inout ) :: infos integer :: s_size , ok real ( kind = dp ), allocatable :: scr2 (:), scr3 (:) real ( kind = dp ), allocatable :: wrk1 (:,:), qvec (:,:) real ( kind = dp ), allocatable :: sym_ritz (:,:) real ( kind = dp ), allocatable :: amo (:,:), wrk2 (:,:) real ( kind = dp ), allocatable :: squared_S (:) real ( kind = dp ), allocatable :: amb (:,:), apb (:,:), smat_full (:,:) real ( kind = dp ), allocatable , target :: vl (:), vr (:) real ( kind = dp ), pointer :: vl_p (:,:), vr_p (:,:) real ( kind = dp ), allocatable :: xm (:), scr (:) real ( kind = dp ), allocatable :: bvec_mo (:,:), for_trnsf_b_vec (:,:) real ( kind = dp ), allocatable , dimension (:,:) :: fa , fb real ( kind = dp ), allocatable , dimension (:) :: rnorm real ( kind = dp ), allocatable , dimension (:) :: mo_energy_work_a , mo_energy_work_b real ( kind = dp ), allocatable , dimension (:,:,:,:) :: trden integer , allocatable , dimension (:,:) :: trans real ( kind = dp ), allocatable , target :: mrsf_density (:,:,:,:) real ( kind = dp ), pointer :: fmrst2 (:,:,:,:) real ( kind = dp ), allocatable , target :: fmrq1 (:,:,:) real ( kind = dp ), allocatable :: dip (:,:,:), bvec_mo_tmp (:), eex (:) integer ( c_int ) , pointer :: ixcore_ptr (:) ! misc-excited-analysis: tagarray exposure of the MRSF densities / dipoles real ( kind = dp ), pointer :: trden_store (:,:,:), dip_store (:,:,:), dipao_store (:,:) real ( kind = dp ), allocatable :: mints_exp (:,:) real ( kind = dp ) :: com_exp ( 3 ) integer :: nocca , nvira , noccb , nvirb integer :: nbf , nbf2 , xvec_dim integer :: mxvec , ist , jst , iend , nvec , novec integer :: iter , nv , iv , ivec integer :: diag_index , i integer :: mxiter logical :: tamm_dancoff integer :: imax integer :: ierr logical :: converged real ( kind = dp ) :: rc_save , rc_new real ( kind = dp ) :: mxerr , cnvtol , scale_exch real ( kind = dp ) :: spc_scale_coco , spc_scale_ovov , spc_scale_coov integer :: maxvec , mrst , nstates , target_state logical :: roref = . false . logical :: uhfref = . false . logical :: debug_mode type ( int2_compute_t ) :: int2_driver type ( int2_mrsf_data_t ), target :: int2_data_st type ( int2_umrsf_data_t ), target :: int2_udata_st type ( int2_td_data_t ), target :: int2_data_q logical :: dft = . false . integer :: scf_type , mol_mult character ( len = 16 ) :: method_name logical :: umrsf ! tagarray real ( kind = dp ), contiguous , pointer :: & fock_a (:), dmat_a (:), mo_A (:,:), mo_energy_a (:), & fock_b (:), dmat_b (:), mo_b (:,:), mo_energy_b (:), & smat (:), ta (:), tb (:), td_t (:,:), bvec_mo_out (:,:), & mrsf_energies (:) character ( len =* ), parameter :: tags_alloc ( 3 ) = ( / character ( len = 80 ) :: & OQP_td_bvec_mo , OQP_td_t , OQP_td_energies / ) character ( len =* ), parameter :: tags_required ( 9 ) = ( / character ( len = 80 ) :: & OQP_FOCK_A , OQP_DM_A , OQP_E_MO_A , OQP_VEC_MO_A , OQP_FOCK_B , OQP_DM_B , OQP_E_MO_B , OQP_VEC_MO_B , OQP_SM / ) ! Readings ! Files open ! 3. LOG: Write: Main output file open ( unit = iw , file = infos % log_filename , position = \"append\" ) umrsf = infos % tddft % umrsf dft = infos % control % hamilton == 20 ! dft or hf ! if ( umrsf ) then if ( dft ) then method_name = 'UMRSF-TDDFT' else method_name = 'UMRSF-TDHF' end if call print_module_info ( 'UMRSF_TDHF_Energy' , 'Computing Energy of ' // trim ( method_name )) else if ( dft ) then method_name = 'MRSF-TDDFT' else method_name = 'MRSF-TDHF' end if call print_module_info ( 'MRSF_TDHF_Energy' , 'Computing Energy of ' // trim ( method_name )) end if ! Load basis set basis => infos % basis basis % atoms => infos % atoms ! Get Fortran pointer ixcore_ptr from C pointer if (. not . ( infos % tddft % ixcore_len == 0 )) & call c_f_pointer ( infos % tddft % ixcore , ixcore_ptr , [ infos % tddft % ixcore_len ]) ! Input parameters mrst = infos % tddft % mult nstates = infos % tddft % nstate target_state = infos % tddft % target_state maxvec = infos % tddft % maxvec cnvtol = infos % tddft % cnvtol debug_mode = infos % tddft % debug_mode mol_mult = infos % mol_prop % mult if ( umrsf ) then if ( mol_mult /= 3 ) call show_message ( 'UMRSF requires a triplet UHF internal reference (mult=3).' , with_abort ) else if ( mol_mult /= 3 ) call show_message ( 'MRSF requires a triplet ROHF internal reference (mult=3).' , with_abort ) end if scf_type = infos % control % scftype if (. not . umrsf . and . scf_type == 3 ) roref = . true . if ( umrsf . and . scf_type /= 2 ) then call show_message ( 'UMRSF requires a UHF internal reference (SCFTYPE=2).' , with_abort ) else if ( umrsf ) then uhfref = . true . end if nbf = basis % nbf nbf2 = nbf * ( nbf + 1 ) / 2 s_size = ( basis % nshell ** 2 + basis % nshell ) / 2 tamm_dancoff = . true . ! tamm_dancoff: 0/1 means not doing/doing Tamm/Dancoff run nocca = infos % mol_prop % nelec_a nvira = nbf - nocca noccb = infos % mol_prop % nelec_b nvirb = nbf - noccb if ( mrst == 1 . or . mrst == 3 ) then xvec_dim = nocca * nvirb else if ( mrst == 5 ) then xvec_dim = noccb * nvira end if if ( mrst == 1 ) then nstates = min ( nstates , xvec_dim - 1 ) mxvec = min ( maxvec * nstates , xvec_dim - 1 , infos % control % maxit_dav * nstates ) else if ( mrst == 3 ) then nstates = min ( nstates , xvec_dim - 3 ) mxvec = min ( maxvec * nstates , xvec_dim - 3 , infos % control % maxit_dav * nstates ) else if ( mrst == 5 ) then nstates = min ( nstates , xvec_dim ) mxvec = min ( maxvec * nstates , xvec_dim , infos % control % maxit_dav * nstates ) end if infos % tddft % nstate = nstates nvec = min ( max ( nstates , 6 ), mxvec ) call infos % dat % alloc_or_die ( OQP_td_bvec_mo , ( / xvec_dim , nstates / ), bvec_mo_out , description = OQP_td_bvec_mo_comment ) call infos % dat % alloc_or_die ( OQP_td_t , ( / nbf2 , 2 / ), td_t , description = OQP_td_t_comment ) call infos % dat % alloc_or_die ( OQP_td_energies , ( / nstates / ), mrsf_energies , description = OQP_td_energies_comment ) call data_has_tags ( infos % dat , tags_required , module_name , subroutine_name , WITH_ABORT ) call tagarray_get_data ( infos % dat , OQP_SM , smat ) call tagarray_get_data ( infos % dat , OQP_FOCK_A , fock_a ) call tagarray_get_data ( infos % dat , OQP_FOCK_B , fock_b ) call tagarray_get_data ( infos % dat , OQP_DM_A , dmat_a ) call tagarray_get_data ( infos % dat , OQP_DM_B , dmat_b ) call tagarray_get_data ( infos % dat , OQP_E_MO_A , mo_energy_a ) call tagarray_get_data ( infos % dat , OQP_E_MO_B , mo_energy_b ) call tagarray_get_data ( infos % dat , OQP_VEC_MO_A , mo_a ) call tagarray_get_data ( infos % dat , OQP_VEC_MO_B , mo_b ) ! Allocate temporary matrices for diagonalization allocate ( fa ( nbf , nbf ), & fb ( nbf , nbf ), & stat = ok ) if ( ok /= 0 ) call show_message ( 'Cannot allocate memory' , with_abort ) ! Allocate TDDFT variables allocate ( xm ( xvec_dim ), & bvec_mo ( xvec_dim , mxvec ), & trden ( nbf , nbf , nstates , nstates ), & wrk1 ( nbf , nbf ), & wrk2 ( nbf , nbf ), & smat_full ( nbf , nbf ), & amo ( xvec_dim , mxvec ), & EEX ( mxvec ), & squared_S ( nstates ), & APB ( mxvec , mxvec ), & AMB ( mxvec , mxvec ), & VR ( mxvec * mxvec ), & VL ( mxvec * mxvec ), & for_trnsf_b_vec ( mxvec , mxvec ), & ! dip ( 3 , nstates , nstates ), & scr ( nbf2 ), & bvec_mo_tmp ( xvec_dim ), & scr2 ( mxvec * mxvec ), & scr3 ( nocca ), & qvec ( xvec_dim , nstates ), & RNORM ( nstates ), & source = 0.0_dp , stat = ok ) if ( ok /= 0 ) call show_message ( 'Cannot allocate memory' , with_abort ) allocate ( trans ( xvec_dim , 2 ), & source = 0 , stat = ok ) if ( ok /= 0 ) call show_message ( 'Cannot allocate memory' , with_abort ) mo_energy_work_a = mo_energy_a mo_energy_work_b = mo_energy_b ! MO rotations (Jacobi) if ( umrsf ) then call unpack_matrix ( smat , smat_full , nbf , 'U' ) call get_jacobi ( infos , mo_a , mo_energy_a , mo_b , mo_energy_b , smat_full , nocca , wrk1 , wrk2 , 0 ) call get_jacobi ( infos , mo_a , mo_energy_a , mo_b , mo_energy_b , smat_full , nocca , wrk1 , wrk2 , 1 ) end if ta => td_t (:, 1 ) tb => td_t (:, 2 ) if ( mrst == 1 . or . mrst == 3 ) then if ( umrsf ) then allocate ( mrsf_density ( nvec , 11 , nbf , nbf ), & source = 0.0_dp , & stat = ok ) else allocate ( mrsf_density ( nvec , 7 , nbf , nbf ), & source = 0.0_dp , & stat = ok ) end if else if ( mrst == 5 ) then allocate ( fmrq1 ( nbf , nbf , nvec ), & source = 0.0_dp , & stat = ok ) end if if ( ok /= 0 ) call show_message ( 'Cannot allocate memory' , with_abort ) scale_exch = 1.0_dp if ( infos % tddft % HFscale == - 1.0_dp ) & infos % tddft % HFscale = infos % dft % HFscale if ( infos % dft % cam_flag ) then if ( infos % tddft % cam_alpha == - 1.0_dp ) & infos % tddft % cam_alpha = infos % dft % cam_alpha infos % tddft % HFscale = infos % tddft % cam_alpha if ( infos % tddft % cam_beta == - 1.0_dp ) & infos % tddft % cam_beta = infos % dft % cam_beta if ( infos % tddft % cam_mu == - 1.0_dp ) & infos % tddft % cam_mu = infos % dft % cam_mu end if if ( dft ) scale_exch = infos % tddft % HFscale ! Pure HF reference (no DFT functional): the effective exact-exchange scale ! is 1.0. Without a DFT functional infos%dft%HFscale is left at the -1.0 ! sentinel, so the response HFscale (and hence the spin-pair coupling below) ! would inherit -1.0. The energy tolerates this (the fmrst2 rescale is ! skipped because spc == HFscale either way), but the MRSF gradient uses the ! spin-pair coupling values directly and needs the correct +1.0. if (. not . dft ) infos % tddft % HFscale = 1.0_dp ! set spin-pair coupling if ( infos % tddft % spc_coco ==- 1.0_dp ) & infos % tddft % spc_coco = infos % tddft % HFscale if ( infos % tddft % spc_ovov ==- 1.0_dp ) & infos % tddft % spc_ovov = infos % tddft % HFscale if ( infos % tddft % spc_coov ==- 1.0_dp ) & infos % tddft % spc_coov = infos % tddft % HFscale if ( debug_mode ) then write ( * , '(/,5x,\"Input parameters:\")' ) write ( * , '(5x,\"Number of states:                 \",1x,I0)' ) nstates write ( * , '(5x,\"Number of single excitations:     \",1x,I0)' ) xvec_dim write ( * , '(5x,\"Number of atomic orbitals:        \",1x,I0)' ) nbf write ( * , '(5x,\"Number of electrons:              \",1x,I0)' ) nocca + noccb write ( * , '(5x,\"Number of occupied alpha orbitals:\",1x,I0)' ) nocca write ( * , '(5x,\"Number of occupied beta orbitals: \",1x,I0)' ) noccb write ( * , '(5x,\"Number of virtual alpha orbitals: \",1x,I0)' ) nvira write ( * , '(5x,\"Number of virtual beta orbitals:  \",1x,I0)' ) nvirb write ( * , '(5x,\"Maximum vectors:                  \",1x,I0)' ) mxvec write ( * , '(5x,\"Initial vectors:                  \",1x,I0)' ) nvec if (. not . ( infos % tddft % ixcore_len == 0 )) & write ( * , '(5x,\"Ixcore (MO index):                \",1x,I0)' ) ixcore_ptr write ( * , '(/7x,\"Fitting parameters for \",A)' ) trim ( method_name ) if (. not . infos % dft % cam_flag ) then write ( * , '(10x,\"Exact HF exchange:\")' ) write ( * , '(5x,\"Reference: |\", t20, f6.3, t29, \"|\")' ) infos % dft % HFscale write ( * , '(5x,\"Response:  |\", t20, f6.3, t29, \"|\")' ) infos % tddft % HFscale else write ( * , '(10x,\"CAM parametres:\")' ) write ( * , '(16x,\"|   alpha   |    beta   |     mu    |\")' ) write ( * , '(5x,\"Reference: |\", t20, f6.3, t29, \"|\", t32, f6.3, t41, \"|\", t44, f6.3, t53, \"|\")' ) & infos % dft % cam_alpha , infos % dft % cam_beta , infos % dft % cam_mu write ( * , '(5x,\"Response:  |\", t20, f6.3, t29, \"|\", t32, f6.3, t41, \"|\", t44, f6.3, t53, \"|\")' ) & infos % tddft % cam_alpha , infos % tddft % cam_beta , infos % tddft % cam_mu end if write ( * , '(10x,\"Spin-pair coupling parametres:\")' ) write ( * , '(16x,\"|   CO-CO   |   OV-OV   |   CO-OV   |\")' ) write ( * , '(16x,\"|\", t20, f6.3, t29, \"|\", t32, f6.3, t41, \"|\", t44, f6.3, t53, \"|\")' ) & infos % tddft % spc_coco , infos % tddft % spc_ovov , infos % tddft % spc_coov end if write ( * , '(/,5x,46(\"=\"))' ) if ( mrst == 1 ) write ( * , '(  5X,\"Davidson algorithm for Singlet response states\")' ) if ( mrst == 3 ) write ( * , '(  5x,\"Davidson algorithm for Triplet response states\")' ) if ( mrst == 5 ) write ( * , '(  5x,\"Davidson algorithm for Quintet response states\")' ) write ( * , '(5x,46(\"=\"))' ) ! Loosen the 2e integral cutoff for the MRSF RESPONSE build only. The ! response is built on the converged orbitals, so it tolerates a far looser ! cutoff than the SCF default (5e-11). DEFAULT 1e-8 -- measured exact to the ! printed precision (<<1 ueV, far below the ~5e-5 regression tolerance and ! the iterative conv tolerance) -- removes integrals the response cannot ! resolve, cutting the integral COUNT (eval + digestion) for a modest free ! speedup that grows with system size. Override via env OQP_MRSF_RESP_CUTOFF ! (a.u.): set looser (e.g. 1e-7/1e-6) for more speed at ueV cost, or set to ! the SCF cutoff (5e-11) to recover the previous exact-tight behavior. ! max(SCF cutoff, requested) never goes tighter than the SCF integrals. ! Restored after the response so SCF / later steps are unaffected. ! Response 2e cutoff from [tdhf] resp_cutoff (infos%control%mrsf_resp_cutoff, ! default 1e-8). max(SCF cutoff, requested) never goes tighter than SCF. rc_save = infos % control % int2e_cutoff rc_new = infos % control % mrsf_resp_cutoff if ( rc_new <= 0.0_dp ) rc_new = 1.0e-8_dp infos % control % int2e_cutoff = max ( rc_save , rc_new ) ! FP32 response digestion from [tdhf] fp32 (infos%control%mrsf_fp32). Also ! reaches the z-vector gradient, which reuses the same process-global flag. call mrsf_set_fp32 ( int ( infos % control % mrsf_fp32 )) ! Initialize ERI (Electron Repulsion Integrals) calculations call int2_driver % init ( basis , infos ) call int2_driver % set_screening () call flush ( iw ) ! Prepare for ROHF if (( roref . and . . not . umrsf ) . or . ( uhfref . and . umrsf )) then !   Alpha call orthogonal_transform_sym ( nbf , nbf , fock_a , mo_a , nbf , scr ) ! shift Fock in MO basis here except MOs listed in ixcores if (. not . ( infos % tddft % ixcore_len == 0 )) then Do iter = 1 , noccb if (. not . any ( ixcore_ptr ( 1 : infos % tddft % ixcore_len ) == iter )) then diag_index = ( iter + 1 ) * iter / 2 scr ( diag_index ) = - 1.0d6 end if End Do end if call unpack_matrix ( scr , fa ) !   Beta call orthogonal_transform_sym ( nbf , nbf , fock_b , mo_b , nbf , scr ) call unpack_matrix ( scr , fb ) end if if ( umrsf ) then do i = 1 , nbf mo_energy_work_a ( i ) = fa ( i , i ) mo_energy_work_b ( i ) = fb ( i , i ) end do end if ! Construct TD trial vector if ( mrst == 1 . or . mrst == 3 ) then if (. not . umrsf ) then call mrinivec ( infos , mo_energy_work_a , mo_energy_work_a , bvec_mo , xm , nvec ) else call mrinivec ( infos , mo_energy_work_a , mo_energy_work_b , bvec_mo , xm , nvec ) end if else if ( mrst == 5 ) then call inivec ( mo_energy_a , mo_energy_a , bvec_mo , xm , noccb , nocca , nvec ) end if ist = 1 iend = nvec iter = 0 mxiter = infos % control % maxit_dav ierr = 0 do iter = 1 , mxiter nv = iend - ist + 1 if ( mrst == 1 . or . mrst == 3 ) then mrsf_density = 0.0_dp ! bo2v, bo1v, bco1, bco2, o21v, co12, ball else if ( mrst == 5 ) then fmrq1 = 0.0_dp end if do ivec = ist , iend iv = ivec - ist + 1 if ( mrst == 1 . or . mrst == 3 ) then call iatogen ( bvec_mo (:, ivec ), wrk1 , nocca , noccb ) if ( umrsf ) then call umrsfcbc ( infos , mo_a , mo_b , wrk1 , mrsf_density ( iv ,:,:,:)) else call mrsfcbc ( infos , mo_a , mo_b , wrk1 , mrsf_density ( iv ,:,:,:)) end if else if ( mrst == 5 ) then call iatogen ( bvec_mo (:, ivec ), wrk1 , noccb , nocca ) call orthogonal_transform ( 't' , nbf , mo_a , wrk1 , fmrq1 (:,:, iv ), wrk2 ) end if end do if ( mrst == 1 . or . mrst == 3 ) then if ( umrsf ) then int2_udata_st = int2_umrsf_data_t ( & d3 = mrsf_density (: iv ,:,:,:), & tamm_dancoff = tamm_dancoff , & scale_exchange = scale_exch , & scale_coulomb = scale_exch ) call int2_driver % run ( & int2_udata_st , & cam = dft . and . infos % dft % cam_flag , & alpha = infos % tddft % cam_alpha , & alpha_coulomb = infos % tddft % cam_alpha , & beta = infos % tddft % cam_beta , & beta_coulomb = infos % tddft % cam_beta , & mu = infos % tddft % cam_mu ) fmrst2 => int2_udata_st % f3 (:,:,:,:, 1 ) ! ado2v, ado1v, adco1, adco2, ao21v, aco12, agdlr else int2_data_st = int2_mrsf_data_t ( & d3 = mrsf_density (: iv ,:,:,:), & tamm_dancoff = tamm_dancoff , & scale_exchange = scale_exch , & scale_coulomb = scale_exch ) call int2_driver % run ( & int2_data_st , & cam = dft . and . infos % dft % cam_flag , & alpha = infos % tddft % cam_alpha , & alpha_coulomb = infos % tddft % cam_alpha , & beta = infos % tddft % cam_beta , & beta_coulomb = infos % tddft % cam_beta , & mu = infos % tddft % cam_mu ) fmrst2 => int2_data_st % f3 (:,:,:,:, 1 ) ! ado2v, ado1v, adco1, adco2, ao21v, aco12, agdlr endif ! Scaling factor if triplet if ( umrsf . and . mrst == 3 ) then fmrst2 (:, 1 : 10 ,:,:) = - fmrst2 (:, 1 : 10 ,:,:) else if ( mrst == 3 ) then fmrst2 (:, 1 : 6 ,:,:) = - fmrst2 (:, 1 : 6 ,:,:) endif ! Spin pair coupling if ( umrsf ) then if ( abs ( infos % tddft % hfscale ) > epsilon ( 1.0_dp )) then if ( infos % tddft % spc_coco /= infos % tddft % hfscale ) then spc_scale_coco = infos % tddft % spc_coco / infos % tddft % hfscale fmrst2 (:, 10 ,:,:) = fmrst2 (:, 10 ,:,:) * spc_scale_coco end if if ( infos % tddft % spc_ovov /= infos % tddft % hfscale ) then spc_scale_ovov = infos % tddft % spc_ovov / infos % tddft % hfscale fmrst2 (:, 9 ,:,:) = fmrst2 (:, 9 ,:,:) * spc_scale_ovov end if if ( infos % tddft % spc_coov /= infos % tddft % hfscale ) then spc_scale_coov = infos % tddft % spc_coov / infos % tddft % hfscale fmrst2 (:, 1 : 8 ,:,:) = fmrst2 (:, 1 : 8 ,:,:) * spc_scale_coov end if else if ( infos % tddft % spc_coco /= 0.0_dp . or . & infos % tddft % spc_ovov /= 0.0_dp . or . & infos % tddft % spc_coov /= 0.0_dp ) then call show_message ( 'UMRSF-TDDFT spin-pair coupling overrides require nonzero HFscale.' , with_abort ) end if else if ( infos % tddft % spc_coco /= infos % tddft % hfscale ) & fmrst2 (:, 6 ,:,:) = fmrst2 (:, 6 ,:,:) * infos % tddft % spc_coco / infos % tddft % hfscale if ( infos % tddft % spc_ovov /= infos % tddft % hfscale ) & fmrst2 (:, 5 ,:,:) = fmrst2 (:, 5 ,:,:) * infos % tddft % spc_ovov / infos % tddft % hfscale if ( infos % tddft % spc_coov /= infos % tddft % hfscale ) & fmrst2 (:, 1 : 4 ,:,:) = fmrst2 (:, 1 : 4 ,:,:) * infos % tddft % spc_coov / infos % tddft % hfscale endif else if ( mrst == 5 ) then int2_data_q = int2_td_data_t ( & d2 = fmrq1 (:,:,: iv ), & int_apb = . false ., & int_amb = . false ., & tamm_dancoff = tamm_dancoff , & scale_exchange = scale_exch ) call int2_driver % run ( & int2_data_q , & cam = dft . and . infos % dft % cam_flag , & alpha = infos % tddft % cam_alpha , & beta = infos % tddft % cam_beta ,& mu = infos % tddft % cam_mu ) end if do ivec = ist , iend iv = ivec - ist + 1 if ( mrst == 1 . or . mrst == 3 ) then ! Product (A-B)*X if ( umrsf ) then call umrsfmntoia ( infos , fmrst2 ( iv ,:,:,:), amo , mo_a , mo_b , ivec ) else call mrsfmntoia ( infos , fmrst2 ( iv ,:,:,:), amo , mo_a , mo_b , ivec ) end if call iatogen ( bvec_mo (:, ivec ), wrk1 , nocca , noccb ) call mrsfesum ( infos , wrk1 , fa , fb , amo , ivec ) else if ( mrst == 5 ) then call mntoia ( int2_data_q % amb (:,:, iv , 1 ), amo (:, ivec ), mo_a , mo_b , noccb , nocca ) ! Z(I+,A-) call iatogen ( bvec_mo (:, ivec ), wrk1 , noccb , nocca ) ! FB(I+,J+)*Z(J+,A-) call dgemm ( 'n' , 'n' , noccb , nbf , noccb , & 1.0_dp , fb , nbf , & wrk1 , nbf , & 0.0_dp , wrk2 , noccb ) ! Z(I+,B-)*FA(B-,A-) call dgemm ( 'n' , 'n' , noccb , nbf , nbf , & 1.0_dp , wrk1 , nbf , & fa , nbf , & - 1.0_dp , wrk2 , noccb ) call mrsfqroesum ( wrk2 , amo , & nocca , noccb , nbf , ivec ) end if end do vl_p ( 1 : nvec , 1 : nvec ) => vl ( 1 : nvec * nvec ) vr_p ( 1 : nvec , 1 : nvec ) => vr ( 1 : nvec * nvec ) call rparedms ( bvec_mo , amo , amo , apb , amb , nvec , tamm_dancoff = . true .) call rpaeig ( eex , vl_p , vr_p , apb , amb , scr2 , tamm_dancoff = . true .) call rpavnorm ( vr_p , vl_p , tamm_dancoff = . true .) call rpaechk ( eex , nvec , nstates , imax , tamm_dancoff = . true .) for_trnsf_b_vec = vr_p call sfresvec ( qvec , bvec_mo , amo , vr_p , eex , nvec , rnorm , nstates ) call sfqvec ( qvec , xm , eex , nstates ) !     Response-space symmetry blocking (no-op unless staged by pyoqp): !     confine each root's update to the dominant irrep of its Ritz vector. sym_ritz = matmul ( bvec_mo (:, 1 : nvec ), vr_p ( 1 : nvec , 1 : nstates )) call sym_response_project ( infos , sym_ritz , qvec , nstates ) call rpaprint ( eex , rnorm , cnvtol , iter , imax , nstates , do_neg = . true .) mxerr = maxval ( rnorm ) !     Check convergence converged = mxerr <= cnvtol if ( converged ) exit !     No space left for new vectors, exit if ( nvec == mxvec ) ierr = 1 if ( ierr /= 0 ) exit call rpanewb ( nstates , bvec_mo , qvec , novec , nvec , ierr , tamm_dancoff = . true .) !   ierr=1 nvec over mxvec: not converged case if ( ierr /= 0 ) exit ist = novec + 1 iend = nvec end do if ( iter >= mxiter . and . . not . converged ) ierr = - 1 select case ( ierr ) case ( - 1 ) write ( * , '(/,2X,\"MRSF-TD-DFT energies NOT CONVERGED after \",I4,\" iterations\"/)' ) mxiter infos % mol_energy % Davidson_converged = . false . case ( 0 ) write ( * , '(/,2X,\"MRSF-TD-DFT energies converged in \",I4,\" iterations\"/)' ) iter infos % mol_energy % Davidson_converged = . true . case ( 1 ) write ( * , '(/,2X,\"..something is wrong.. nvec = mxvec\")' ) infos % mol_energy % Davidson_converged = . false . case ( 2 ) write ( * , '(/,2x,\"..something is wrong..  nvec > mxvec\")' ) write ( * , '(3x,\"nvec/mxvec =\",I4,\"/\",I4)' ) nvec , mxvec infos % mol_energy % Davidson_converged = . false . case ( 3 ) write ( * , '(/,2x,\"..something is wrong.. No vectors were added\")' ) infos % mol_energy % Davidson_converged = . false . end select call flush ( iw ) call trfrmb ( bvec_mo , for_trnsf_b_vec , nvec , nstates ) select case ( mrst ) case ( 1 ) if ( umrsf ) then trden = 0.0_dp else do ist = 1 , nstates do jst = ist , nstates call get_mrsf_transition_density ( infos , trden (:,:, ist , jst ), bvec_mo , ist , jst ) end do end do end if if ( umrsf ) then do ist = 1 , nstates call umrsfssqu ( squared_S ( ist ), mo_a , mo_b , smat , wrk1 , scr3 , nbf , nbf2 , & xvec_dim , ist , nbf , bvec_mo , nocca , noccb , & . true ., . false .) end do else squared_S (:) = 0.0_dp end if call get_mrsf_transitions ( trans , nocca , noccb , nbf ) write ( * , '(/,2x,35(\"=\"),/,2x,& &\"Spin-adapted spin-flip excitations\",/,2x,35(\"=\"))' ) case ( 3 ) if ( umrsf ) then trden = 0.0_dp else do ist = 1 , nstates do jst = ist , nstates call get_mrsf_transition_density ( infos , trden (:,:, ist , jst ), bvec_mo , ist , jst ) end do end do end if if ( umrsf ) then do ist = 1 , nstates call umrsfssqu ( squared_S ( ist ), mo_a , mo_b , smat , wrk1 , scr3 , nbf , nbf2 , & xvec_dim , ist , nbf , bvec_mo , nocca , noccb , & . false ., . true .) end do else squared_S (:) = 2.0_dp end if call get_mrsf_transitions ( trans , nocca , noccb , nbf ) write ( * , '(/,2x,35(\"=\"),/,2x,& &\"Spin-adapted spin-flip excitations\",/,2x,35(\"=\"))' ) case ( 5 ) call get_transition_density ( trden , bvec_mo , nbf , noccb , nocca , nstates ) squared_S (:) = 6.0_dp call get_transitions ( trans , noccb , nocca , nbf ) write ( * , '(/,2x,35(\"=\"),/,2x,& &\"Beta -> Alpha spin-flip excitations\",/,2x,35(\"=\"))' ) case default error stop \"Unknown mrst value\" end select call get_transition_dipole ( basis , dip , mo_a , trden , nstates ) ! --- misc-excited-analysis: expose the MRSF state-interaction transition / !     state-difference densities (alpha-MO basis), the transition dipoles, !     and the AO electric-dipole integrals for downstream Python analysis. !     Pure write-out; no physics above is altered (ported to the alloc_or_die !     tagarray API of current main). !     Skipped for UMRSF: there trden is set identically to zero above, so no !     genuine state-interaction densities exist and exposing them would !     publish misleading all-zero tags. if (. not . umrsf ) then ! get_mrsf_transition_density / get_transition_dipole only populate the ! upper triangle (ist<=jst). Mirror it into the stored copies so reverse ! state pairs are correct: gamma&#94;{j->i} = (gamma&#94;{i->j})&#94;T and the (real) ! transition dipole mu&#94;{j->i} = mu&#94;{i->j}. The live `dip`/`trden` arrays ! handed to print_results are left untouched. do jst = 1 , nstates do ist = jst + 1 , nstates trden (:,:, ist , jst ) = transpose ( trden (:,:, jst , ist )) end do end do call infos % dat % alloc_or_die ( OQP_td_trans_density_mo , & ( / nbf , nbf , nstates * nstates / ), trden_store , & description = OQP_td_trans_density_mo_comment ) trden_store = reshape ( trden (:,:, 1 : nstates , 1 : nstates ), ( / nbf , nbf , nstates * nstates / )) call infos % dat % alloc_or_die ( OQP_td_trans_dipole , ( / 3 , nstates , nstates / ), & dip_store , description = OQP_td_trans_dipole_comment ) dip_store = dip (:, 1 : nstates , 1 : nstates ) do jst = 1 , nstates do ist = jst + 1 , nstates dip_store (:, ist , jst ) = dip_store (:, jst , ist ) end do end do allocate ( mints_exp ( nbf2 , 3 ), source = 0.0_dp ) com_exp = basis % atoms % center ( weight = 'mass' ) call multipole_integrals ( basis , mints_exp , com_exp , 1 ) call infos % dat % alloc_or_die ( OQP_td_dip_ao , ( / nbf2 , 3 / ), dipao_store , & description = OQP_td_dip_ao_comment ) dipao_store = mints_exp deallocate ( mints_exp ) end if mrsf_energies = eex ( 1 : nstates ) bvec_mo_out = bvec_mo (:, 1 : nstates ) infos % mol_energy % excited_energy = mrsf_energies ( infos % tddft % target_state ) call print_results ( infos , bvec_mo , eex , trans , dip , squared_S , nstates , & physical_mrsf_labels = . true .) call flush ( iw ) call int2_driver % clean () infos % control % int2e_cutoff = rc_save call measure_time ( print_total = 1 , log_unit = iw ) close ( iw ) end subroutine tdhf_mrsf_energy end module tdhf_mrsf_energy_mod","tags":"","url":"sourcefile/tdhf_mrsf_energy.f90.html"},{"title":"tdhf_mrsf_lib.F90 – OpenQP Fortran API","text":"Source Code module tdhf_mrsf_lib use precision , only : dp , sp use int2_compute , only : int2_fock_data_t , int2_storage_t use basis_tools , only : basis_set use oqp_linalg type , extends ( int2_fock_data_t ) :: int2_mrsf_data_t real ( kind = dp ), allocatable :: f3 (:,:,:,:,:) real ( kind = dp ), pointer :: d3 (:,:,:,:) => null () real ( kind = dp ), allocatable :: ds (:,:,:,:) !< symmetrized Coulomb density (comps 1:4), precomputed once real ( kind = sp ), allocatable :: ds_sp (:,:,:,:) !< FP32 copy of ds (opt-in OQP_MRSF_FP32) real ( kind = sp ), allocatable :: d3_sp (:,:,:,:) !< FP32 copy of d3 (opt-in OQP_MRSF_FP32) real ( kind = sp ), allocatable :: f3s (:,:,:,:,:) !< FP32 Fock accumulator (opt-in OQP_MRSF_FP32) logical :: tamm_dancoff = . true . !< Tamm-Dancoff approximation contains procedure :: parallel_start => int2_mrsf_data_t_parallel_start procedure :: parallel_stop => int2_mrsf_data_t_parallel_stop procedure :: init_screen => int2_mrsf_data_t_init_screen procedure :: update => int2_mrsf_data_t_update procedure :: clean => int2_mrsf_data_t_clean end type type , extends ( int2_mrsf_data_t ) :: int2_umrsf_data_t contains procedure :: update => int2_umrsf_data_t_update end type integer , save :: g_mrsf_fp32 = - 1 !< opt-in FP32 Fock accumulation (env OQP_MRSF_FP32) contains !> Read the OQP_MRSF_FP32 opt-in once. When set, the MRSF response Fock !> digestion accumulates in single precision (~+8% over the FP64 path on !> cc-pVDZ; excitation energies perturbed at the ~few-ueV level, Davidson !> convergence unchanged). Default off = exact FP64. subroutine ensure_mrsf_fp32 () ! g_mrsf_fp32 is set from [tdhf] fp32 via mrsf_set_fp32() before the response; ! default to off (0) if it was never set. if ( g_mrsf_fp32 < 0 ) g_mrsf_fp32 = 0 end subroutine !> Set the FP32 response-digestion flag from the control struct ([tdhf] fp32). subroutine mrsf_set_fp32 ( v ) integer , intent ( in ) :: v g_mrsf_fp32 = v end subroutine !############################################################################### subroutine int2_mrsf_data_t_parallel_start ( this , basis , nthreads ) implicit none class ( int2_mrsf_data_t ), target , intent ( inout ) :: this type ( basis_set ), intent ( in ) :: basis integer , intent ( in ) :: nthreads integer :: nbf , nsh , nmatrix , mu , nu nbf = basis % nbf this % fockdim = nbf * ( nbf + 1 ) / 2 this % nfocks = ubound ( this % d3 , 1 ) this % nthreads = nthreads nsh = basis % nshell nmatrix = ubound ( this % d3 , 2 ) ! 7 ! spin pair copuling A': bo2v, bo1v, bco1, bco2, o21v, co12; A: ball if ( this % cur_pass == 1 ) then if ( allocated ( this % f3 )) deallocate ( this % f3 ) if ( allocated ( this % dsh )) deallocate ( this % dsh ) allocate ( this % f3 ( this % nfocks , nmatrix , nbf , nbf , nthreads ), & this % dsh ( nsh , nsh ), & source = 0.0d0 ) ! Precompute the symmetrized Coulomb density ds(:,c,mu,nu)=d3(mu,nu)+d3(nu,mu) ! for the Coulomb components (1:4) once per run. d3 is constant over the ! Davidson sigma build, so this lets the digestion kernel read a single ! (symmetric) slab per integral instead of summing two scattered d3 reads. if ( allocated ( this % ds )) deallocate ( this % ds ) allocate ( this % ds ( this % nfocks , 4 , nbf , nbf )) do nu = 1 , nbf do mu = 1 , nbf this % ds (:,:, mu , nu ) = this % d3 (:, 1 : 4 , mu , nu ) + this % d3 (:, 1 : 4 , nu , mu ) end do end do ! Opt-in FP32 Fock accumulation (env OQP_MRSF_FP32): FP32 operand copies ! + an FP32 per-thread accumulator, folded back to FP64 in parallel_stop. ! Only for the base (non-UMRSF) MRSF type: UMRSF's d3 carries more matrix ! components and its own update routine does not use the FP32 accumulator, ! so FP32 is left inert (exact FP64) on the UMRSF path. call ensure_mrsf_fp32 () if ( g_mrsf_fp32 /= 0 ) then select type ( this ) type is ( int2_mrsf_data_t ) if ( allocated ( this % ds_sp )) deallocate ( this % ds_sp ) if ( allocated ( this % d3_sp )) deallocate ( this % d3_sp ) if ( allocated ( this % f3s )) deallocate ( this % f3s ) allocate ( this % ds_sp ( this % nfocks , 4 , nbf , nbf ), & this % d3_sp ( this % nfocks , nmatrix , nbf , nbf )) this % ds_sp = real ( this % ds , sp ) this % d3_sp = real ( this % d3 , sp ) allocate ( this % f3s ( this % nfocks , nmatrix , nbf , nbf , nthreads ), source = 0.0_sp ) end select end if end if call this % init_screen ( basis ) end subroutine !############################################################################### subroutine int2_mrsf_data_t_parallel_stop ( this ) implicit none integer :: f3last , t class ( int2_mrsf_data_t ), intent ( inout ) :: this if ( this % cur_pass /= this % num_passes ) return f3last = size ( shape ( this % f3 )) ! Reduce the FP64 accumulator across threads first. This holds the pass-2 ! (CAM short-range exchange) contributions, and is zero in the FP32 ! pass-1-only case -- so the subsequent add is exact in both cases. if ( this % nthreads /= 1 ) then this % f3 (:,:,:,:, 1 ) = sum ( this % f3 , dim = f3last ) end if ! Then add the FP32 per-thread accumulator (folded to FP64) when present. if ( allocated ( this % f3s )) then do t = 1 , this % nthreads this % f3 (:,:,:,:, 1 ) = this % f3 (:,:,:,:, 1 ) + real ( this % f3s (:,:,:,:, t ), dp ) end do end if call this % pe % allreduce ( this % f3 (:,:,:,:, 1 ), & size ( this % f3 (:,:,:,:, 1 ))) this % nthreads = 1 end subroutine !############################################################################### subroutine int2_mrsf_data_t_clean ( this ) implicit none class ( int2_mrsf_data_t ), intent ( inout ) :: this deallocate ( this % f3 ) deallocate ( this % dsh ) if ( allocated ( this % ds )) deallocate ( this % ds ) if ( allocated ( this % ds_sp )) deallocate ( this % ds_sp ) if ( allocated ( this % d3_sp )) deallocate ( this % d3_sp ) if ( allocated ( this % f3s )) deallocate ( this % f3s ) nullify ( this % d3 ) end subroutine !############################################################################### subroutine int2_mrsf_data_t_init_screen ( this , basis ) implicit none class ( int2_mrsf_data_t ), target , intent ( inout ) :: this type ( basis_set ), intent ( in ) :: basis integer :: sized sized = ubound ( this % d3 , 2 ) !   Form shell density call shell_den_screen_mrsf ( this % dsh , this % d3 (:, sized ,:,:), basis ) this % max_den = maxval ( abs ( this % dsh )) end subroutine !############################################################################### subroutine shell_den_screen_mrsf ( dsh , da , basis ) use types , only : information use basis_tools , only : basis_set implicit none type ( basis_set ), intent ( in ) :: basis real ( kind = dp ), intent ( out ) :: dsh (:,:) real ( kind = dp ), intent ( in ), dimension (:,:,:) :: da integer :: ish , jsh , maxi , maxj , mini , minj ! RHF do ish = 1 , basis % nshell mini = basis % ao_offset ( ish ) maxi = mini + basis % naos ( ish ) - 1 do jsh = 1 , ish minj = basis % ao_offset ( jsh ) maxj = minj + basis % naos ( jsh ) - 1 dsh ( ish , jsh ) = maxval ( abs ( da (:, minj : maxj , mini : maxi ))) dsh ( jsh , ish ) = dsh ( ish , jsh ) end do end do end subroutine shell_den_screen_mrsf !############################################################################### subroutine int2_mrsf_data_t_update ( this , buf ) implicit none class ( int2_mrsf_data_t ), intent ( inout ) :: this type ( int2_storage_t ), intent ( inout ) :: buf integer :: i , j , k , l , n , v , c real ( kind = dp ) :: val , xval , cval integer :: mythread mythread = buf % thread_id if (. not . this % tamm_dancoff ) return associate ( f3 => this % f3 (:,:,:,:, mythread ), & d3 => this % d3 , & ds => this % ds , & nf => this % nfocks & ) ! f3(nF,1:7,:,:) !> 1=ado2v, 2=ado1v, 3=adco1, 4=adco2, 5=ao21v, 6=aco12, 7=agdlr ! d3(nF,1:7,:,:) !> 1= bo2v, 2= bo1v, 3= bco1, 4= bco2, 5= o21v, 6= co12, 7= ball ! ds(nF,1:4,:,:) !> symmetrized Coulomb density (d3+d3&#94;T), precomputed once if ( this % cur_pass == 1 . and . allocated ( this % f3s )) then ! Opt-in FP32 accumulation (OQP_MRSF_FP32): same algebra as the FP64 ! path below but operands/accumulator are single precision. Folded back ! to FP64 in parallel_stop. ~few-ueV perturbation, convergence unchanged. block real ( kind = sp ) :: cs , xs associate ( f3s => this % f3s (:,:,:,:, mythread ), & ds_sp => this % ds_sp , d3_sp => this % d3_sp ) do n = 1 , buf % ncur i = buf % ids ( 1 , n ); j = buf % ids ( 2 , n ); k = buf % ids ( 3 , n ); l = buf % ids ( 4 , n ) val = buf % ints ( n ) cs = real ( val * this % scale_coulomb , sp ) xs = real ( val * this % scale_exchange , sp ) do c = 1 , 4 do v = 1 , nf f3s ( v , c , i , j ) = f3s ( v , c , i , j ) + cs * ds_sp ( v , c , k , l ) f3s ( v , c , j , i ) = f3s ( v , c , j , i ) + cs * ds_sp ( v , c , k , l ) f3s ( v , c , k , l ) = f3s ( v , c , k , l ) + cs * ds_sp ( v , c , i , j ) f3s ( v , c , l , k ) = f3s ( v , c , l , k ) + cs * ds_sp ( v , c , i , j ) end do end do do c = 1 , 7 do v = 1 , nf f3s ( v , c , i , k ) = f3s ( v , c , i , k ) - xs * d3_sp ( v , c , j , l ) f3s ( v , c , k , i ) = f3s ( v , c , k , i ) - xs * d3_sp ( v , c , l , j ) f3s ( v , c , i , l ) = f3s ( v , c , i , l ) - xs * d3_sp ( v , c , j , k ) f3s ( v , c , l , i ) = f3s ( v , c , l , i ) - xs * d3_sp ( v , c , k , j ) f3s ( v , c , j , k ) = f3s ( v , c , j , k ) - xs * d3_sp ( v , c , i , l ) f3s ( v , c , k , j ) = f3s ( v , c , k , j ) - xs * d3_sp ( v , c , l , i ) f3s ( v , c , j , l ) = f3s ( v , c , j , l ) - xs * d3_sp ( v , c , i , k ) f3s ( v , c , l , j ) = f3s ( v , c , l , j ) - xs * d3_sp ( v , c , k , i ) end do end do end do end associate end block else if ( this % cur_pass == 1 ) then do n = 1 , buf % ncur i = buf % ids ( 1 , n ); j = buf % ids ( 2 , n ); k = buf % ids ( 3 , n ); l = buf % ids ( 4 , n ) val = buf % ints ( n ) xval = val * this % scale_exchange cval = val * this % scale_coulomb ! Coulomb (components 1:4): the 8 permutational contributions collapse ! to 4 distinct Fock targets, each reading one symmetric ds slab. ! Explicit loops (stride-1 v inner) vectorize and avoid array temporaries. do c = 1 , 4 do v = 1 , nf f3 ( v , c , i , j ) = f3 ( v , c , i , j ) + cval * ds ( v , c , k , l ) f3 ( v , c , j , i ) = f3 ( v , c , j , i ) + cval * ds ( v , c , k , l ) f3 ( v , c , k , l ) = f3 ( v , c , k , l ) + cval * ds ( v , c , i , j ) f3 ( v , c , l , k ) = f3 ( v , c , l , k ) + cval * ds ( v , c , i , j ) end do end do ! Exchange (components 1:7): 8 distinct targets (no symmetry to fold). do c = 1 , 7 do v = 1 , nf f3 ( v , c , i , k ) = f3 ( v , c , i , k ) - xval * d3 ( v , c , j , l ) f3 ( v , c , k , i ) = f3 ( v , c , k , i ) - xval * d3 ( v , c , l , j ) f3 ( v , c , i , l ) = f3 ( v , c , i , l ) - xval * d3 ( v , c , j , k ) f3 ( v , c , l , i ) = f3 ( v , c , l , i ) - xval * d3 ( v , c , k , j ) f3 ( v , c , j , k ) = f3 ( v , c , j , k ) - xval * d3 ( v , c , i , l ) f3 ( v , c , k , j ) = f3 ( v , c , k , j ) - xval * d3 ( v , c , l , i ) f3 ( v , c , j , l ) = f3 ( v , c , j , l ) - xval * d3 ( v , c , i , k ) f3 ( v , c , l , j ) = f3 ( v , c , l , j ) - xval * d3 ( v , c , k , i ) end do end do end do else if ( this % cur_pass == 2 ) then do n = 1 , buf % ncur i = buf % ids ( 1 , n ); j = buf % ids ( 2 , n ); k = buf % ids ( 3 , n ); l = buf % ids ( 4 , n ) xval = buf % ints ( n ) * this % scale_exchange do v = 1 , nf f3 ( v , 7 , i , k ) = f3 ( v , 7 , i , k ) - xval * d3 ( v , 7 , j , l ) f3 ( v , 7 , k , i ) = f3 ( v , 7 , k , i ) - xval * d3 ( v , 7 , l , j ) f3 ( v , 7 , i , l ) = f3 ( v , 7 , i , l ) - xval * d3 ( v , 7 , j , k ) f3 ( v , 7 , l , i ) = f3 ( v , 7 , l , i ) - xval * d3 ( v , 7 , k , j ) f3 ( v , 7 , j , k ) = f3 ( v , 7 , j , k ) - xval * d3 ( v , 7 , i , l ) f3 ( v , 7 , k , j ) = f3 ( v , 7 , k , j ) - xval * d3 ( v , 7 , l , i ) f3 ( v , 7 , j , l ) = f3 ( v , 7 , j , l ) - xval * d3 ( v , 7 , i , k ) f3 ( v , 7 , l , j ) = f3 ( v , 7 , l , j ) - xval * d3 ( v , 7 , k , i ) end do end do end if end associate buf % ncur = 0 end subroutine !############################################################################### subroutine int2_umrsf_data_t_update ( this , buf ) implicit none class ( int2_umrsf_data_t ), intent ( inout ) :: this type ( int2_storage_t ), intent ( inout ) :: buf integer :: i , j , k , l , n real ( kind = dp ) :: val , xval , cval integer :: mythread mythread = buf % thread_id if (. not . this % tamm_dancoff ) return associate ( f3 => this % f3 (:,:,:,:, mythread ), & d3 => this % d3 , & nf => this % nfocks & ) do n = 1 , buf % ncur i = buf % ids ( 1 , n ) j = buf % ids ( 2 , n ) k = buf % ids ( 3 , n ) l = buf % ids ( 4 , n ) val = buf % ints ( n ) xval = val * this % scale_exchange cval = val * this % scale_coulomb if ( this % cur_pass == 1 ) then ! Coulomb-like updates (MRSF columns :4 -> :8, alpha/beta pairs) f3 (: nf , 1 : 8 , i , j ) = f3 (: nf , 1 : 8 , i , j ) + cval * d3 (: nf , 1 : 8 , k , l ) ! (ij|lk) f3 (: nf , 1 : 8 , k , l ) = f3 (: nf , 1 : 8 , k , l ) + cval * d3 (: nf , 1 : 8 , i , j ) ! (kl|ji) f3 (: nf , 1 : 8 , i , j ) = f3 (: nf , 1 : 8 , i , j ) + cval * d3 (: nf , 1 : 8 , l , k ) ! (ij|kl) f3 (: nf , 1 : 8 , l , k ) = f3 (: nf , 1 : 8 , l , k ) + cval * d3 (: nf , 1 : 8 , i , j ) ! (lk|ji) f3 (: nf , 1 : 8 , j , i ) = f3 (: nf , 1 : 8 , j , i ) + cval * d3 (: nf , 1 : 8 , k , l ) ! (ji|lk) f3 (: nf , 1 : 8 , k , l ) = f3 (: nf , 1 : 8 , k , l ) + cval * d3 (: nf , 1 : 8 , j , i ) ! (kl|ij) f3 (: nf , 1 : 8 , j , i ) = f3 (: nf , 1 : 8 , j , i ) + cval * d3 (: nf , 1 : 8 , l , k ) ! (ji|kl) f3 (: nf , 1 : 8 , l , k ) = f3 (: nf , 1 : 8 , l , k ) + cval * d3 (: nf , 1 : 8 , j , i ) ! (lk|ij) ! Exchange-like updates (MRSF columns :7 -> :11, incl. alpha/beta) f3 (: nf , 1 : 8 , i , k ) = f3 (: nf , 1 : 8 , i , k ) - xval * d3 (: nf , 1 : 8 , j , l ) ! (ij|lk) f3 (: nf , 1 : 8 , k , i ) = f3 (: nf , 1 : 8 , k , i ) - xval * d3 (: nf , 1 : 8 , l , j ) ! (kl|ji) f3 (: nf , 1 : 8 , i , l ) = f3 (: nf , 1 : 8 , i , l ) - xval * d3 (: nf , 1 : 8 , j , k ) ! (ij|kl) f3 (: nf , 1 : 8 , l , i ) = f3 (: nf , 1 : 8 , l , i ) - xval * d3 (: nf , 1 : 8 , k , j ) ! (lk|ji) f3 (: nf , 1 : 8 , j , k ) = f3 (: nf , 1 : 8 , j , k ) - xval * d3 (: nf , 1 : 8 , i , l ) ! (ji|lk) f3 (: nf , 1 : 8 , k , j ) = f3 (: nf , 1 : 8 , k , j ) - xval * d3 (: nf , 1 : 8 , l , i ) ! (kl|ij) f3 (: nf , 1 : 8 , j , l ) = f3 (: nf , 1 : 8 , j , l ) - xval * d3 (: nf , 1 : 8 , i , k ) ! (ji|kl) f3 (: nf , 1 : 8 , l , j ) = f3 (: nf , 1 : 8 , l , j ) - xval * d3 (: nf , 1 : 8 , k , i ) ! (lk|ij) ! Mixed alpha/beta spin-pair channels use the same exchange ! permutation pattern as MRSF channels 5:6, with only the column ! range renumbered.  This preserves the ROHF/MRSF reduction limit. f3 (: nf , 9 : 10 , i , k ) = f3 (: nf , 9 : 10 , i , k ) - xval * d3 (: nf , 9 : 10 , j , l ) ! (ij|lk) f3 (: nf , 9 : 10 , k , i ) = f3 (: nf , 9 : 10 , k , i ) - xval * d3 (: nf , 9 : 10 , l , j ) ! (kl|ji) f3 (: nf , 9 : 10 , i , l ) = f3 (: nf , 9 : 10 , i , l ) - xval * d3 (: nf , 9 : 10 , j , k ) ! (ij|kl) f3 (: nf , 9 : 10 , l , i ) = f3 (: nf , 9 : 10 , l , i ) - xval * d3 (: nf , 9 : 10 , k , j ) ! (lk|ji) f3 (: nf , 9 : 10 , j , k ) = f3 (: nf , 9 : 10 , j , k ) - xval * d3 (: nf , 9 : 10 , i , l ) ! (ji|lk) f3 (: nf , 9 : 10 , k , j ) = f3 (: nf , 9 : 10 , k , j ) - xval * d3 (: nf , 9 : 10 , l , i ) ! (kl|ij) f3 (: nf , 9 : 10 , j , l ) = f3 (: nf , 9 : 10 , j , l ) - xval * d3 (: nf , 9 : 10 , i , k ) ! (ji|kl) f3 (: nf , 9 : 10 , l , j ) = f3 (: nf , 9 : 10 , l , j ) - xval * d3 (: nf , 9 : 10 , k , i ) ! (lk|ij) ! General component agdlr is column 11 (spin-independent) f3 ( 1 : nf , 11 , i , k ) = f3 ( 1 : nf , 11 , i , k ) - xval * d3 ( 1 : nf , 11 , j , l ) f3 ( 1 : nf , 11 , k , i ) = f3 ( 1 : nf , 11 , k , i ) - xval * d3 ( 1 : nf , 11 , l , j ) f3 ( 1 : nf , 11 , i , l ) = f3 ( 1 : nf , 11 , i , l ) - xval * d3 ( 1 : nf , 11 , j , k ) f3 ( 1 : nf , 11 , l , i ) = f3 ( 1 : nf , 11 , l , i ) - xval * d3 ( 1 : nf , 11 , k , j ) f3 ( 1 : nf , 11 , j , k ) = f3 ( 1 : nf , 11 , j , k ) - xval * d3 ( 1 : nf , 11 , i , l ) f3 ( 1 : nf , 11 , k , j ) = f3 ( 1 : nf , 11 , k , j ) - xval * d3 ( 1 : nf , 11 , l , i ) f3 ( 1 : nf , 11 , j , l ) = f3 ( 1 : nf , 11 , j , l ) - xval * d3 ( 1 : nf , 11 , i , k ) f3 ( 1 : nf , 11 , l , j ) = f3 ( 1 : nf , 11 , l , j ) - xval * d3 ( 1 : nf , 11 , k , i ) else if ( this % cur_pass == 2 ) then ! In pass 2 only the general component agdlr (column 11) is updated, ! as in the MRSF version (column 7 there). f3 ( 1 : nf , 11 , i , k ) = f3 ( 1 : nf , 11 , i , k ) - xval * d3 ( 1 : nf , 11 , j , l ) f3 ( 1 : nf , 11 , k , i ) = f3 ( 1 : nf , 11 , k , i ) - xval * d3 ( 1 : nf , 11 , l , j ) f3 ( 1 : nf , 11 , i , l ) = f3 ( 1 : nf , 11 , i , l ) - xval * d3 ( 1 : nf , 11 , j , k ) f3 ( 1 : nf , 11 , l , i ) = f3 ( 1 : nf , 11 , l , i ) - xval * d3 ( 1 : nf , 11 , k , j ) f3 ( 1 : nf , 11 , j , k ) = f3 ( 1 : nf , 11 , j , k ) - xval * d3 ( 1 : nf , 11 , i , l ) f3 ( 1 : nf , 11 , k , j ) = f3 ( 1 : nf , 11 , k , j ) - xval * d3 ( 1 : nf , 11 , l , i ) f3 ( 1 : nf , 11 , j , l ) = f3 ( 1 : nf , 11 , j , l ) - xval * d3 ( 1 : nf , 11 , i , k ) f3 ( 1 : nf , 11 , l , j ) = f3 ( 1 : nf , 11 , l , j ) - xval * d3 ( 1 : nf , 11 , k , i ) end if end do end associate buf % ncur = 0 end subroutine int2_umrsf_data_t_update !############################################################################### !############################################################################### subroutine mrinivec ( infos , ea , eb , bvec_mo , xm , nvec ) use precision , only : dp use io_constants , only : iw use types , only : information implicit none type ( information ), intent ( in ) :: infos real ( kind = dp ), intent ( in ), dimension (:) :: ea , eb real ( kind = dp ), intent ( out ), dimension (:,:) :: bvec_mo real ( kind = dp ), intent ( out ), dimension (:) :: xm integer , intent ( in ) :: nvec logical :: debug_mode real ( kind = dp ) :: xmj integer :: nocca , nbf , i , ij , j , k , xvec_dim , lr1 , lr2 , mrst integer :: itmp ( nvec ) real ( kind = dp ) :: xtmp ( nvec ) debug_mode = infos % tddft % debug_mode nbf = infos % basis % nbf nocca = infos % mol_prop % nelec_A xvec_dim = ubound ( xm , 1 ) lr1 = nocca - 1 lr2 = nocca ! For Singlet or Triplet mrst = infos % tddft % mult ! Set xm(xvec_dim) ij = 0 do j = lr1 , nbf do i = 1 , lr2 if ( i == lr1 . and . j == lr1 ) then ij = ij + 1 xm ( ij ) = ( eb ( lr1 ) - ea ( lr1 ) + eb ( lr2 ) - ea ( lr2 )) * 0.5_dp cycle end if ij = ij + 1 xm ( ij ) = eb ( j ) - ea ( i ) if ( i == nocca . and . j == nocca ) then xm ( ij ) = huge ( 1.0d0 ) else if ( mrst == 3 . and . i == nocca . and . j == nocca - 1 ) then xm ( ij ) = huge ( 1.0d0 ) else if ( mrst == 3 . and . i == nocca - 1 . and . j == nocca ) then xm ( ij ) = huge ( 1.0d0 ) end if end do end do ! Find indices of the first `nvec` smallest ! Values in the `xm` array itmp = 0 ! indices xtmp = huge ( 1.0d0 ) ! values do i = 1 , xvec_dim do j = 1 , nvec if ( xtmp ( j ) > xm ( i )) exit end do if ( j <= nvec ) then ! new small value found, ! insert it into temporary arrays xtmp ( j + 1 : nvec ) = xtmp ( j : nvec - 1 ) itmp ( j + 1 : nvec ) = itmp ( j : nvec - 1 ) xtmp ( j ) = xm ( i ) itmp ( j ) = i end if end do ! Ordering xm(xvec_dim): xm(small) <= xm(large) ! Get smaller diagonal values do j = 1 , xvec_dim - 1 do i = j + 1 , xvec_dim if ( xm ( j ) <= xm ( i )) cycle xmj = xm ( j ) xm ( j ) = xm ( i ) xm ( i ) = xmj end do end do if ( debug_mode ) then write ( iw , '(\"print xm(xvec_dim) ordering\")' ) do i = 1 , xvec_dim write ( iw , '(a,i5,f20.10,i5)' ) 'i,xm(ij)=' , i , xm ( i ) end do end if ! Get initial vectors: bvec(xvec_dim, nvec) bvec_mo = 0.0_dp do k = 1 , nvec bvec_mo ( itmp ( k ), k ) = 1.0_dp end do ! set xm(xvec_dim) again ij = 0 do j = lr1 , nbf do i = 1 , lr2 if ( i == lr1 . and . j == lr1 ) then ij = ij + 1 xm ( ij ) = ( eb ( lr1 ) - ea ( lr1 ) + eb ( lr2 ) - ea ( lr2 )) * 0.5_dp cycle endif ij = ij + 1 xm ( ij ) = eb ( j ) - ea ( i ) if ( i == nocca . and . j == nocca ) then xm ( ij ) = 9 d99 else if ( mrst == 3 . and . i == nocca . and . j == nocca - 1 ) then xm ( ij ) = 9 d99 else if ( mrst == 3 . and . i == nocca - 1 . and . j == nocca ) then xm ( ij ) = 9 d99 end if end do end do if ( debug_mode ) then write ( iw , '(\"print xm(xvec_dim) ordering\")' ) do i = 1 , xvec_dim write ( iw , '(a,i5,f20.10,i5)' ) 'i,xm(ij)=' , i , xm ( i ) end do end if return end subroutine mrinivec !> Transform MRSF response vectors from MO to AO basis !> !> This subroutine performs the transformation of MRSF-TDDFT response amplitudes !> X&#94;(k), where k is singlet or triplet, from molecular orbital (MO) representation !> to atomic orbital (AO) basis. The AO-basis response matrices are needed !> for contraction with two-electron integrals and Fock matrix contributions !> in the response equations. !> !> Physical context: !> In MRSF-TDDFT, the response space is constructed from MS=+/-1 triplet references !> to eliminate spin contamination in target singlet and triplet excited states. !> !> Orbital spaces in MRSF-TDDFT: !> - C (Closed): Doubly-occupied orbitals (indices i,j,k,l) !> - O (Open): Singly-occupied orbitals O1=HOMO-1, O2=HOMO (indices u,v,w,z) !> - V (Virtual): Unoccupied orbitals (indices a,b,c,d) !> !> For each reference state k, the response amplitudes X&#94;(k)_pq represent orbital !> excitations between different orbital spaces. The response configurations are: !> - Type I (OO): Open-to-Open transitions (O1<->O2) !> - Type II (CO): Closed-to-Open transitions (C->O1, C->O2) !> - Type III (OV): Open-to-Virtual transitions (O1->V, O2->V) !> - Type IV (CV): Closed-to-Virtual transitions (C->V) !> !> The six response components in this subroutine correspond to: !> 1. bo2v: O2(HOMO, alpha) -> V(beta) - OV block !> 2. bo1v: O1(HOMO-1, alpha) -> V(beta) - OV block !> 3. bco1: C(alpha) -> O1(HOMO-1, beta) - CO block !> 4. bco2: C(alpha) -> O2(HOMO, beta) - CO block !> 5. o21v: Mixed OV component coupling O1 and O2 with V !> 6. co12: Mixed CO component coupling C with O1 and O2 !> !> Transformation scheme: !> For each component, we transform X&#94;(k)_pq (MO basis) to P&#94;(k)_(mu,nu) (AO basis): !>   P&#94;(k)_(mu,nu) = sum_pq C_(mu,p) X&#94;(k)_pq C_(nu,q) !> where C are MO coefficient matrices (va for alpha-spin, vb for beta-spin). !> !> Spin-pairing coupling between MS=+1 and MS=-1 reference states is realized !> through specific linear combinations of MO coefficients va and vb (with proper !> signs and 1/sqrt(2) normalization), following Slater-Condon rules. This enables !> proper description of singlet and triplet target states from the mixed-reference formalism. !> !> Reference: Lee et al., J. Chem. Phys. 150, 184111 (2019), Eq. 2.11-2.18 !> !> \\author  Konstantin Komarov (constlike@gmail.com) !> subroutine mrsfcbc ( infos , va , vb , bvec , fmrsf ) use messages , only : show_message , with_abort use types , only : information use io_constants , only : iw use precision , only : dp implicit none type ( information ), intent ( in ) :: infos real ( kind = dp ), intent ( in ), dimension (:,:) :: & va , vb , bvec real ( kind = dp ), intent ( inout ), target , dimension (:,:,:) :: & fmrsf real ( kind = dp ), allocatable , dimension (:,:) :: & tmp real ( kind = dp ), pointer , dimension (:,:) :: & bo2v , bo1v , bco1 , bco2 , ball , co12 , o21v integer :: nocca , noccb , mrst , i , j , m , nbf , lr1 , lr2 , ok logical :: debug_mode real ( kind = dp ), parameter :: isqrt2 = 1.0_dp / sqrt ( 2.0_dp ) ball => fmrsf ( 7 ,:,:) bo2v => fmrsf ( 1 ,:,:) bo1v => fmrsf ( 2 ,:,:) bco1 => fmrsf ( 3 ,:,:) bco2 => fmrsf ( 4 ,:,:) o21v => fmrsf ( 5 ,:,:) co12 => fmrsf ( 6 ,:,:) nbf = infos % basis % nbf nocca = infos % mol_prop % nelec_A noccb = infos % mol_prop % nelec_B mrst = infos % tddft % mult debug_mode = infos % tddft % debug_mode lr1 = nocca - 1 lr2 = nocca allocate ( tmp ( nbf , max ( 1 , noccb )), source = 0.0_dp , stat = ok ) if ( ok /= 0 ) call show_message ( 'Cannot allocate memory' , with_abort ) !----------------------------------------------------------------------- ! Component 1: bo2v - O2(HOMO, alpha) -> V(beta) excitations (OV block) !----------------------------------------------------------------------- ! Physical meaning: This component represents Open-to-Virtual (OV) excitations ! from the HOMO orbital of alpha-spin (O2, lr2 = nocca) to virtual orbitals ! of beta-spin. In MRSF theory, this corresponds to Type III response ! configurations. ! ! MO->AO transformation: P&#94;bo2v_(mu,nu) = C&#94;alpha_(mu,HOMO) * X_(HOMO,a) * C&#94;beta_(nu,a) ! where a runs over virtual beta-orbitals (nocca+1:nbf) ! ! Step 1: Intermediate vector tmp = sum_a C&#94;beta_(mu,a) X_(HOMO,a) !   tmp_mu = sum_{a in virt_beta} C&#94;beta_(mu,a) * X_(HOMO,a) call dgemm ( 'n' , 't' , nbf , 1 , nbf - nocca , & 1.0_dp , vb (:, nocca + 1 ), nbf , & bvec ( lr2 : lr2 , nocca + 1 ), nbf , & 0.0_dp , tmp (:, 1 ), nbf ) ! Step 2: Outer product to form AO-basis matrix !   P&#94;bo2v_(mu,nu) += C&#94;alpha_(mu,HOMO) * tmp_nu call dgemm ( 'n' , 't' , nbf , nbf , 1 , & 1.0_dp , va (:, lr2 : lr2 ), nbf , & tmp (:, 1 : 1 ), nbf , & 1.0_dp , bo2v , nbf ) !----------------------------------------------------------------------- ! Component 2: bo1v - O1(HOMO-1, alpha) -> V(beta) excitations (OV block) !----------------------------------------------------------------------- ! Physical meaning: This component represents Open-to-Virtual (OV) excitations ! from HOMO-1 orbital of alpha-spin (O1, lr1 = nocca-1) to virtual orbitals ! of beta-spin. Together with bo2v, this forms the complete set of Type III ! spin-flip excitations from the two singly-occupied MOs (O1 and O2) in the ! MS=+/-1 triplet reference. ! ! MO->AO transformation: P&#94;bo1v_(mu,nu) = C&#94;alpha_(mu,HOMO-1) * X_(HOMO-1,a) * C&#94;beta_(nu,a) ! ! Step 1: Intermediate vector tmp = sum_a C&#94;beta_(mu,a) X_(HOMO-1,a) !   tmp_mu = sum_{a in virt_beta} C&#94;beta_(mu,a) * X_(HOMO-1,a) call dgemm ( 'n' , 't' , nbf , 1 , nbf - nocca , & 1.0_dp , vb (:, nocca + 1 ), nbf , & bvec ( lr1 : lr1 , nocca + 1 ), nbf , & 0.0_dp , tmp (:, 1 ), nbf ) ! Step 2: Outer product to form AO-basis matrix !   P&#94;bo1v_(mu,nu) += C&#94;alpha_(mu,HOMO-1) * tmp_nu call dgemm ( 'n' , 't' , nbf , nbf , 1 , & 1.0_dp , va (:, lr1 : lr1 ), nbf , & tmp (:, 1 : 1 ), nbf , & 1.0_dp , bo1v , nbf ) !----------------------------------------------------------------------- ! Component 3: bco1 - C(alpha) -> O1(HOMO-1, beta) excitations (CO block) !----------------------------------------------------------------------- ! Physical meaning: This component represents Closed-to-Open (CO) excitations ! from doubly-occupied alpha-orbitals (C, 1:noccb) to the HOMO-1 orbital of ! beta-spin (O1, lr1). In MRSF theory, this corresponds to Type II response ! configurations. These are spin-flip de-excitations that complement the ! bo1v/bo2v excitations, maintaining the symmetry of the response space. ! ! MO->AO transformation: P&#94;bco1_(mu,nu) = C&#94;alpha_(mu,i) * X_(i,HOMO-1) * C&#94;beta_(nu,HOMO-1) ! where i runs over doubly-occupied orbitals (1:noccb) ! ! Block C->O/C->V when there is no doubly-occupied core (noccb=0, e.g. H2 ! triplet): these Closed-origin excitation classes are empty and contribute ! nothing. bco1/bco2/co12 and the CV update of ball stay at their zeroed value ! (mrsf_density=0 before the vector loop), so the spin-flip response is correct. if ( noccb > 0 ) then ! Step 1: Intermediate vector tmp = sum_i C&#94;alpha_(mu,i) X_(i,HOMO-1) !   tmp_mu = sum_{i in occ_alpha} C&#94;alpha_(mu,i) * X_(i,HOMO-1) call dgemm ( 'n' , 'n' , nbf , 1 , noccb , & 1.0_dp , va , nbf , & bvec ( 1 : noccb , lr1 : lr1 ), nbf , & 0.0_dp , tmp (:, 1 ), nbf ) ! Step 2: Outer product to form AO-basis matrix !   P&#94;bco1_(mu,nu) += tmp_mu * C&#94;beta_(nu,HOMO-1) call dgemm ( 'n' , 't' , nbf , nbf , 1 , & 1.0_dp , tmp (:, 1 : 1 ), nbf , & vb (:, lr1 : lr1 ), nbf , & 1.0_dp , bco1 , nbf ) end if !----------------------------------------------------------------------- ! Component 4: bco2 - C(alpha) -> O2(HOMO, beta) excitations (CO block) !----------------------------------------------------------------------- ! Physical meaning: This component represents Closed-to-Open (CO) excitations ! from doubly-occupied alpha-orbitals (C, 1:noccb) to the HOMO orbital of ! beta-spin (O2, lr2). In MRSF theory, this corresponds to Type II response ! configurations. Together with bco1, this completes the set of spin-flip ! de-excitations from doubly-occupied orbitals to the two singly-occupied MOs. ! ! MO->AO transformation: P&#94;bco2_(mu,nu) = C&#94;alpha_(mu,i) * X_(i,HOMO) * C&#94;beta_(nu,HOMO) ! where i runs over doubly-occupied orbitals (1:noccb) ! if ( noccb > 0 ) then ! Step 1: Intermediate vector tmp = sum_i C&#94;alpha_(mu,i) X_(i,HOMO) !   tmp_mu = sum_{i in occ_alpha} C&#94;alpha_(mu,i) * X_(i,HOMO) call dgemm ( 'n' , 'n' , nbf , 1 , noccb , & 1.0_dp , va , nbf , & bvec ( 1 : noccb , lr2 : lr2 ), nbf , & 0.0_dp , tmp (:, 1 ), nbf ) ! Step 2: Outer product to form AO-basis matrix !   P&#94;bco2_(mu,nu) += tmp_mu * C&#94;beta_(nu,HOMO) call dgemm ( 'n' , 't' , nbf , nbf , 1 , & 1.0_dp , tmp (:, 1 : 1 ), nbf , & vb (:, lr2 : lr2 ), nbf , & 1.0_dp , bco2 , nbf ) end if !----------------------------------------------------------------------- ! Component 5: o21v - Mixed (O1<->O2)(alpha) x V(beta) (OV block) !----------------------------------------------------------------------- ! Physical meaning: This is a mixed Open-to-Virtual (OV) component coupling ! both HOMO and HOMO-1 alpha-orbitals (O1 and O2) with virtual beta-orbitals. ! The subtraction ensures proper antisymmetry and represents coherent ! superpositions of spin-flip excitations. This component is essential for ! the correct description of spin-adapted states in MRSF theory, arising ! from the coupling between different OV response configurations. ! ! MO->AO transformation: !   P&#94;o21v_(mu,nu) = sum_a [ !       C&#94;alpha_(mu,HOMO-1) * X_(HOMO,a) - C&#94;alpha_(mu,HOMO) * X_(HOMO-1,a) !                          ] * C&#94;beta_(nu,a) ! ! Step 1: Intermediate vector from HOMO -> virt_beta amplitudes !   tmp_mu = sum_{a in virt_beta} C&#94;beta_(mu,a) * X_(HOMO,a) call dgemm ( 'n' , 't' , nbf , 1 , nbf - nocca , & 1.0_dp , vb (:, nocca + 1 ), nbf , & bvec ( lr2 : lr2 , nocca + 1 ), nbf , & 0.0_dp , tmp (:, 1 ), nbf ) ! Combined outer products with subtraction !   P&#94;o21v_(mu,nu) += C&#94;alpha_(mu,HOMO-1) * tmp_nu (positive contribution) call dgemm ( 'n' , 't' , nbf , nbf , 1 , & 1.0_dp , tmp (:, 1 : 1 ), nbf , & va (:, lr1 : lr1 ), nbf , & 1.0_dp , o21v , nbf ) ! Step 1: Intermediate vector from HOMO-1 -> virt_beta amplitudes !   tmp_mu = sum_{a in virt_beta} C&#94;beta_(mu,a) * X_(HOMO-1,a) call dgemm ( 'n' , 't' , nbf , 1 , nbf - nocca , & 1.0_dp , vb (:, nocca + 1 ), nbf , & bvec ( lr1 : lr1 , nocca + 1 ), nbf , & 0.0_dp , tmp (:, 1 ), nbf ) !   P&#94;o21v_(mu,nu) -= C&#94;alpha_(mu,HOMO) * tmp_nu (negative contribution) call dgemm ( 'n' , 't' , nbf , nbf , 1 , & - 1.0_dp , tmp (:, 1 : 1 ), nbf , & va (:, lr2 : lr2 ), nbf , & 1.0_dp , o21v , nbf ) !----------------------------------------------------------------------- ! Component 6: co12 - C(alpha) x Mixed (O1<->O2)(beta) (CO block) !----------------------------------------------------------------------- ! Physical meaning: This is a mixed Closed-to-Open (CO) component coupling ! doubly-occupied alpha-orbitals with both HOMO and HOMO-1 beta-orbitals ! (O1 and O2). The subtraction ensures proper antisymmetry and represents ! coherent superpositions of spin-flip de-excitations. Together with o21v, ! this maintains the full symmetry of the MRSF response space under orbital ! permutations, arising from coupling between different CO configurations. ! ! MO->AO transformation: !   P&#94;co12_(mu,nu) = sum_i [ !       C&#94;beta_(mu,HOMO) * X_(i,HOMO-1) - C&#94;beta_(mu,HOMO-1) * X_(i,HOMO) !                          ] * C&#94;alpha_(nu,i) ! if ( noccb > 0 ) then ! Step 1: Intermediate vector from occ_alpha -> HOMO-1_beta amplitudes !   tmp_mu = sum_{i in occ_alpha} C&#94;alpha_(mu,i) * X_(i,HOMO-1) call dgemm ( 'n' , 'n' , nbf , 1 , noccb , & 1.0_dp , va , nbf , & bvec ( 1 : noccb , lr1 : lr1 ), nbf , & 0.0_dp , tmp (:, 1 ), nbf ) ! Combined outer products with subtraction !   P&#94;co12_(mu,nu) += C&#94;beta_(mu,HOMO) * tmp_nu (positive contribution) call dgemm ( 'n' , 't' , nbf , nbf , 1 , & 1.0_dp , vb (:, lr2 : lr2 ), nbf , & tmp (:, 1 : 1 ), nbf , & 1.0_dp , co12 , nbf ) ! Step 1: Intermediate vector from occ_alpha -> HOMO_beta amplitudes !   tmp_mu = sum_{i in occ_alpha} C&#94;alpha_(mu,i) * X_(i,HOMO) call dgemm ( 'n' , 'n' , nbf , 1 , noccb , & 1.0_dp , va , nbf , & bvec ( 1 : noccb , lr2 : lr2 ), nbf , & 0.0_dp , tmp (:, 1 ), nbf ) !   P&#94;co12_(mu,nu) -= C&#94;beta_(mu,HOMO-1) * tmp_nu (negative contribution) call dgemm ( 'n' , 't' , nbf , nbf , 1 , & - 1.0_dp , vb (:, lr1 : lr1 ), nbf , & tmp (:, 1 : 1 ), nbf , & 1.0_dp , co12 , nbf ) end if !----------------------------------------------------------------------- ! Sum the four primary components into the total response matrix !----------------------------------------------------------------------- ! Physical meaning: Combine bo2v, bo1v, bco1, and bco2 (the four components ! without mixed character) into the total AO-basis response matrix ball. ! These represent the OV and CO blocks (Type II and Type III configurations). ! The mixed components o21v and co12 are not included here as they are ! handled separately in the spin-dependent sections below. ball = ball + bo2v + bo1v + bco1 + bco2 !----------------------------------------------------------------------- ! Additional general contribution: C(alpha) x V(beta) block (CV) !----------------------------------------------------------------------- ! Physical meaning: Transform the general Closed-to-Virtual (CV) block of ! response amplitudes (doubly-occupied_alpha -> virtual_beta) to AO basis. ! This represents Type IV spin-flip excitations from the doubly-occupied ! core orbitals. These excitations do not involve the singly-occupied ! frontier orbitals (O1, O2) and represent the CV response configurations. ! ! Transformation: P&#94;ball_(mu,nu) += sum_ia C&#94;alpha_(mu,i) * X_(i,a) * C&#94;beta_(nu,a) ! where i in doubly-occupied (1:noccb), a in virtual_beta (nocca+1:nbf) ! if ( noccb > 0 ) then ! Step 1: Intermediate tmp_(mu,i) = sum_a C&#94;beta_(mu,a) * X_(i,a) call dgemm ( 'n' , 't' , nbf , noccb , nbf - nocca , & 1.0_dp , vb (:, nocca + 1 ), nbf , & bvec (:, nocca + 1 ), nbf , & 0.0_dp , tmp (:, 1 : noccb ), nbf ) ! Step 2: Outer product P&#94;ball_(mu,nu) += sum_i C&#94;alpha_(mu,i) * tmp_(nu,i) call dgemm ( 'n' , 't' , nbf , nbf , noccb , & 1.0_dp , va , nbf , & tmp (:, 1 : noccb ), nbf , & 1.0_dp , ball , nbf ) end if !----------------------------------------------------------------------- ! Spin-dependent corrections for (O1<->O2) x (O1<->O2) block (OO) !----------------------------------------------------------------------- ! Physical meaning: Add corrections for the Open-to-Open (OO) Type I response ! configurations that depend on the target spin state (singlet mrst=1 or ! triplet mrst=3). These involve the special elements X_(HOMO,HOMO-1), ! X_(HOMO-1,HOMO), and X_(HOMO-1,HOMO-1) that couple the two singly-occupied ! MOs (O1 and O2). The 1/sqrt(2) factor ensures proper normalization of ! spin-adapted states in the MRSF formalism. ! ! Spin-pairing coupling between MS=+1 and MS=-1 triplet references (following ! Slater-Condon rules) is implemented via specific linear combinations of ! MO coefficients va and vb. The different sign patterns for singlet/triplet ! reflect the different spin symmetries: ! - Singlet: antisymmetric spatial wavefunction (subtraction) ! - Triplet: symmetric spatial wavefunction (addition) if ( mrst == 1 ) then ! Singlet state corrections (mrst=1): ! Three terms that couple HOMO and HOMO-1 orbitals: ! 1. X_(HOMO,HOMO-1) * C&#94;alpha_HOMO (outer) C&#94;beta_HOMO-1 ! 2. X_(HOMO-1,HOMO) * C&#94;alpha_HOMO-1 (outer) C&#94;beta_HOMO ! 3. X_(HOMO-1,HOMO-1) * (C&#94;alpha_HOMO-1 (outer) C&#94;beta_HOMO-1 - C&#94;alpha_HOMO (outer) C&#94;beta_HOMO) / sqrt(2) ! The subtraction in term 3 ensures proper singlet spin coupling. do m = 1 , nbf ball (:, m ) = ball (:, m ) & + va (:, lr2 ) * bvec ( lr2 , lr1 ) * vb ( m , lr1 ) & + va (:, lr1 ) * bvec ( lr1 , lr2 ) * vb ( m , lr2 ) & + ( va (:, lr1 ) * vb ( m , lr1 ) - va (:, lr2 ) * vb ( m , lr2 )) & * bvec ( lr1 , lr1 ) * isqrt2 end do else if ( mrst == 3 ) then ! Triplet state corrections (mrst=3): ! Single term for diagonal HOMO-1,HOMO-1 element: ! X_(HOMO-1,HOMO-1) * (C&#94;alpha_HOMO-1 (outer) C&#94;beta_HOMO-1 + C&#94;alpha_HOMO (outer) C&#94;beta_HOMO) / sqrt(2) ! The addition ensures proper triplet spin coupling. ! Off-diagonal OO terms are zero for triplet states. do m = 1 , nbf ball (:, m ) = ball (:, m ) & + ( va (:, lr1 ) * vb ( m , lr1 ) + va (:, lr2 ) * vb ( m , lr2 )) & * bvec ( lr1 , lr1 ) * isqrt2 end do end if if ( debug_mode ) then write ( iw , * ) 'Check sum = va' , sum ( abs ( va )) write ( iw , * ) 'Check sum = vb' , sum ( abs ( vb )) write ( iw , * ) 'Check sum = bvec' , sum ( abs ( bvec )) write ( iw , * ) 'Check sum = ball' , sum ( abs ( ball )) write ( iw , * ) 'Check sum = o21v' , sum ( abs ( o21v )) write ( iw , * ) 'Check sum = co12' , sum ( abs ( co12 )) write ( iw , * ) 'Check sum = bo2v' , sum ( abs ( bo2v )) write ( iw , * ) 'Check sum = bo1v' , sum ( abs ( bo1v )) write ( iw , * ) 'Check sum = bco1' , sum ( abs ( bco1 )) write ( iw , * ) 'Check sum = bco2' , sum ( abs ( bco2 )) end if return end subroutine mrsfcbc !############################################################################### !> Transform UMRSF trial vectors from MO to AO basis !> !> UMRSF analogue of mrsfcbc: builds the AO-basis generalized density !> components of the UMRSF-TDDFT response from a UHF reference.  Because !> alpha and beta MOs differ, each spin-pair-coupling MRSF channel splits !> into separate alpha/beta components (11 channels in total): !>   1/2. bo2va/bo2vb: O2(HOMO) -> V, alpha/beta !>   3/4. bo1va/bo1vb: O1(HOMO-1) -> V, alpha/beta !>   5/6. bco1a/bco1b: C -> O1(HOMO-1), alpha/beta !>   7/8. bco2a/bco2b: C -> O2(HOMO), alpha/beta !>   9.   o21v: mixed OV component coupling O1 and O2 with V !>   10.  co12: mixed CO component coupling C with O1 and O2 !>   11.  ball: general (summed) component !> !> See mrsfcbc for the underlying transformation scheme and reference. !> subroutine umrsfcbc ( infos , va , vb , bvec , mrsf_density ) use messages , only : show_message , with_abort use types , only : information use io_constants , only : iw use precision , only : dp implicit none type ( information ), intent ( in ) :: infos real ( kind = dp ), intent ( in ), dimension (:,:) :: & va , vb , bvec real ( kind = dp ), intent ( inout ), target , dimension (:,:,:) :: & mrsf_density real ( kind = dp ), allocatable , dimension (:,:) :: & tmp , tmp1 , tmp2 real ( kind = dp ), pointer , dimension (:,:) :: & bo2va , bo2vb , bo1va , bo1vb , bco1a , bco1b , & bco2a , bco2b , ball , co12 , o21v integer :: nocca , noccb , mrst , i , j , m , nbf , lr1 , lr2 , ok logical :: debug_mode real ( kind = dp ), parameter :: isqrt2 = 1.0_dp / sqrt ( 2.0_dp ) ball => mrsf_density ( 11 ,:,:) bo2va => mrsf_density ( 1 ,:,:) bo2vb => mrsf_density ( 2 ,:,:) bo1va => mrsf_density ( 3 ,:,:) bo1vb => mrsf_density ( 4 ,:,:) bco1a => mrsf_density ( 5 ,:,:) bco1b => mrsf_density ( 6 ,:,:) bco2a => mrsf_density ( 7 ,:,:) bco2b => mrsf_density ( 8 ,:,:) o21v => mrsf_density ( 9 ,:,:) co12 => mrsf_density ( 10 ,:,:) nbf = infos % basis % nbf nocca = infos % mol_prop % nelec_A noccb = infos % mol_prop % nelec_B mrst = infos % tddft % mult debug_mode = infos % tddft % debug_mode lr1 = nocca - 1 lr2 = nocca allocate ( tmp ( nbf , nbf ), & tmp1 ( nbf , 4 ), & tmp2 ( nbf , 4 ), & source = 0.0_dp , stat = ok ) if ( ok /= 0 ) call show_message ( 'Cannot allocate memory' , with_abort ) do j = nocca + 1 , nbf tmp1 (:, 1 ) = tmp1 (:, 1 ) + va (:, j ) * bvec ( nocca , j ) tmp1 (:, 2 ) = tmp1 (:, 2 ) + vb (:, j ) * bvec ( nocca , j ) tmp1 (:, 3 ) = tmp1 (:, 3 ) + va (:, j ) * bvec ( nocca - 1 , j ) tmp1 (:, 4 ) = tmp1 (:, 4 ) + vb (:, j ) * bvec ( nocca - 1 , j ) end do do i = 1 , nocca - 2 tmp2 (:, 1 ) = tmp2 (:, 1 ) + va (:, i ) * bvec ( i , nocca - 1 ) tmp2 (:, 2 ) = tmp2 (:, 2 ) + vb (:, i ) * bvec ( i , nocca - 1 ) tmp2 (:, 3 ) = tmp2 (:, 3 ) + va (:, i ) * bvec ( i , nocca ) tmp2 (:, 4 ) = tmp2 (:, 4 ) + vb (:, i ) * bvec ( i , nocca ) end do do m = 1 , nbf ball (:, m ) = ball (:, m ) + tmp1 ( m , 2 ) * va (:, nocca ) & + tmp1 ( m , 4 ) * va (:, nocca - 1 ) & + tmp2 (:, 1 ) * vb ( m , nocca - 1 ) & + tmp2 (:, 3 ) * vb ( m , nocca ) bo2va (:, m ) = bo2va (:, m ) + tmp1 ( m , 1 ) * va (:, nocca ) bo2vb (:, m ) = bo2vb (:, m ) + tmp1 ( m , 2 ) * vb (:, nocca ) bo1va (:, m ) = bo1va (:, m ) + tmp1 ( m , 3 ) * va (:, nocca - 1 ) bo1vb (:, m ) = bo1vb (:, m ) + tmp1 ( m , 4 ) * vb (:, nocca - 1 ) o21v (:, m ) = o21v (:, m ) + tmp1 ( m , 2 ) * va (:, nocca - 1 ) & - tmp1 ( m , 4 ) * va (:, nocca ) bco1a (:, m ) = bco1a (:, m ) + tmp2 (:, 1 ) * va ( m , nocca - 1 ) bco1b (:, m ) = bco1b (:, m ) + tmp2 (:, 2 ) * vb ( m , nocca - 1 ) bco2a (:, m ) = bco2a (:, m ) + tmp2 (:, 3 ) * va ( m , nocca ) bco2b (:, m ) = bco2b (:, m ) + tmp2 (:, 4 ) * vb ( m , nocca ) co12 (:, m ) = co12 (:, m ) + tmp2 (:, 1 ) * vb ( m , nocca ) & - tmp2 (:, 3 ) * vb ( m , nocca - 1 ) end do ! Closed->Virtual block: empty when there is no doubly-occupied core ! (nocca-2 = noccb = 0, e.g. H2 triplet). Skip explicitly so the UHF path ! mirrors the ROHF guard (the do i=1,nocca-2 loop above is already a no-op). if ( nocca > 2 ) then call dgemm ( 'n' , 't' , nbf , nocca - 2 , nbf - nocca , & 1.0_dp , vb (:, nocca + 1 ), nbf , & bvec (:, nocca + 1 ), nbf , & 0.0_dp , tmp , nbf ) call dgemm ( 'n' , 't' , nbf , nbf , nocca - 2 , & 1.0_dp , va , nbf , & tmp , nbf , & 1.0_dp , ball , nbf ) end if if ( mrst == 1 ) then do m = 1 , nbf ball (:, m ) = ball (:, m ) & + va (:, lr2 ) * bvec ( lr2 , lr1 ) * vb ( m , lr1 ) & + va (:, lr1 ) * bvec ( lr1 , lr2 ) * vb ( m , lr2 ) & + ( va (:, lr1 ) * vb ( m , lr1 ) - va (:, lr2 ) * vb ( m , lr2 )) & * bvec ( lr1 , lr1 ) * isqrt2 end do else if ( mrst == 3 ) then do m = 1 , nbf ball (:, m ) = ball (:, m ) & + ( va (:, lr1 ) * vb ( m , lr1 ) + va (:, lr2 ) * vb ( m , lr2 )) & * bvec ( lr1 , lr1 ) * isqrt2 end do end if if ( debug_mode ) then write ( iw , * ) 'UMRSFCBC' write ( iw , * ) 'Check sum = va' , sum ( abs ( va )) write ( iw , * ) 'Check sum = vb' , sum ( abs ( vb )) write ( iw , * ) 'Check sum = bvec' , sum ( abs ( bvec )) write ( iw , * ) 'Check sum = ball' , sum ( abs ( ball )) write ( iw , * ) 'Check sum = o21v' , sum ( abs ( o21v )) write ( iw , * ) 'Check sum = co12' , sum ( abs ( co12 )) write ( iw , * ) 'Check sum = bo2va' , sum ( abs ( bo2va )) write ( iw , * ) 'Check sum = bo2vb' , sum ( abs ( bo2vb )) write ( iw , * ) 'Check sum = bo1va' , sum ( abs ( bo1va )) write ( iw , * ) 'Check sum = bo1vb' , sum ( abs ( bo1vb )) write ( iw , * ) 'Check sum = bco1a' , sum ( abs ( bco1a )) write ( iw , * ) 'Check sum = bco1b' , sum ( abs ( bco1b )) write ( iw , * ) 'Check sum = bco2a' , sum ( abs ( bco2a )) write ( iw , * ) 'Check sum = bco2b' , sum ( abs ( bco2b )) end if deallocate ( tmp , tmp1 , tmp2 ) return end subroutine umrsfcbc !> Transform MRSF Fock-like matrices from AO to MO basis !> !> This subroutine performs the transformation of MRSF-TDDFT Fock-like matrices !> (or generalized density contributions) from atomic orbital (AO) basis back to !> molecular orbital (MO) representation. !> !> Physical context: !> After contracting the response amplitudes (in AO basis) with two-electron !> integrals and other operators, we obtain Fock-like matrices P&#94;(k)_(mu,nu) in !> AO basis. These must be transformed back to MO basis to extract elements !> corresponding to specific orbital transitions in the MRSF response space. !> !> Orbital spaces (same as in mrsfcbc): !> - C (Closed): Doubly-occupied orbitals !> - O (Open): Singly-occupied O1=HOMO-1, O2=HOMO !> - V (Virtual): Unoccupied orbitals !> !> Transformation scheme: !> For the general contribution: F&#94;MO_pq = sum_(mu,nu) C&#94;alpha_(mu,p) P&#94;AO_(mu,nu) C&#94;beta_(nu,q) !> !> Then, specific corrections are added for each of the six response components !> corresponding to different blocks of the MRSF response space: !> 1. Section 3: Corrections from ado1v (OV) and aco12 (CO mixed) -> C x O2 block !> 2. Section 4: Corrections from ado2v (OV) and aco12 (CO mixed) -> C x O1 block !> 3. Section 5: Corrections from adco2 (CO) and ao21v (OV mixed) -> O1 x V block !> 4. Section 6: Corrections from adco1 (CO) and ao21v (OV mixed) -> O2 x V block !> !> Reference: Lee et al., J. Chem. Phys. 150, 184111 (2019), Eq. 2.11-2.18 !> !> \\author  Konstantin Komarov (constlike@gmail.com) !> subroutine mrsfmntoia ( infos , fmrsf , pmo , va , vb , ivec ) use precision , only : dp use types , only : information use messages , only : show_message , with_abort use io_constants , only : iw implicit none type ( information ), intent ( in ) :: infos real ( kind = dp ), intent ( in ), target , dimension (:,:,:) :: & fmrsf real ( kind = dp ), intent ( out ), dimension (:,:) :: pmo real ( kind = dp ), intent ( in ), dimension (:,:) :: va , vb integer , intent ( in ) :: ivec real ( kind = dp ), allocatable :: & scr (:,:), tmp (:), wrk (:,:) real ( kind = dp ), pointer , dimension (:,:) :: & adco1 , adco2 , ado1v , ado2v , agdlr , aco12 , ao21v integer :: noca , nocb , mrst , i , ij , & j , lr1 , lr2 , nbf , ok real ( kind = dp ), parameter :: zero = 0.0_dp real ( kind = dp ), parameter :: one = 1.0_dp real ( kind = dp ), parameter :: sqrt2 = 1.0_dp / sqrt ( 2.0_dp ) logical :: debug_mode nbf = infos % basis % nbf mrst = infos % tddft % mult noca = infos % mol_prop % nelec_a nocb = infos % mol_prop % nelec_b debug_mode = infos % tddft % debug_mode allocate ( tmp ( nbf ), scr ( nbf , nbf ), wrk ( nbf , nbf ), source = 0.0_dp , stat = ok ) if ( ok /= 0 ) call show_message ( 'Cannot allocate memory' , with_abort ) agdlr => fmrsf ( 7 ,:,:) ado2v => fmrsf ( 1 ,:,:) ado1v => fmrsf ( 2 ,:,:) adco1 => fmrsf ( 3 ,:,:) adco2 => fmrsf ( 4 ,:,:) ao21v => fmrsf ( 5 ,:,:) aco12 => fmrsf ( 6 ,:,:) lr1 = noca - 1 lr2 = noca !----------------------------------------------------------------------- ! Initial AO->MO transformation of general Fock-like contribution !----------------------------------------------------------------------- ! Physical meaning: Transform the general (summed) Fock-like matrix agdlr ! from AO basis to MO basis. This represents the baseline contribution ! before adding specific corrections for each response component. ! ! Transformation: F&#94;MO_pq = C&#94;alpha&#94;T * P&#94;AO * C&#94;beta !   Step 1: wrk = C&#94;alpha&#94;T * agdlr (transform first index) !   Step 2: scr = wrk * C&#94;beta (transform second index) ! ! Result: scr contains the general MO-basis matrix that will be corrected ! by the specific response component contributions in sections 3-6. call dgemm ( 't' , 'n' , nbf , nbf , nbf , & one , va , nbf , & agdlr , nbf , & zero , wrk , nbf ) call dgemm ( 'n' , 'n' , nbf , nbf , nbf , & one , wrk , nbf , & vb , nbf , & zero , scr , nbf ) ! 1 !   ----- (m,n) to (i+,n) ----- wrk = scr !----------------------------------------------------------------------- ! Section 3: Corrections for C(alpha) -> O2(HOMO, beta) response element !----------------------------------------------------------------------- ! Physical meaning: Add corrections to F&#94;MO_(i,HOMO) from two sources: ! 1. ado1v: O1(HOMO-1, alpha) -> V(beta) excitation component (OV block) ! 2. aco12: C(alpha) x Mixed (O1<->O2)(beta) component (CO mixed block) ! ! These represent the backflow of MO to AO, accounting for coupling ! between different excitation types (OV and CO blocks). ! The result corrects wrk(i,lr2) for doubly-occupied ! orbitals i in the Closed space. ! ! Combined transformation: !   tmp = ado1v * C&#94;beta_HOMO + aco12 * C&#94;beta_HOMO-1 !   F&#94;MO_(i,HOMO) += C&#94;alpha_i&#94;T * tmp  (for i=1:noca-2) ! ! Step 1: Contract ado1v with HOMO_beta MO coefficient !   tmp_mu = sum_nu P&#94;ado1v_(mu,nu) * C&#94;beta_(nu,HOMO) call dgemm ( 'n' , 'n' , nbf , 1 , nbf , & one , ado1v , nbf , & vb (:, lr2 : lr2 ), nbf , & zero , tmp , nbf ) ! Step 2: Add contribution from aco12 with HOMO-1_beta MO coefficient !   tmp_mu += sum_nu P&#94;aco12_(mu,nu) * C&#94;beta_(nu,HOMO-1) call dgemm ( 'n' , 'n' , nbf , 1 , nbf , & one , aco12 , nbf , & vb (:, lr1 : lr1 ), nbf , & one , tmp , nbf ) ! Step 3: Project onto doubly-occupied alpha-orbitals !   F&#94;MO_(i,HOMO) += sum_mu C&#94;alpha_(mu,i) * tmp_mu  (i=1:noca-2) ! Guard: when noca<=2 there is no doubly-occupied core below the open-shell ! frontier (HOMO-1,HOMO), so the Closed->Open block is empty (e.g. H2 triplet, ! noca=2 => noccb=noca-2=0). Without the guard DGEMM gets M=LDC=noca-2<=0 ! (illegal value), crashing the MRSF Davidson. Matches umrsfmntoia (do i=1,lr1-1). if ( noca > 2 ) then call dgemm ( 't' , 'n' , noca - 2 , 1 , nbf , & one , va , nbf , & tmp , nbf , & one , wrk ( 1 : noca - 2 , lr2 : lr2 ), noca - 2 ) end if !----------------------------------------------------------------------- ! Section 4: Corrections for C(alpha) -> O1(HOMO-1, beta) response element !----------------------------------------------------------------------- ! Physical meaning: Add corrections to F&#94;MO_(i,HOMO-1) from two sources: ! 1. ado2v: O2(HOMO, alpha) -> V(beta) excitation component (OV block, positive) ! 2. aco12: C(alpha) x Mixed (O1<->O2)(beta) component (CO mixed, negative) ! ! The subtraction in this section ensures proper antisymmetry between ! HOMO and HOMO-1 contributions, maintaining consistency with the mixed ! character of the aco12 and ao21v components. This antisymmetry arises from ! the spin-pairing coupling realized via linear combinations of va and vb. ! ! Combined transformation: !   tmp = ado2v * C&#94;beta_HOMO-1 - aco12 * C&#94;beta_HOMO !   F&#94;MO_(i,HOMO-1) += C&#94;alpha_i&#94;T * tmp  (for i=1:noca-2) ! ! Step 1: Contract aco12 with HOMO_beta MO coefficient !   tmp_mu = sum_nu P&#94;aco12_(mu,nu) * C&#94;beta_(nu,HOMO) call dgemm ( 'n' , 'n' , nbf , 1 , nbf , & one , aco12 , nbf , & vb (:, lr2 : lr2 ), nbf , & zero , tmp , nbf ) ! Step 2: Add ado2v contribution and subtract aco12 contribution !   tmp_mu = sum_nu P&#94;ado2v_(mu,nu) * C&#94;beta_(nu,HOMO-1) - tmp_mu call dgemm ( 'n' , 'n' , nbf , 1 , nbf , & one , ado2v , nbf , & vb (:, lr1 : lr1 ), nbf , & - one , tmp , nbf ) ! Step 3: Project onto doubly-occupied alpha-orbitals !   F&#94;MO_(i,HOMO-1) += sum_mu C&#94;alpha_(mu,i) * tmp_mu  (i=1:noca-2) if ( noca > 2 ) then ! see guard note above; empty when no doubly-occupied core call dgemm ( 't' , 'n' , noca - 2 , 1 , nbf , & one , va , nbf , & tmp , nbf , & one , wrk ( 1 : noca - 2 , lr1 : lr1 ), noca - 2 ) end if !----------------------------------------------------------------------- ! Section 5: Corrections for O1(HOMO-1, alpha) -> V(beta) response element !----------------------------------------------------------------------- ! Physical meaning: Add corrections to F&#94;MO_(HOMO-1,a) from two sources: ! 1. adco2: C(alpha) -> O2(HOMO, beta) excitation component (CO block) ! 2. ao21v: Mixed (O1<->O2)(alpha) x V(beta) component (OV mixed block) ! ! This section computes contributions to the O1(HOMO-1, alpha) -> V(beta) block ! by contracting the transposed AO matrices with alpha-spin MO coefficients, ! then projecting onto virtual beta-orbitals. ! ! Combined transformation: !   tmp = adco2&#94;T * C&#94;alpha_HOMO-1 + ao21v&#94;T * C&#94;alpha_HOMO !   F&#94;MO_(HOMO-1,a) += C&#94;beta_a&#94;T * tmp  (for a in virt_beta) ! ! Step 1: Contract adco2&#94;T with HOMO-1_alpha MO coefficient !   tmp_mu = sum_nu P&#94;adco2_(nu,mu) * C&#94;alpha_(nu,HOMO-1) call dgemm ( 't' , 'n' , nbf , 1 , nbf , & one , adco2 , nbf , & va (:, lr1 : lr1 ), nbf , & zero , tmp , nbf ) ! Step 2: Add contribution from ao21v&#94;T with HOMO_alpha MO coefficient !   tmp_mu += sum_nu P&#94;ao21v_(nu,mu) * C&#94;alpha_(nu,HOMO) call dgemm ( 't' , 'n' , nbf , 1 , nbf , & one , ao21v , nbf , & va (:, lr2 : lr2 ), nbf , & one , tmp , nbf ) ! Step 3: Project onto virtual beta-orbitals !   F&#94;MO_(HOMO-1,a) += sum_mu C&#94;beta_(mu,a) * tmp_mu  (a=noca+1:nbf) call dgemm ( 't' , 'n' , nbf - noca , 1 , nbf , & one , vb (:, noca + 1 ), nbf , & tmp , nbf , & one , wrk ( lr1 : lr1 , noca + 1 : nbf ), nbf - noca ) !----------------------------------------------------------------------- ! Section 6: Corrections for O2(HOMO, alpha) -> V(beta) response element !----------------------------------------------------------------------- ! Physical meaning: Add corrections to F&#94;MO_(HOMO,a) from two sources: ! 1. adco1: C(alpha) -> O1(HOMO-1, beta) excitation component (CO block, positive) ! 2. ao21v: Mixed (O1<->O2)(alpha) x V(beta) component (OV mixed, negative) ! ! The subtraction in this section ensures proper antisymmetry between ! HOMO and HOMO-1 contributions, complementing Section 5 and maintaining ! consistency with the mixed character of ao21v. This antisymmetry arises from ! the spin-pairing coupling realized via linear combinations of va and vb. ! ! Combined transformation: !   tmp = adco1&#94;T * C&#94;alpha_HOMO - ao21v&#94;T * C&#94;alpha_HOMO-1 !   F&#94;MO_(HOMO,a) += C&#94;beta_a&#94;T * tmp  (for a in virt_beta) ! ! Step 1: Contract ao21v&#94;T with HOMO-1_alpha MO coefficient !   tmp_mu = sum_nu P&#94;ao21v_(nu,mu) * C&#94;alpha_(nu,HOMO-1) call dgemm ( 't' , 'n' , nbf , 1 , nbf , & one , ao21v , nbf , & va (:, lr1 : lr1 ), nbf , & zero , tmp , nbf ) ! Step 2: Add adco1 contribution and subtract ao21v contribution !   tmp_mu = sum_nu P&#94;adco1_(nu,mu) * C&#94;alpha_(nu,HOMO) - tmp_mu call dgemm ( 't' , 'n' , nbf , 1 , nbf , & one , adco1 , nbf , & va (:, lr2 : lr2 ), nbf , & - one , tmp , nbf ) ! Step 3: Project onto virtual beta-orbitals !   F&#94;MO_(HOMO,a) += sum_mu C&#94;beta_(mu,a) * tmp_mu  (a=noca+1:nbf) call dgemm ( 't' , 'n' , nbf - noca , 1 , nbf , & one , vb (:, noca + 1 ), nbf , & tmp , nbf , & one , wrk ( lr2 : lr2 , noca + 1 : nbf ), nbf - noca ) !----------------------------------------------------------------------- ! Spin-dependent corrections for (O1,O1) diagonal element (OO block) !----------------------------------------------------------------------- ! Physical meaning: Apply spin-state-dependent transformations to the ! F&#94;MO_(HOMO-1,HOMO-1) diagonal element based on whether we are computing ! a singlet (mrst=1) or triplet (mrst=3) excited state. ! ! The 1/sqrt(2) factor and the addition/subtraction of diagonal elements ensure ! proper normalization and spin coupling for the MRSF response equations. ! This reflects the spin-pairing coupling between MS=+1 and MS=-1 triplet ! reference states (via linear combinations of va and vb), following Slater-Condon rules. if ( mrst == 1 ) then ! Singlet state (mrst=1): ! F&#94;MO_(HOMO-1,HOMO-1) = (scr_(HOMO-1,HOMO-1) - scr_(HOMO,HOMO)) / sqrt(2) ! The subtraction reflects the antisymmetric spin coupling in singlets. ! The (HOMO,HOMO) element is zeroed as it's not part of the singlet response space. wrk ( lr1 , lr1 ) = ( scr ( lr1 , lr1 ) - scr ( lr2 , lr2 )) * sqrt2 wrk ( lr2 , lr2 ) = 0.0_dp else if ( mrst == 3 ) then ! Triplet state (mrst=3): ! F&#94;MO_(HOMO-1,HOMO-1) = (scr_(HOMO-1,HOMO-1) + scr_(HOMO,HOMO)) / sqrt(2) ! The addition reflects the symmetric spin coupling in triplets. ! All other OO coupling elements (HOMO,HOMO-1), (HOMO-1,HOMO), and ! (HOMO,HOMO) are zeroed as they're outside the triplet response space. wrk ( lr1 , lr1 ) = ( scr ( lr1 , lr1 ) + scr ( lr2 , lr2 )) * sqrt2 wrk ( lr2 , lr1 ) = 0.0_dp wrk ( lr1 , lr2 ) = 0.0_dp wrk ( lr2 , lr2 ) = 0.0_dp end if pmo (:, ivec ) = 0.0_dp ij = 0 do j = nocb + 1 , nbf do i = 1 , noca ij = ij + 1 pmo ( ij , ivec ) = pmo ( ij , ivec ) + wrk ( i , j ) end do end do if ( debug_mode ) then write ( iw , * ) 'MNTOIA' write ( iw , * ) 'Check sum = ivec' , ivec write ( iw , * ) 'Check sum = agdlr' , sum ( abs ( agdlr )) write ( iw , * ) 'Check sum = ao21v' , sum ( abs ( ao21v )) write ( iw , * ) 'Check sum = aco12' , sum ( abs ( aco12 )) write ( iw , * ) 'Check sum = ado2v' , sum ( abs ( ado2v )) write ( iw , * ) 'Check sum = ado1v' , sum ( abs ( ado1v )) write ( iw , * ) 'Check sum = adco1' , sum ( abs ( adco1 )) write ( iw , * ) 'Check sum = adco2' , sum ( abs ( adco2 )) write ( iw , * ) 'Check sum = pmo' , sum ( abs ( pmo (:, ivec ))) end if return end subroutine mrsfmntoia !############################################################################### !> Transform UMRSF Fock-like matrices from AO to MO basis !> !> UMRSF analogue of mrsfmntoia for a UHF reference: assembles the MO-basis !> response vector from the 11 AO-basis Fock-like components produced by !> int2_umrsf_data_t_update (spin-split alpha/beta channels 1:8, mixed !> spin-pair channels 9:10, and the general component agdlr in channel 11). !> See mrsfmntoia for the underlying transformation scheme and reference. !> subroutine umrsfmntoia ( infos , fmrsf , pmo , va , vb , ivec ) use precision , only : dp use types , only : information use messages , only : show_message , with_abort use io_constants , only : iw implicit none type ( information ), intent ( in ) :: infos real ( kind = dp ), intent ( in ), target , dimension (:,:,:) :: & fmrsf real ( kind = dp ), intent ( out ), dimension (:,:) :: pmo real ( kind = dp ), intent ( in ), dimension (:,:) :: va , vb integer , intent ( in ) :: ivec real ( kind = dp ), allocatable :: & scr (:,:), wrk (:,:) real ( kind = dp ), pointer , dimension (:,:) :: & adco1a , adco1b , adco2a , adco2b , & ado1va , ado1vb , ado2va , ado2vb , agdlr , aco12 , ao21v integer :: noca , nocb , mrst , i , ij , & j , lr1 , lr2 , nbf , ok , ni , nj real ( kind = dp ), parameter :: zero = 0.0_dp real ( kind = dp ), parameter :: one = 1.0_dp real ( kind = dp ), parameter :: half = 0.5_dp real ( kind = dp ), parameter :: sqrt2 = 1.0_dp / sqrt ( 2.0_dp ) real ( kind = dp ) :: dumn logical :: debug_mode nbf = infos % basis % nbf mrst = infos % tddft % mult noca = infos % mol_prop % nelec_a nocb = infos % mol_prop % nelec_b debug_mode = infos % tddft % debug_mode allocate ( scr ( nbf , nbf ), wrk ( nbf , nbf ), source = 0.0_dp , stat = ok ) if ( ok /= 0 ) call show_message ( 'Cannot allocate memory' , with_abort ) agdlr => fmrsf ( 11 ,:,:) ado2va => fmrsf ( 1 ,:,:) ado2vb => fmrsf ( 2 ,:,:) ado1va => fmrsf ( 3 ,:,:) ado1vb => fmrsf ( 4 ,:,:) adco1a => fmrsf ( 5 ,:,:) adco1b => fmrsf ( 6 ,:,:) adco2a => fmrsf ( 7 ,:,:) adco2b => fmrsf ( 8 ,:,:) ao21v => fmrsf ( 9 ,:,:) aco12 => fmrsf ( 10 ,:,:) lr1 = noca - 1 lr2 = noca ! Initial AO->MO transformation of the general Fock-like contribution: !   wrk = C&#94;alpha&#94;T * agdlr,  scr = wrk * C&#94;beta call dgemm ( 't' , 'n' , nbf , nbf , nbf , & one , va , nbf , & agdlr , nbf , & zero , wrk , nbf ) call dgemm ( 'n' , 'n' , nbf , nbf , nbf , & one , wrk , nbf , & vb , nbf , & zero , scr , nbf ) ! 1 !   ----- (m,n) to (i+,n) ----- wrk = scr ! 3 j = lr2 do i = 1 , lr1 - 1 dumn = 0.0_dp do ni = 1 , nbf do nj = 1 , nbf dumn = dumn + va ( ni , i ) * va ( nj , j ) * ado1va ( ni , nj ) * half & + vb ( ni , i ) * vb ( nj , j ) * ado1vb ( ni , nj ) * half & + va ( ni , i ) * vb ( nj , j - 1 ) * aco12 ( ni , nj ) end do end do wrk ( i , j ) = wrk ( i , j ) + dumn end do ! 4 j = lr1 do i = 1 , lr1 - 1 dumn = 0.0_dp do ni = 1 , nbf do nj = 1 , nbf dumn = dumn + va ( ni , i ) * va ( nj , j ) * ado2va ( ni , nj ) * half & + vb ( ni , i ) * vb ( nj , j ) * ado2vb ( ni , nj ) * half & - va ( ni , i ) * vb ( nj , j + 1 ) * aco12 ( ni , nj ) end do end do wrk ( i , j ) = wrk ( i , j ) + dumn end do ! 5 i = lr1 do j = lr2 + 1 , nbf dumn = 0.0_dp do ni = 1 , nbf do nj = 1 , nbf dumn = dumn + va ( nj , j ) * va ( ni , i ) * adco2a ( ni , nj ) * half & + vb ( nj , j ) * vb ( ni , i ) * adco2b ( ni , nj ) * half & + vb ( nj , j ) * va ( ni , i + 1 ) * ao21v ( ni , nj ) end do end do wrk ( i , j ) = wrk ( i , j ) + dumn end do ! 6 i = lr2 do j = lr2 + 1 , nbf dumn = 0.0_dp do ni = 1 , nbf do nj = 1 , nbf dumn = dumn + va ( nj , j ) * va ( ni , i ) * adco1a ( ni , nj ) * half & + vb ( nj , j ) * vb ( ni , i ) * adco1b ( ni , nj ) * half & - vb ( nj , j ) * va ( ni , i - 1 ) * ao21v ( ni , nj ) end do end do wrk ( i , j ) = wrk ( i , j ) + dumn end do if ( mrst == 1 ) then wrk ( lr1 , lr1 ) = ( scr ( lr1 , lr1 ) - scr ( lr2 , lr2 )) * sqrt2 wrk ( lr2 , lr2 ) = 0.0_dp else if ( mrst == 3 ) then wrk ( lr1 , lr1 ) = ( scr ( lr1 , lr1 ) + scr ( lr2 , lr2 )) * sqrt2 wrk ( lr2 , lr1 ) = 0.0_dp wrk ( lr1 , lr2 ) = 0.0_dp wrk ( lr2 , lr2 ) = 0.0_dp end if pmo (:, ivec ) = 0.0_dp if ( debug_mode ) then write ( iw , * ) 'UMRSFMNTOIA wrk(1:5,1:5)' write ( iw , * ) wrk ( 1 : 5 , 1 : 5 ) end if ij = 0 do j = nocb + 1 , nbf do i = 1 , noca ij = ij + 1 pmo ( ij , ivec ) = pmo ( ij , ivec ) + wrk ( i , j ) end do end do if ( debug_mode ) then write ( iw , * ) 'UMRSFMNTOIA' write ( iw , * ) 'Check sum = ivec' , ivec write ( iw , * ) 'Check sum = agdlr' , sum ( abs ( agdlr )) write ( iw , * ) 'Check sum = ao21v' , sum ( abs ( ao21v )) write ( iw , * ) 'Check sum = ado2vb' , sum ( abs ( ado2vb )) write ( iw , * ) 'Check sum = ado2va' , sum ( abs ( ado2va )) write ( iw , * ) 'Check sum = aco12' , sum ( abs ( aco12 )) write ( iw , * ) 'Check sum = ado1va' , sum ( abs ( ado1va )) write ( iw , * ) 'Check sum = ado1vb' , sum ( abs ( ado1vb )) write ( iw , * ) 'Check sum = adco1a' , sum ( abs ( adco1a )) write ( iw , * ) 'Check sum = adco1b' , sum ( abs ( adco1b )) write ( iw , * ) 'Check sum = adco2a' , sum ( abs ( adco2a )) write ( iw , * ) 'Check sum = adco2b' , sum ( abs ( adco2b )) write ( iw , * ) 'Check sum = pmo' , sum ( abs ( pmo (:, ivec ))) end if return end subroutine umrsfmntoia subroutine mrsfesum ( infos , wrk , fij , fab , pmo , iv ) use precision , only : dp use types , only : information use messages , only : show_message , with_abort use io_constants , only : iw implicit none type ( information ), intent ( in ) :: infos real ( kind = dp ), intent ( in ), dimension (:,:) :: & wrk , fij , fab real ( kind = dp ), intent ( inout ), dimension (:,:) :: & pmo integer , intent ( in ) :: iv real ( kind = dp ), allocatable , dimension (:,:) :: scr , tmp1 , wrk1 real ( kind = dp ) :: dumn , xlr integer :: nbf , nocca , noccb , mrst , i , ij , j , lr1 , lr2 , ok real ( kind = dp ), parameter :: sqrt2 = 1.0_dp / sqrt ( 2.0_dp ) logical :: debug_mode nbf = infos % basis % nbf nocca = infos % mol_prop % nelec_a noccb = infos % mol_prop % nelec_b mrst = infos % tddft % mult debug_mode = infos % tddft % debug_mode allocate ( scr ( nbf , nbf ), tmp1 ( nbf , nbf ), wrk1 ( nbf , nbf ), source = 0.0_dp , stat = ok ) if ( ok /= 0 ) call show_message ( 'Cannot allocate memory' , with_abort ) lr1 = nocca - 1 lr2 = nocca scr = wrk scr ( lr1 , lr1 ) = 0.0_dp scr ( lr2 , lr2 ) = 0.0_dp ! Contraction 1 call dgemm ( 'n' , 't' , nocca , nbf - noccb , nbf - noccb , & 1.0_dp , scr ( 1 , noccb + 1 ), nbf , & fab ( noccb + 1 :, noccb + 1 ), nbf , & 0.0_dp , tmp1 ( 1 , noccb + 1 ), nbf ) ! Contraction 2 call dgemm ( 'n' , 'n' , nocca , nbf - noccb , nocca , & - 1.0_dp , fij (:, 1 ), nbf , & scr (:, noccb + 1 ), nbf , & 1.0_dp , tmp1 ( 1 , noccb + 1 ), nbf ) xlr = wrk ( lr1 , lr1 ) if ( mrst == 1 ) then do j = noccb + 1 , nbf do i = 1 , nocca wrk1 ( i , j ) = wrk1 ( i , j ) + tmp1 ( i , j ) if ( i == lr1 ) wrk1 ( i , j ) = wrk1 ( i , j ) + fab ( j , lr1 ) * xlr * sqrt2 if ( i == lr2 ) wrk1 ( i , j ) = wrk1 ( i , j ) - fab ( j , lr2 ) * xlr * sqrt2 if ( j == lr1 ) wrk1 ( i , j ) = wrk1 ( i , j ) - fij ( i , lr1 ) * xlr * sqrt2 if ( j == lr2 ) wrk1 ( i , j ) = wrk1 ( i , j ) + fij ( i , lr2 ) * xlr * sqrt2 end do end do dumn = - dot_product ( fij ( lr1 , 1 : nocca ), scr ( 1 : nocca , lr1 )) & + dot_product ( fij ( lr2 , 1 : nocca ), scr ( 1 : nocca , lr2 )) & + dot_product ( fab ( lr1 , noccb + 1 : nbf ), scr ( lr1 , noccb + 1 : nbf )) & - dot_product ( fab ( lr2 , noccb + 1 : nbf ), scr ( lr2 , noccb + 1 : nbf )) wrk1 ( lr1 , lr1 ) = dumn * sqrt2 & + xlr * ( fab ( lr1 , lr1 ) + fab ( lr2 , lr2 ) & - fij ( lr1 , lr1 ) - fij ( lr2 , lr2 )) * 0.5_dp elseif ( mrst == 3 ) then do j = noccb + 1 , nbf do i = 1 , nocca wrk1 ( i , j ) = wrk1 ( i , j ) + tmp1 ( i , j ) if ( i == lr1 ) wrk1 ( i , j ) = wrk1 ( i , j ) + fab ( j , lr1 ) * xlr * sqrt2 if ( i == lr2 ) wrk1 ( i , j ) = wrk1 ( i , j ) + fab ( j , lr2 ) * xlr * sqrt2 if ( j == lr1 ) wrk1 ( i , j ) = wrk1 ( i , j ) - fij ( i , lr1 ) * xlr * sqrt2 if ( j == lr2 ) wrk1 ( i , j ) = wrk1 ( i , j ) - fij ( i , lr2 ) * xlr * sqrt2 end do end do dumn = dot_product ( - fij ( lr1 , 1 : nocca ), scr ( 1 : nocca , lr1 )) & + dot_product ( - fij ( lr2 , 1 : nocca ), scr ( 1 : nocca , lr2 )) & + dot_product ( fab ( lr1 , noccb + 1 : nbf ), scr ( lr1 , noccb + 1 : nbf )) & + dot_product ( fab ( lr2 , noccb + 1 : nbf ), scr ( lr2 , noccb + 1 : nbf )) wrk1 ( lr1 , lr1 ) = dumn * sqrt2 & + xlr * ( fab ( lr1 , lr1 ) + fab ( lr2 , lr2 ) & - fij ( lr1 , lr1 ) - fij ( lr2 , lr2 )) * 0.5_dp end if if ( mrst == 1 ) then wrk1 ( lr2 , lr2 ) = 0.0_dp else if ( mrst == 3 ) then wrk1 ( lr2 , lr1 ) = 0.0_dp wrk1 ( lr1 , lr2 ) = 0.0_dp wrk1 ( lr2 , lr2 ) = 0.0_dp end if ij = 0 do j = noccb + 1 , nbf do i = 1 , nocca ij = ij + 1 pmo ( ij , iv ) = pmo ( ij , iv ) + wrk1 ( i , j ) end do end do if ( debug_mode ) then write ( iw , * ) 'Check sum = ivec' , iv write ( iw , * ) 'Check sum = pmo' , sum ( abs ( pmo (:, iv ))) end if return end subroutine mrsfesum subroutine mrsfqroesum ( fbzzfa , pmo , noca , nocb , nbf , ivec ) use precision , only : dp implicit none real ( kind = dp ), target , intent ( in ) :: fbzzfa ( * ) real ( kind = dp ), intent ( inout ) :: pmo (:,:) integer , intent ( in ) :: noca , nocb , nbf , ivec real ( kind = dp ), pointer :: wrk (:,:) integer :: i , ij , j wrk ( 1 : nocb , 1 : nbf ) => fbzzfa ( 1 : nocb * nbf ) ij = 0 do j = noca + 1 , nbf do i = 1 , nocb ij = ij + 1 pmo ( ij , ivec ) = pmo ( ij , ivec ) + wrk ( i , j ) end do end do end subroutine mrsfqroesum subroutine get_mrsf_transitions ( trans , noca , nocb , nbf ) implicit none integer , intent ( out ), dimension (:,:) :: trans integer , intent ( in ) :: noca , nocb , nbf integer :: ij , i , j , lr1 , lr2 lr1 = nocb + 1 lr2 = noca ij = 0 do j = lr1 , nbf do i = 1 , lr2 ij = ij + 1 trans ( ij , 1 ) = i trans ( ij , 2 ) = j end do end do end subroutine get_mrsf_transitions !> @details This subroutine transforms Multi-Reference Spin-Flip (MRSF) response vectors !>          from a compressed representation to an expanded form. It handles both !>          singlet (mrst=1) and triplet (mrst=3) cases. !> !> @param[in]     infos  Information structure containing system parameters !> @param[in]     xv     Input compressed MRSF response vector !> @param[out]    xv12   Output expanded MRSF response vector !> !> @date Aug 2024 !> @author Konstantin Komarov subroutine mrsfxvec ( infos , xv , xv12 ) use precision , only : dp use types , only : information use messages , only : show_message , with_abort implicit none type ( information ), intent ( in ) :: infos real ( kind = dp ), intent ( in ), dimension (:) :: xv real ( kind = dp ), intent ( inout ), dimension (:) :: xv12 integer :: noca , nocb , nbf , mrst integer :: i , ij , ijd , ijg , ijlr1 , ijlr2 , j , xvec_dim , ok real ( kind = dp ), parameter :: sqrt2 = 1.0_dp / sqrt ( 2.0_dp ) real ( kind = dp ), allocatable , dimension (:) :: tmp nbf = infos % basis % nbf noca = infos % mol_prop % nelec_A nocb = infos % mol_prop % nelec_B mrst = infos % tddft % mult ijlr1 = ( noca - 1 - nocb - 1 ) * noca + noca - 1 ijg = ( noca - 1 - nocb - 1 ) * noca + noca ijd = ( noca - nocb - 1 ) * noca + noca - 1 ijlr2 = ( noca - nocb - 1 ) * noca + noca xvec_dim = noca * ( nbf - nocb ) allocate ( tmp ( xvec_dim ), source = 0.0_dp , stat = ok ) if ( ok /= 0 ) call show_message ( 'Cannot allocate memory' , with_abort ) if ( mrst == 1 ) then do i = 1 , noca do j = nocb + 1 , nbf ij = ( j - nocb - 1 ) * noca + i if ( ij == ijlr1 ) then tmp ( ij ) = xv ( ijlr1 ) * sqrt2 cycle else if ( ij == ijlr2 ) then tmp ( ij ) = - xv ( ijlr1 ) * sqrt2 cycle end if tmp ( ij ) = xv ( ij ) end do end do else if ( mrst == 3 ) then do i = 1 , noca do j = nocb + 1 , nbf ij = ( j - nocb - 1 ) * noca + i if ( ij == ijlr1 ) then tmp ( ij ) = xv ( ijlr1 ) * sqrt2 cycle else if ( ij == ijg ) then tmp ( ij ) = 0.0_dp cycle else if ( ij == ijd ) then tmp ( ij ) = 0.0_dp cycle else if ( ij == ijlr2 ) then tmp ( ij ) = xv ( ijlr1 ) * sqrt2 cycle end if tmp ( ij ) = xv ( ij ) end do end do end if xv12 (:) = tmp (:) return end subroutine mrsfxvec !>    @brief    Spin-pairing parts !>              of singlet and triplet MRSF Lagrangian !> subroutine mrsfsp ( xhxa , xhxb , ca , cb , xv , fmrsf , noca , nocb ) use precision , only : dp use messages , only : show_message , with_abort implicit none real ( kind = dp ), intent ( out ), dimension (:,:) :: xhxa , xhxb real ( kind = dp ), intent ( in ), dimension (:,:) :: ca , cb , xv real ( kind = dp ), intent ( in ), target , dimension (:,:,:) :: fmrsf integer , intent ( in ) :: noca , nocb integer :: nbf , i , j , lr1 , lr2 , ok real ( kind = dp ), allocatable :: scr (:,:), scr2 (:,:) real ( kind = dp ), pointer , dimension (:,:) :: & adco1 , adco2 , ado1v , ado2v , aco12 , ao21v ado2v => fmrsf ( 1 ,:,:) ado1v => fmrsf ( 2 ,:,:) adco1 => fmrsf ( 3 ,:,:) adco2 => fmrsf ( 4 ,:,:) ao21v => fmrsf ( 5 ,:,:) aco12 => fmrsf ( 6 ,:,:) nbf = ubound ( ca , 1 ) lr1 = nocb + 1 lr2 = noca allocate ( scr ( nbf , nbf ), & scr2 ( nbf , nbf ), & source = 0.0_dp , stat = ok ) if ( ok /= 0 ) call show_message ( 'Cannot allocate memory' , with_abort ) ! Spin-pairing coupling contributions of xhxa ! o1v call dgemm ( 't' , 'n' , nbf , nbf , nbf , & 1.0_dp , ca , nbf , & ao21v , nbf , & 0.0_dp , scr2 , nbf ) call dgemm ( 'n' , 'n' , nbf , nbf , nbf , & 2.0_dp , scr2 , nbf , & cb , nbf , & 0.0_dp , scr , nbf ) do j = noca + 1 , nbf xhxa (:, lr2 ) = xhxa (:, lr2 ) + scr (:, j ) * xv ( lr1 , j ) xhxa (:, lr1 ) = xhxa (:, lr1 ) - scr (:, j ) * xv ( lr2 , j ) end do ! co1 call dgemm ( 't' , 'n' , nbf , nbf , nbf , & - 1.0_dp , ca , nbf , & aco12 , nbf , & 0.0_dp , scr2 , nbf ) call dgemm ( 'n' , 'n' , nbf , nbf , nbf , & 2.0_dp , scr2 , nbf , & cb , nbf , & 0.0_dp , scr , nbf ) do i = 1 , nocb xhxa (:, i ) = xhxa (:, i ) + scr (:, lr2 ) * xv ( i , lr1 ) xhxa (:, i ) = xhxa (:, i ) - scr (:, lr1 ) * xv ( i , lr2 ) end do call dgemm ( 't' , 'n' , nbf , nbf , nbf , & 1.0_dp , ca , nbf , & adco2 , nbf , & 0.0_dp , scr2 , nbf ) call dgemm ( 'n' , 'n' , nbf , nbf , nbf , & 2.0_dp , scr2 , nbf , & cb , nbf , & 0.0_dp , scr , nbf ) do j = noca + 1 , nbf xhxa (:, lr1 ) = xhxa (:, lr1 ) + scr (:, j ) * xv ( lr1 , j ) end do call dgemm ( 't' , 'n' , nbf , nbf , nbf , & 1.0_dp , ca , nbf , & adco1 , nbf , & 0.0_dp , scr2 , nbf ) call dgemm ( 'n' , 'n' , nbf , nbf , nbf , & 2.0_dp , scr2 , nbf , & cb , nbf , & 0.0_dp , scr , nbf ) do j = noca + 1 , nbf xhxa (:, lr2 ) = xhxa (:, lr2 ) + scr (:, j ) * xv ( lr2 , j ) end do call dgemm ( 't' , 'n' , nbf , nbf , nbf , & 1.0_dp , ca , nbf , & ado2v , nbf , & 0.0_dp , scr2 , nbf ) call dgemm ( 'n' , 'n' , nbf , 1 , nbf , & 2.0_dp , scr2 , nbf , & cb (:, lr1 ), nbf , & 0.0_dp , scr , nbf ) do i = 1 , nocb xhxa (:, i ) = xhxa (:, i ) + scr (:, 1 ) * xv ( i , lr1 ) end do ! co2 call dgemm ( 't' , 'n' , nbf , nbf , nbf , & 1.0_dp , ca , nbf , & ado1v , nbf , & 0.0_dp , scr2 , nbf ) call dgemm ( 'n' , 'n' , nbf , 1 , nbf , & 2.0_dp , scr2 , nbf , & cb (:, lr2 ), nbf , & 0.0_dp , scr , nbf ) do i = 1 , nocb xhxa (:, i ) = xhxa (:, i ) + scr (:, 1 ) * xv ( i , lr2 ) end do ! Spin-pairing coupling contributions of xhxb call dgemm ( 't' , 'n' , nbf , nbf , nbf , & 1.0_dp , ca , nbf , & ao21v , nbf ,& 0.0_dp , scr2 , nbf ) call dgemm ( 'n' , 'n' , nbf , nbf , nbf , & 2.0_dp , scr2 , nbf , & cb , nbf , & 0.0_dp , scr , nbf ) do j = noca + 1 , nbf xhxb (:, j ) = xhxb (:, j ) + scr ( lr2 ,:) * xv ( lr1 , j ) end do call dgemm ( 't' , 'n' , nbf , nbf , nbf , & - 1.0_dp , ca , nbf , & ao21v , nbf , & 0.0_dp , scr2 , nbf ) call dgemm ( 'n' , 'n' , nbf , nbf , nbf , & 2.0_dp , scr2 , nbf , & cb , nbf , & 0.0_dp , scr , nbf ) do j = noca + 1 , nbf xhxb (:, j ) = xhxb (:, j ) + scr ( lr1 ,:) * xv ( lr2 , j ) end do ! co1 call dgemm ( 't' , 'n' , nbf , nbf , nbf , & - 1.0_dp , ca , nbf , & aco12 , nbf , & 0.0_dp , scr2 , nbf ) call dgemm ( 'n' , 'n' , nbf , nbf , nbf , & 2.0_dp , scr2 , nbf , & cb , nbf , & 0.0_dp , scr , nbf ) do i = 1 , nocb xhxb (:, lr2 ) = xhxb (:, lr2 ) + scr ( i ,:) * xv ( i , lr1 ) end do call dgemm ( 't' , 'n' , nbf , nbf , nbf , & 1.0_dp , ca , nbf , & aco12 , nbf , & 0.0_dp , scr2 , nbf ) call dgemm ( 'n' , 'n' , nbf , nbf , nbf , & 2.0_dp , scr2 , nbf , & cb , nbf , & 0.0_dp , scr , nbf ) do i = 1 , nocb xhxb (:, lr1 ) = xhxb (:, lr1 ) + scr ( i ,:) * xv ( i , lr2 ) end do call dgemm ( 't' , 'n' , nbf , nbf , nbf , & 1.0_dp , ca , nbf , & ado2v , nbf , & 0.0_dp , scr2 , nbf ) call dgemm ( 'n' , 'n' , nbf , nbf , nbf , & 2.0_dp , scr2 , nbf , & cb , nbf , & 0.0_dp , scr , nbf ) do i = 1 , nocb xhxb (:, lr1 ) = xhxb (:, lr1 ) + scr ( i ,:) * xv ( i , lr1 ) end do call dgemm ( 't' , 'n' , nbf , nbf , nbf , & 1.0_dp , ca , nbf , & ado1v , nbf , & 0.0_dp , scr2 , nbf ) call dgemm ( 'n' , 'n' , nbf , nbf , nbf , & 2.0_dp , scr2 , nbf , & cb , nbf , & 0.0_dp , scr , nbf ) do i = 1 , nocb xhxb (:, lr2 ) = xhxb (:, lr2 ) + scr ( i ,:) * xv ( i , lr2 ) end do ! O1V call dgemm ( 't' , 'n' , 1 , nbf , nbf , & 1.0_dp , ca (:, lr1 ), nbf , & adco2 , nbf , & 0.0_dp , scr2 , 1 ) call dgemm ( 'n' , 'n' , 1 , nbf , nbf , & 2.0_dp , scr2 , 1 , & cb , nbf , & 0.0_dp , scr , 1 ) do j = noca + 1 , nbf xhxb (:, j ) = xhxb (:, j ) + scr (:, 1 ) * xv ( lr1 , j ) end do call dgemm ( 't' , 'n' , 1 , nbf , nbf , & 1.0_dp , ca (:, lr2 ), nbf , & adco1 , nbf , & 0.0_dp , scr2 , 1 ) call dgemm ( 'n' , 'n' , 1 , nbf , nbf , & 2.0_dp , scr2 , 1 , & cb , nbf , & 0.0_dp , scr , 1 ) do j = noca + 1 , nbf xhxb (:, j ) = xhxb (:, j ) + scr (:, 1 ) * xv ( lr2 , j ) end do return end subroutine mrsfsp !>    @brief    Spin-pairing parts !>              of singlet and triplet UMRSF Lagrangian !> subroutine umrsfsp ( xhxa , xhxb , ca , cb , xv , fmrsf , noca , nocb ) use precision , only : dp use messages , only : show_message , with_abort implicit none real ( kind = dp ), intent ( out ), dimension (:,:) :: xhxa , xhxb real ( kind = dp ), intent ( in ), dimension (:,:) :: ca , cb , xv real ( kind = dp ), intent ( in ), target , dimension (:,:,:) :: fmrsf integer , intent ( in ) :: noca , nocb integer :: nbf , i , j , lr1 , lr2 , ok real ( kind = dp ), allocatable :: scr (:,:), scr2 (:,:) real ( kind = dp ), pointer , dimension (:,:) :: & adco1a , adco1b , adco2a , adco2b , ado1va , & ado1vb , ado2va , ado2vb , aco12 , ao21v ado2va => fmrsf ( 1 ,:,:) ado2vb => fmrsf ( 2 ,:,:) ado1va => fmrsf ( 3 ,:,:) ado1vb => fmrsf ( 4 ,:,:) adco1a => fmrsf ( 5 ,:,:) adco1b => fmrsf ( 6 ,:,:) adco2a => fmrsf ( 7 ,:,:) adco2b => fmrsf ( 8 ,:,:) ao21v => fmrsf ( 9 ,:,:) aco12 => fmrsf ( 10 ,:,:) nbf = ubound ( ca , 1 ) lr1 = nocb + 1 lr2 = noca allocate ( scr ( nbf , nbf ), & scr2 ( nbf , nbf ), & source = 0.0_dp , stat = ok ) if ( ok /= 0 ) call show_message ( 'Cannot allocate memory' , with_abort ) ! Spin-pairing coupling contributions of xhxa ! o1v call dgemm ( 't' , 'n' , nbf , nbf , nbf , & 1.0_dp , ca , nbf , & ao21v , nbf , & 0.0_dp , scr2 , nbf ) call dgemm ( 'n' , 'n' , nbf , nbf , nbf , & 2.0_dp , scr2 , nbf , & cb , nbf , & 0.0_dp , scr , nbf ) do j = noca + 1 , nbf xhxa (:, lr2 ) = xhxa (:, lr2 ) + scr (:, j ) * xv ( lr1 , j ) xhxa (:, lr1 ) = xhxa (:, lr1 ) - scr (:, j ) * xv ( lr2 , j ) end do ! co1 call dgemm ( 't' , 'n' , nbf , nbf , nbf , & - 1.0_dp , ca , nbf , & aco12 , nbf , & 0.0_dp , scr2 , nbf ) call dgemm ( 'n' , 'n' , nbf , nbf , nbf , & 2.0_dp , scr2 , nbf , & cb , nbf , & 0.0_dp , scr , nbf ) do i = 1 , nocb xhxa (:, i ) = xhxa (:, i ) + scr (:, lr2 ) * xv ( i , lr1 ) xhxa (:, i ) = xhxa (:, i ) - scr (:, lr1 ) * xv ( i , lr2 ) end do call dgemm ( 't' , 'n' , nbf , nbf , nbf , & 1.0_dp , ca , nbf , & adco2a , nbf , & 0.0_dp , scr2 , nbf ) call dgemm ( 'n' , 'n' , nbf , nbf , nbf , & 2.0_dp , scr2 , nbf , & cb , nbf , & 0.0_dp , scr , nbf ) do j = noca + 1 , nbf xhxa (:, lr1 ) = xhxa (:, lr1 ) + scr (:, j ) * xv ( lr1 , j ) end do call dgemm ( 't' , 'n' , nbf , nbf , nbf , & 1.0_dp , ca , nbf , & adco1a , nbf , & 0.0_dp , scr2 , nbf ) call dgemm ( 'n' , 'n' , nbf , nbf , nbf , & 2.0_dp , scr2 , nbf , & cb , nbf , & 0.0_dp , scr , nbf ) do j = noca + 1 , nbf xhxa (:, lr2 ) = xhxa (:, lr2 ) + scr (:, j ) * xv ( lr2 , j ) end do call dgemm ( 't' , 'n' , nbf , nbf , nbf , & 1.0_dp , ca , nbf , & ado2va , nbf , & 0.0_dp , scr2 , nbf ) call dgemm ( 'n' , 'n' , nbf , 1 , nbf , & 2.0_dp , scr2 , nbf , & cb (:, lr1 ), nbf , & 0.0_dp , scr , nbf ) do i = 1 , nocb xhxa (:, i ) = xhxa (:, i ) + scr (:, 1 ) * xv ( i , lr1 ) end do ! co2 call dgemm ( 't' , 'n' , nbf , nbf , nbf , & 1.0_dp , ca , nbf , & ado1va , nbf , & 0.0_dp , scr2 , nbf ) call dgemm ( 'n' , 'n' , nbf , 1 , nbf , & 2.0_dp , scr2 , nbf , & cb (:, lr2 ), nbf , & 0.0_dp , scr , nbf ) do i = 1 , nocb xhxa (:, i ) = xhxa (:, i ) + scr (:, 1 ) * xv ( i , lr2 ) end do ! Spin-pairing coupling contributions of xhxb call dgemm ( 't' , 'n' , nbf , nbf , nbf , & 1.0_dp , ca , nbf , & ao21v , nbf ,& 0.0_dp , scr2 , nbf ) call dgemm ( 'n' , 'n' , nbf , nbf , nbf , & 2.0_dp , scr2 , nbf , & cb , nbf , & 0.0_dp , scr , nbf ) do j = noca + 1 , nbf xhxb (:, j ) = xhxb (:, j ) + scr ( lr2 ,:) * xv ( lr1 , j ) end do call dgemm ( 't' , 'n' , nbf , nbf , nbf , & - 1.0_dp , ca , nbf , & ao21v , nbf , & 0.0_dp , scr2 , nbf ) call dgemm ( 'n' , 'n' , nbf , nbf , nbf , & 2.0_dp , scr2 , nbf , & cb , nbf , & 0.0_dp , scr , nbf ) do j = noca + 1 , nbf xhxb (:, j ) = xhxb (:, j ) + scr ( lr1 ,:) * xv ( lr2 , j ) end do ! co1 call dgemm ( 't' , 'n' , nbf , nbf , nbf , & - 1.0_dp , ca , nbf , & aco12 , nbf , & 0.0_dp , scr2 , nbf ) call dgemm ( 'n' , 'n' , nbf , nbf , nbf , & 2.0_dp , scr2 , nbf , & cb , nbf , & 0.0_dp , scr , nbf ) do i = 1 , nocb xhxb (:, lr2 ) = xhxb (:, lr2 ) + scr ( i ,:) * xv ( i , lr1 ) end do call dgemm ( 't' , 'n' , nbf , nbf , nbf , & 1.0_dp , ca , nbf , & aco12 , nbf , & 0.0_dp , scr2 , nbf ) call dgemm ( 'n' , 'n' , nbf , nbf , nbf , & 2.0_dp , scr2 , nbf , & cb , nbf , & 0.0_dp , scr , nbf ) do i = 1 , nocb xhxb (:, lr1 ) = xhxb (:, lr1 ) + scr ( i ,:) * xv ( i , lr2 ) end do call dgemm ( 't' , 'n' , nbf , nbf , nbf , & 1.0_dp , ca , nbf , & ado2vb , nbf , & 0.0_dp , scr2 , nbf ) call dgemm ( 'n' , 'n' , nbf , nbf , nbf , & 2.0_dp , scr2 , nbf , & cb , nbf , & 0.0_dp , scr , nbf ) do i = 1 , nocb xhxb (:, lr1 ) = xhxb (:, lr1 ) + scr ( i ,:) * xv ( i , lr1 ) end do call dgemm ( 't' , 'n' , nbf , nbf , nbf , & 1.0_dp , ca , nbf , & ado1vb , nbf , & 0.0_dp , scr2 , nbf ) call dgemm ( 'n' , 'n' , nbf , nbf , nbf , & 2.0_dp , scr2 , nbf , & cb , nbf , & 0.0_dp , scr , nbf ) do i = 1 , nocb xhxb (:, lr2 ) = xhxb (:, lr2 ) + scr ( i ,:) * xv ( i , lr2 ) end do ! O1V call dgemm ( 't' , 'n' , 1 , nbf , nbf , & 1.0_dp , ca (:, lr1 ), nbf , & adco2b , nbf , & 0.0_dp , scr2 , 1 ) call dgemm ( 'n' , 'n' , 1 , nbf , nbf , & 2.0_dp , scr2 , 1 , & cb , nbf , & 0.0_dp , scr , 1 ) do j = noca + 1 , nbf xhxb (:, j ) = xhxb (:, j ) + scr (:, 1 ) * xv ( lr1 , j ) end do call dgemm ( 't' , 'n' , 1 , nbf , nbf , & 1.0_dp , ca (:, lr2 ), nbf , & adco1b , nbf , & 0.0_dp , scr2 , 1 ) call dgemm ( 'n' , 'n' , 1 , nbf , nbf , & 2.0_dp , scr2 , 1 , & cb , nbf , & 0.0_dp , scr , 1 ) do j = noca + 1 , nbf xhxb (:, j ) = xhxb (:, j ) + scr (:, 1 ) * xv ( lr2 , j ) end do return end subroutine umrsfsp subroutine mrsfrowcal ( wmo , mo_energy_a , fa , fb , xk , & xhxa , xhxb , hppija , hppijb , noca , nocb ) use precision , only : dp implicit none real ( kind = dp ), intent ( out ), dimension (:,:) :: wmo real ( kind = dp ), intent ( in ), dimension (:) :: mo_energy_a real ( kind = dp ), intent ( in ), dimension (:,:) :: fa , fb real ( kind = dp ), intent ( in ), dimension (:) :: xk real ( kind = dp ), intent ( in ), dimension (:,:) :: xhxa , xhxb real ( kind = dp ), intent ( in ), dimension (:,:) :: hppija , hppijb integer , intent ( in ) :: noca , nocb real ( kind = dp ), allocatable , dimension (:,:) :: wrk , scr integer :: i , a , k , x , y , j , b , ij , nbf , lr1 , lr2 nbf = ubound ( fa , 1 ) lr1 = nocb + 1 lr2 = noca allocate ( wrk ( nbf , nbf ), & scr ( nbf , nbf ), & source = 0.0_dp ) ! Unpack  xk ij = 0 do i = lr1 , lr2 do j = 1 , nocb ij = ij + 1 scr ( j , i ) = xk ( ij ) end do end do do i = noca + 1 , nbf do j = 1 , nocb ij = ij + 1 scr ( j , i ) = xk ( ij ) end do end do do k = noca + 1 , nbf do i = lr1 , lr2 ij = ij + 1 scr ( i , k ) = xk ( ij ) end do end do ! W_ix do x = 1 , nocb do k = 1 , nocb wrk ( x , 1 : 2 ) = wrk ( x , 1 : 2 ) - fa ( k , x ) * scr ( k , lr1 : lr2 ) end do end do do x = 1 , nocb do k = 1 , nbf - noca wrk ( x , 1 : 2 ) = wrk ( x , 1 : 2 ) + scr ( lr1 : lr2 , noca + k ) * fa ( noca + k , x ) end do end do wmo ( 1 : nocb , lr1 : lr2 ) = wrk ( 1 : nocb , 1 : 2 ) * 0.5_dp & + xhxa ( 1 : nocb , lr1 : lr2 ) & + xhxb ( 1 : nocb , lr1 : lr2 ) & + hppija ( 1 : nocb , lr1 : lr2 ) wmo ( 1 : nocb , lr1 ) = wmo ( 1 : nocb , lr1 ) & + mo_energy_a ( 1 : nocb ) * scr ( 1 : nocb , lr1 ) wmo ( 1 : nocb , lr2 ) = wmo ( 1 : nocb , lr2 ) & + mo_energy_a ( 1 : nocb ) * scr ( 1 : nocb , lr2 ) !   ----- W_IA ----- wrk = 0.0_dp do i = 1 , nocb do a = 1 , nbf - noca wrk ( i , a ) = wrk ( i , a ) + fa ( lr1 , i ) * scr ( lr1 , noca + a ) & + fa ( lr2 , i ) * scr ( lr2 , noca + a ) end do end do wmo ( 1 : nocb , noca + 1 : nbf ) = wrk ( 1 : nocb , 1 : nbf - noca ) * 0.5_dp & + xhxb ( 1 : nocb , noca + 1 : nbf ) do a = 1 , nbf - noca wmo ( 1 : nocb , noca + a ) = wmo ( 1 : nocb , noca + a ) & + mo_energy_a ( 1 : nocb ) * scr ( 1 : nocb , noca + a ) end do !   ----- W_XA ----- wrk = 0.0_dp do a = 1 , nbf - noca do k = 1 , nocb wrk ( 1 , a ) = wrk ( 1 , a ) + fa ( k , lr1 ) * scr ( k , noca + a ) wrk ( 2 , a ) = wrk ( 2 , a ) + fa ( k , lr2 ) * scr ( k , noca + a ) end do end do do a = 1 , nbf - noca wrk ( 1 , a ) = wrk ( 1 , a ) - fb ( lr1 , lr1 ) * scr ( lr1 , noca + a ) & - fb ( lr2 , lr1 ) * scr ( lr2 , noca + a ) wrk ( 2 , a ) = wrk ( 2 , a ) - fb ( lr1 , lr2 ) * scr ( lr1 , noca + a ) & - fb ( lr2 , lr2 ) * scr ( lr2 , noca + a ) end do wmo ( lr1 : lr2 , noca + 1 : nbf ) = wrk ( 1 : 2 , 1 : nbf - noca ) * 0.5_dp & + xhxb ( lr1 : lr2 , noca + 1 : nbf ) do a = noca + 1 , nbf wmo ( lr1 : lr2 , a ) = wmo ( lr1 : lr2 , a ) & + mo_energy_a ( lr1 : lr2 ) * scr ( lr1 : lr2 , a ) end do !  W_ij do i = 1 , nocb do j = 1 , i wmo ( i , j ) = hppija ( i , j ) + hppijb ( i , j ) + xhxa ( j , i ) end do end do ! W_xy do x = nocb + 1 , noca do y = nocb + 1 , x wmo ( x , y ) = xhxa ( y , x ) + xhxb ( y , x ) + hppija ( x , y ) end do end do ! W_ab do a = noca + 1 , nbf do b = noca + 1 , a wmo ( a , b ) = xhxb ( b , a ) end do end do ! Scale diagonal elements do i = 1 , nbf wmo ( i , i ) = wmo ( i , i ) * 0.5_dp end do wmo = - wmo return end subroutine mrsfrowcal subroutine mrsfqrorhs ( rhs , xhxa , xhxb , hpta , hptb , tab , tij , fa , fb , noca , & nocb ) use precision , only : dp implicit none real ( kind = dp ), intent ( out ), dimension (:) :: rhs real ( kind = dp ), intent ( inout ), dimension (:,:) :: xhxa , xhxb real ( kind = dp ), intent ( in ), dimension (:,:) :: hpta real ( kind = dp ), intent ( in ), dimension (:,:) :: hptb real ( kind = dp ), intent ( in ), dimension (:,:) :: tij real ( kind = dp ), intent ( in ), dimension (:,:) :: tab real ( kind = dp ), intent ( in ), dimension (:,:) :: fa , fb integer , intent ( in ) :: noca , nocb real ( kind = dp ), allocatable , dimension (:,:) :: scr integer :: nbf , i , j , ij , a , x , nconf nbf = ubound ( fa , 1 ) allocate ( scr ( nbf , nbf ), & source = 0.0_dp ) ! Alpha ! hxa+= 2*fa(p+,a+)*ta(a+,b+) do j = noca + 1 , nbf do i = noca + 1 , nbf scr ( i , j ) = tab ( i - noca , j - noca ) end do end do call dgemm ( 'n' , 'n' , nbf , nbf , nbf , & 2.0_dp , fa , nbf , & scr , nbf , & 1.0_dp , xhxa , nbf ) ! Beta ! xhxb+= 2*fb(p-, i-)*tb(i-, j-) call dgemm ( 'n' , 'n' , nbf , nocb , nocb , & 2.0_dp , fb , nbf , & tij , nocb , & 1.0_dp , xhxb , nbf ) rhs = 0.0_dp ! doc-socc ij = 0 do x = nocb + 1 , noca do i = 1 , nocb ij = ij + 1 rhs ( ij ) = hptb ( i , x - nocb ) + xhxb ( x , i ) end do end do ! doc-virt do a = noca + 1 , nbf do i = 1 , nocb ij = ij + 1 rhs ( ij ) = hpta ( i , a - noca ) + hptb ( i , a - nocb ) & + xhxb ( a , i ) - xhxa ( i , a ) end do end do ! soc-virt do a = noca + 1 , nbf do x = nocb + 1 , noca ij = ij + 1 rhs ( ij ) = hpta ( x , a - noca ) - xhxa ( x , a ) end do end do nconf = ij rhs ( 1 : nconf ) = - rhs ( 1 : nconf ) return end subroutine mrsfqrorhs subroutine mrsfqropcal ( pa , pb , tab , tij , z , noca , nocb ) use precision , only : dp implicit none real ( kind = dp ), intent ( out ), dimension (:,:) :: pa , pb real ( kind = dp ), intent ( in ), dimension (:,:) :: tab , tij real ( kind = dp ), intent ( in ), dimension (:) :: z integer , intent ( in ) :: noca , nocb integer :: nbf , i , j , a , x , ij nbf = ubound ( pa , 1 ) ! alpha pa = 0.0_dp do j = noca + 1 , nbf do i = noca + 1 , nbf pa ( i , j ) = tab ( i - noca , j - noca ) end do end do ! beta pb = 0.0_dp do j = 1 , nocb do i = 1 , nocb pb ( i , j ) = tij ( i , j ) end do end do ! doc-socc ij = 0 do x = nocb + 1 , noca do i = 1 , nocb ij = ij + 1 pb ( i , x ) = pb ( i , x ) + z ( ij ) * 0.5_dp end do end do ! doc-virt do a = noca + 1 , nbf do i = 1 , nocb ij = ij + 1 pa ( i , a ) = pa ( i , a ) + z ( ij ) * 0.5_dp pb ( i , a ) = pb ( i , a ) + z ( ij ) * 0.5_dp end do end do ! socc-virt do a = noca + 1 , nbf do x = nocb + 1 , noca ij = ij + 1 pa ( x , a ) = pa ( x , a ) + z ( ij ) * 0.5_dp end do end do return end subroutine mrsfqropcal subroutine mrsfqrowcal ( w , mo_energy_a , fa , fb , z , & xhxa , xhxb , hppija , hppijb , noca , nocb ) use precision , only : dp implicit none real ( kind = dp ), intent ( out ), dimension (:,:) :: w real ( kind = dp ), intent ( in ), dimension (:) :: mo_energy_a real ( kind = dp ), intent ( in ), dimension (:,:) :: fa , fb real ( kind = dp ), intent ( in ), dimension (:) :: z real ( kind = dp ), intent ( in ), dimension (:,:) :: xhxa , xhxb real ( kind = dp ), intent ( in ), dimension (:,:) :: hppija , hppijb integer , intent ( in ) :: noca , nocb real ( kind = dp ), allocatable , dimension (:,:) :: scr , wrk integer :: i , a , k , x , y , j , b , ij , nbf , lr1 , lr2 nbf = ubound ( fa , 1 ) lr1 = nocb + 1 lr2 = noca allocate ( wrk ( nbf , nbf ), & scr ( nbf , nbf ), & source = 0.0_dp ) ij = 0 do x = nocb + 1 , noca do i = 1 , nocb ij = ij + 1 scr ( i , x ) = z ( ij ) end do end do do a = noca + 1 , nbf do i = 1 , nocb ij = ij + 1 scr ( i , a ) = z ( ij ) end do end do do a = noca + 1 , nbf do x = nocb + 1 , noca ij = ij + 1 scr ( x , a ) = z ( ij ) end do end do ! w_ix do i = 1 , nocb do k = 1 , nocb wrk ( i , 1 : 2 ) = wrk ( i , 1 : 2 ) - fa ( k , i ) * scr ( k , lr1 : lr2 ) end do end do do i = 1 , nocb do y = 1 , nbf - noca wrk ( i , 1 : 2 ) = wrk ( i , 1 : 2 ) + fa ( noca + y , i ) * scr ( lr1 : lr2 , noca + y ) end do end do w ( 1 : nocb , lr1 : lr2 ) = 0.5_dp * wrk ( 1 : nocb , 1 : 2 ) + hppija ( 1 : nocb , lr1 : lr2 ) do i = 1 , nocb w ( i , lr1 : lr2 ) = w ( i , lr1 : lr2 ) & + mo_energy_a ( i ) * scr ( i , lr1 : lr2 ) end do ! w_ia wrk = 0.0_dp do a = 1 , nbf - noca do i = 1 , nocb wrk ( i , a ) = wrk ( i , a ) + fa ( lr1 , i ) * scr ( lr1 , noca + a ) wrk ( i , a ) = wrk ( i , a ) + fa ( lr2 , i ) * scr ( lr2 , noca + a ) end do end do do a = 1 , nbf - noca w ( 1 : nocb , noca + a ) = mo_energy_a ( 1 : nocb ) * scr ( 1 : nocb , noca + a ) & + 0.5_dp * wrk ( 1 : nocb , a ) & + xhxa ( 1 : nocb , noca + a ) end do ! w_xa wrk = 0.0_dp do a = 1 , nbf - noca do k = 1 , nocb wrk ( 1 : 2 , a ) = wrk ( 1 : 2 , a ) + fa ( k , lr1 : lr2 ) * scr ( k , noca + a ) end do end do do a = 1 , nbf - noca wrk ( 1 : 2 , a ) = wrk ( 1 : 2 , a ) - fb ( lr1 , lr1 : lr2 ) * scr ( lr1 , noca + a ) wrk ( 1 : 2 , a ) = wrk ( 1 : 2 , a ) - fb ( lr2 , lr1 : lr2 ) * scr ( lr2 , noca + a ) end do do a = 1 , nbf - noca w ( lr1 : lr2 , noca + a ) = mo_energy_a ( lr1 : lr2 ) * scr ( lr1 : lr2 , noca + a ) & + 0.5_dp * wrk ( 1 : 2 , a ) & + xhxa ( lr1 : lr2 , noca + a ) end do ! w_ij do i = 1 , nocb do j = 1 , i w ( i , j ) = hppija ( i , j ) + hppijb ( i , j ) + xhxb ( j , i ) end do end do ! w_xy do x = nocb + 1 , noca do y = nocb + 1 , x w ( x , y ) = hppija ( x , y ) end do end do ! w_ab do a = noca + 1 , nbf do b = noca + 1 , a w ( a , b ) = xhxa ( b , a ) end do end do ! scale diagonal elements do i = 1 , nbf w ( i , i ) = 0.5_dp * w ( i , i ) end do w = - w return end subroutine mrsfqrowcal subroutine get_mrsf_transition_density ( infos , trden , bvec_mo , ist , jst ) use precision , only : dp use messages , only : show_message , with_abort use types , only : information implicit none type ( information ), intent ( in ) :: infos real ( kind = dp ), intent ( out ), dimension (:,:) :: trden real ( kind = dp ), intent ( in ), dimension (:,:) :: bvec_mo integer , intent ( in ) :: ist , jst real ( kind = dp ), allocatable :: xv12i (:,:), xv12j (:,:) integer :: nbf , noca , nocb , nvirb , ok integer :: i , ij , ijd , ijg , ijlr1 , ijlr2 , j , mrst real ( kind = dp ), parameter :: rsqrt = 1.0_dp / sqrt ( 2.0_dp ) nbf = infos % basis % nbf noca = infos % mol_prop % nelec_a mrst = infos % tddft % mult nocb = noca - 2 nvirb = nbf - nocb allocate ( xv12i ( noca , nvirb ), & xv12j ( noca , nvirb ), & source = 0.0_dp , stat = ok ) if ( ok /= 0 ) call show_message ( 'Cannot allocate memory' , with_abort ) ijlr1 = ( noca - 1 - nocb - 1 ) * noca + noca - 1 ijg = ( noca - 1 - nocb - 1 ) * noca + noca ijd = ( noca - nocb - 1 ) * noca + noca - 1 ijlr2 = ( noca - nocb - 1 ) * noca + noca if ( mrst == 1 ) then do i = 1 , noca do j = nocb + 1 , nbf ij = ( j - nocb - 1 ) * noca + i if ( ij == ijlr1 ) then xv12j ( i , j - nocb ) = bvec_mo ( ijlr1 , jst ) * rsqrt xv12i ( i , j - nocb ) = bvec_mo ( ijlr1 , ist ) * rsqrt cycle else if ( ij == ijlr2 ) then xv12j ( i , j - nocb ) = - bvec_mo ( ijlr1 , jst ) * rsqrt xv12i ( i , j - nocb ) = - bvec_mo ( ijlr1 , ist ) * rsqrt cycle end if xv12j ( i , j - nocb ) = bvec_mo ( ij , jst ) xv12i ( i , j - nocb ) = bvec_mo ( ij , ist ) end do end do else if ( mrst == 3 ) then do i = 1 , noca do j = nocb + 1 , nbf ij = ( j - nocb - 1 ) * noca + i if ( ij == ijlr1 ) then xv12j ( i , j - nocb ) = bvec_mo ( ijlr1 , jst ) * rsqrt xv12i ( i , j - nocb ) = bvec_mo ( ijlr1 , ist ) * rsqrt cycle else if ( ij == ijlr2 ) then xv12j ( i , j - nocb ) = bvec_mo ( ijlr1 , jst ) * rsqrt xv12i ( i , j - nocb ) = bvec_mo ( ijlr1 , ist ) * rsqrt cycle else if ( ij == ijg ) then xv12j ( i , j - nocb ) = 0.0_dp xv12i ( i , j - nocb ) = 0.0_dp cycle else if ( ij == ijd ) then xv12j ( i , j - nocb ) = 0.0_dp xv12i ( i , j - nocb ) = 0.0_dp cycle end if xv12j ( i , j - nocb ) = bvec_mo ( ij , jst ) xv12i ( i , j - nocb ) = bvec_mo ( ij , ist ) end do end do end if call get_trans_den ( trden , xv12i , xv12j , noca , nocb , nvirb ) return end subroutine get_mrsf_transition_density subroutine get_trans_den ( trden , xv12i , xv12j , noca , nocb , nvirb ) use precision , only : dp implicit none real ( kind = dp ), intent ( out ), dimension (:,:) :: trden real ( kind = dp ), intent ( in ), dimension (:,:) :: xv12i , xv12j integer , intent ( in ) :: noca , nocb , nvirb logical :: ioo , joo integer :: i , j , k real ( kind = dp ) :: tmp , scal real ( kind = dp ), parameter :: sqrt2 = sqrt ( 2.0_dp ) ! Revised trden(vir/vir) do i = 1 , nvirb do j = 1 , nvirb tmp = 0.0_dp do k = 1 , noca ioo = . false . joo = . false . if (( i == 1 . or . i == 2 ) . and . ( k == noca - 1 . or . k == noca )) ioo = . true . if (( j == 1 . or . j == 2 ) . and . ( k == noca - 1 . or . k == noca )) joo = . true . scal = 1.0_dp if ( ioo . and . . not . joo ) scal = sqrt2 if (. not . ioo . and . joo ) scal = sqrt2 tmp = tmp + scal * xv12j ( k , i ) * xv12i ( k , j ) end do trden ( i + nocb , j + nocb ) = trden ( i + nocb , j + nocb ) + tmp end do end do ! Revised trden(occ/occ) do i = 1 , noca do j = 1 , noca tmp = 0.0_dp do k = 1 , nvirb ioo = . false . joo = . false . if (( i == noca - 1 . or . i == noca ) . and . ( k == 1 . or . k == 2 )) ioo = . true . if (( j == noca - 1 . or . j == noca ) . and . ( k == 1 . or . k == 2 )) joo = . true . scal = 1.0_dp if ( ioo . and . . not . joo ) scal = sqrt2 if (. not . ioo . and . joo ) scal = sqrt2 tmp = tmp + scal * xv12j ( j , k ) * xv12i ( i , k ) end do trden ( i , j ) = trden ( i , j ) - tmp end do end do ! Trden(occ/vir) elements are zero return end subroutine !############################################################################### !> @brief Jacobi pair-rotations of MOs based on off-diagonal elements !>        of the alpha/beta MO overlap matrix s_mo !> @author Vladimir Yu. Makhnev !> @date October 2025 subroutine get_jacobi ( infos , mo_a , mo_energy_a , mo_b , mo_energy_b , & smat_full , nocca , work , s_mo , isegm ) use precision , only : dp use io_constants , only : iw use types , only : information use messages , only : show_message , with_abort implicit none type ( information ), intent ( in ) :: infos real ( kind = dp ), intent ( inout ), dimension (:,:) :: mo_a , mo_b real ( kind = dp ), intent ( in ), dimension (:) :: mo_energy_a , mo_energy_b real ( kind = dp ), intent ( in ), dimension (:,:) :: smat_full integer , intent ( in ) :: nocca , isegm real ( kind = dp ), intent ( inout ), dimension (:,:) :: s_mo real ( kind = dp ), intent ( inout ), dimension (:,:) :: work integer :: i , nbf , nmo integer :: p_start , p_end , q_start integer :: p , q , iterj integer :: max_iter , i_max , j_max real ( kind = dp ) :: thresh real ( kind = dp ) :: max_off real ( kind = dp ), parameter :: go2ev = 2 7.211386245988d+00 logical :: dgprint logical :: if_conv dgprint = infos % tddft % debug_mode if_conv = . false . thresh = 1 d - 3 nbf = size ( mo_a , 1 ) nmo = size ( mo_a , 2 ) write ( iw , '(A)' ) '                    ++++++++++++++++++++++++++++++++++++++++' write ( iw , '(A)' ) '                       UMRSF-TDDFT: Jacobi rotation of MOs' write ( iw , '(A)' ) '                    ++++++++++++++++++++++++++++++++++++++++' write ( iw , '(A)' ) '' ! Calculate overlap between alpha and beta MOs: s_mo = mo_a&#94;T * smat_full * mo_b call dgemm ( 't' , 'n' , nbf , nbf , nbf , 1.0_dp , mo_a , nbf , smat_full , nbf , 0.0_dp , work , nbf ) call dgemm ( 'n' , 'n' , nbf , nbf , nbf , 1.0_dp , work , nbf , mo_b , nbf , 0.0_dp , s_mo , nbf ) ! Normalize columns to ensure proper comparison do i = 1 , nbf s_mo (:, i ) = s_mo (:, i ) / max ( norm2 ( s_mo (:, i )), 1.0e-10_dp ) end do if ( dgprint ) then write ( iw , '(A)' ) '-----------------------------------------' write ( iw , '(A)' ) 'Diagonal elements of overlap matrix (BEFORE ROTATIONS)' write ( iw , '(A)' ) '-----------------------------------------' write ( iw , '(A)' ) '# orb.      A_i, eV  B_i, eV   A_i × B_i Overlap' write ( iw , '(A)' ) '-----------------------------------------' do i = 1 , nmo write ( iw , '(I5,3F12.6)' ) i , mo_energy_a ( i ) * go2ev , mo_energy_b ( i ) * go2ev , s_mo ( i , i ) end do write ( iw , '(A)' ) '-----------------------------------------' write ( iw , '(A)' ) '' end if if ( isegm == 0 ) then p_start = nocca - 1 p_end = 2 q_start = 1 max_iter = 10000 else if ( isegm == 1 ) then p_start = nmo p_end = nocca + 1 q_start = nocca max_iter = 10000 else call show_message ( 'get_jacobi: invalid isegm' , with_abort ) end if do iterj = 1 , max_iter max_off = 0.0d0 i_max = - 1 j_max = - 1 do p = p_start , p_end , - 1 do q = q_start , p - 1 if ( abs ( s_mo ( p , q )) > max_off ) then max_off = abs ( s_mo ( p , q )) i_max = p j_max = q end if if ( abs ( s_mo ( q , p )) > max_off ) then max_off = abs ( s_mo ( q , p )) i_max = q j_max = p end if end do end do if ( dgprint ) write ( iw , * ) \"max_off\" , max_off , i_max , j_max if ( max_off <= thresh ) then write ( iw , '(\"segment \",I1,\" converged at iter \",I0)' ) isegm , iterj call flush ( iw ) exit else if ( if_conv ) then write ( iw , '(\"segment \",I1,\" reached the min theta at iter \",I0)' ) isegm , iterj call flush ( iw ) exit end if call rotate_pair ( mo_a , mo_b , smat_full , s_mo , nmo , nbf , isegm , i_max , j_max , if_conv ) end do if ( dgprint ) then write ( iw , '(A)' ) '-----------------------------------------' write ( iw , '(A)' ) 'Diagonal elements of overlap matrix (AFTER ROTATIONS)' write ( iw , '(A)' ) '-----------------------------------------' write ( iw , '(A)' ) '# orb.      A_i, eV  B_i, eV   A_i × B_i Overlap' write ( iw , '(A)' ) '-----------------------------------------' do i = 1 , nmo write ( iw , '(I5,3F12.6)' ) i , mo_energy_a ( i ) * go2ev , mo_energy_b ( i ) * go2ev , s_mo ( i , i ) end do write ( iw , '(A)' ) '-----------------------------------------' end if call check_sign ( mo_a , mo_b , smat_full , s_mo , nmo , nbf ) if ( dgprint ) then write ( iw , '(A)' ) '-----------------------------------------' write ( iw , '(A)' ) 'Diagonal elements of overlap matrix (FINAL/SIGN FIXED)' write ( iw , '(A)' ) '-----------------------------------------' write ( iw , '(A)' ) '# orb.      A_i, eV  B_i, eV   A_i × B_i Overlap' write ( iw , '(A)' ) '-----------------------------------------' do i = 1 , nmo write ( iw , '(I5,3F12.6)' ) i , mo_energy_a ( i ) * go2ev , mo_energy_b ( i ) * go2ev , s_mo ( i , i ) end do write ( iw , '(A)' ) '-----------------------------------------' end if return end subroutine get_jacobi !############################################################################### !> Single Jacobi rotation of the MO pair (i_idx, j_idx) chosen by get_jacobi subroutine rotate_pair ( mo_a , mo_b , smat , s_mo , nbf , norb , isegm , i_idx , j_idx , if_conv ) implicit none logical , intent ( inout ) :: if_conv integer , intent ( in ) :: nbf , norb , isegm , i_idx , j_idx real ( kind = dp ), intent ( inout ) :: mo_a ( nbf , * ), mo_b ( nbf , * ) real ( kind = dp ), intent ( in ) :: smat ( * ) real ( kind = dp ), intent ( inout ) :: s_mo ( norb , * ) real ( kind = dp ) :: tht real ( kind = dp ) :: aa , bb , cc , dd , att , btt , cth , sth aa = s_mo ( i_idx , i_idx ) bb = s_mo ( j_idx , j_idx ) cc = s_mo ( i_idx , j_idx ) dd = s_mo ( j_idx , i_idx ) att = 0.5d0 * ( aa * aa + bb * bb - cc * cc - dd * dd ) if ( isegm == 0 ) then btt = aa * dd - bb * cc else if ( isegm == 1 ) then btt = aa * cc - bb * dd end if tht = 0.5d0 * atan2 ( btt , att ) if ( abs ( tht ) < 1.0d-4 ) then if_conv = . true . return end if cth = cos ( tht ) sth = sin ( tht ) if ( isegm == 0 ) then call drot ( nbf , mo_a ( 1 , i_idx ), 1 , mo_a ( 1 , j_idx ), 1 , cth , sth ) call drot ( norb , s_mo ( i_idx , 1 ), norb , s_mo ( j_idx , 1 ), norb , cth , sth ) else call drot ( nbf , mo_b ( 1 , i_idx ), 1 , mo_b ( 1 , j_idx ), 1 , cth , sth ) call drot ( norb , s_mo ( 1 , i_idx ), 1 , s_mo ( 1 , j_idx ), 1 , cth , sth ) end if end subroutine rotate_pair !############################################################################### !> Flip the sign of MO column swa (alpha for isegm=0, beta otherwise) subroutine swap_sign_a ( mo_a , mo_b , nbf , norb , swa , isegm ) implicit none real ( kind = dp ), intent ( inout ), dimension ( nbf , * ) :: mo_a , mo_b integer , intent ( in ) :: nbf , norb , swa , isegm integer :: i if ( isegm == 0 ) then do i = 1 , nbf mo_a ( i , swa ) = - mo_a ( i , swa ) end do else do i = 1 , nbf mo_b ( i , swa ) = - mo_b ( i , swa ) end do end if end subroutine swap_sign_a !############################################################################### !> Fix beta MO signs so the diagonal alpha/beta overlaps are non-negative, !> then recompute s_mo subroutine check_sign ( mo_a , mo_b , smat , s_mo , nbf , norb ) implicit none integer , intent ( in ) :: nbf , norb real ( kind = dp ), intent ( inout ) :: mo_a ( nbf , * ), mo_b ( nbf , * ) real ( kind = dp ), intent ( in ) :: smat ( * ) real ( kind = dp ), intent ( inout ) :: s_mo ( norb , * ) integer :: i real ( kind = dp ), allocatable :: sq (:,:) do i = 1 , norb if ( s_mo ( i , i ) < 0.0d0 ) then call swap_sign_a ( mo_a , mo_b , nbf , norb , i , 1 ) end if end do allocate ( sq ( nbf , nbf )) call dgemm ( 't' , 'n' , nbf , nbf , nbf , 1.0d0 , mo_a , nbf , smat , nbf , 0.0d0 , sq , nbf ) call dgemm ( 'n' , 'n' , nbf , nbf , nbf , 1.0d0 , sq , nbf , mo_b , nbf , 0.0d0 , s_mo , nbf ) deallocate ( sq ) end subroutine check_sign !############################################################################### !> Compute the <S&#94;2> expectation value of a UMRSF-TDDFT response state !> !> UMRSF analogue of the MRSF spin-square evaluation: accumulates <S&#94;2> !> for state js from the response amplitudes bvec_mo and the diagonal !> alpha/beta MO overlaps, for singlet (mrsfs) or triplet (mrsft) targets. !> subroutine umrsfssqu ( ss , mo_a , mo_b , smat , wrk1 , wrk2 , nbf , nbf2 , xvec_dim , js , & norb , bvec_mo , nocca , noccb , mrsfs , mrsft ) use mathlib , only : unpack_f90 use precision , only : dp implicit none logical , intent ( in ) :: mrsfs , mrsft integer :: i , j , js , nocca , noccb , nbf , nbf2 , xvec_dim , norb real ( kind = dp ), intent ( in ), dimension (:,:) :: mo_a , mo_b real ( kind = dp ), intent ( in ), dimension (:) :: smat real ( kind = dp ), intent ( inout ), dimension (:,:) :: wrk1 real ( kind = dp ), intent ( inout ), dimension (:) :: wrk2 real ( kind = dp ), intent ( in ), dimension ( nocca , norb - noccb , * ) :: bvec_mo real ( kind = dp ), intent ( out ) :: ss real ( kind = dp ), parameter :: half = 0.5d+00 real ( kind = dp ), parameter :: tol = 1.0d-12 real ( kind = dp ) :: a , b , c , dum , f call unpack_f90 ( smat , wrk1 , 'u' ) ! Precalculation of diagonal alpha/beta MO overlaps a = 0 b = 1 c = 0 do i = 1 , nocca dum = dot_product ( mo_a (:, i ), matmul ( wrk1 , mo_b (:, i )) ) wrk2 ( i ) = dum if ( i > noccb ) then cycle else a = a + dum * dum b = b * dum * dum c = c + ( 1.0_dp / max (( dum * dum ), tol )) end if end do f = 1 if ( mrsfs ) then ! Singlet spin quantum number ss = 0 do i = 1 , nocca do j = 1 , norb - noccb ! cv if (( j > 2 ). and .( i <= noccb )) then ss = ss + ( nocca - 1 - a + ( wrk2 ( i )) ** 2 - b / & ( max ( abs ( wrk2 ( i )), tol )) ** 2 ) * ( bvec_mo ( i , j , js )) ** 2 ! co else if ( i <= noccb ) then ss = ss + ( nocca - 1 - a + ( wrk2 ( i )) ** 2 - ( wrk2 ( j + noccb )) ** 2 & - b * (( wrk2 ( j + noccb )) / max ( abs ( wrk2 ( i )), tol )) ** 2 ) & * ( bvec_mo ( i , j , js )) ** 2 ! ov, os else if (( j > 2 ) . or . ( i == noccb + j )) then ss = ss + ( nocca - 1 - a - b ) * ( bvec_mo ( i , j , js )) ** 2 ! g, d else ss = ss + half * ( nocca - 1 - a - ( wrk2 ( noccb + j )) ** 2 & + ( wrk2 ( noccb + j )) ** 2 * b * ( nocca - 1 - c - 1.0d0 / & ( max ( abs ( wrk2 ( noccb + j )), tol )) ** 2 )) & * ( bvec_mo ( i , j , js )) ** 2 f = f + half * ( - 1 + a * ( wrk2 ( noccb + j )) ** 2 ) * ( bvec_mo ( i , j , js )) ** 2 end if end do end do else if ( mrsft ) then ! Triplet spin quantum number ss = 0 do i = 1 , nocca do j = 1 , norb - noccb ! cv if (( j > 2 ). and .( i <= noccb )) then ss = ss + ( nocca - 1 - a + ( wrk2 ( i )) ** 2 & + b * ( 1.0d0 / max ( abs ( wrk2 ( i )), tol )) ** 2 ) & * ( bvec_mo ( i , j , js )) ** 2 ! co else if ( i <= noccb ) then ss = ss + ( nocca - 1 - a + ( wrk2 ( i )) ** 2 - ( wrk2 ( j + noccb )) ** 2 & + b * ( ( wrk2 ( j + noccb ) / & max ( abs ( wrk2 ( i )), tol )) ** 2 )) * ( bvec_mo ( i , j , js )) ** 2 ! ov, ot else if (( j > 2 ) . or . ( i == noccb + j )) then ss = ss + ( nocca - 1 - a + b ) * ( bvec_mo ( i , j , js )) ** 2 end if end do end do end if ! Normalization ss = ss / f return end subroutine umrsfssqu !############################################################################### !> Build UMRSF transition and unrelaxed difference density matrices !> !> UMRSF analogue of sfdmat: forms the AO-basis transition density (abxc) !> and the packed occ-occ (ta) / vir-vir (tb) unrelaxed difference density !> contributions using separate alpha/beta MO coefficients. !> subroutine umrsfdmat ( bvec , abxc , mo_a , mo_b , ta , tb , & noca , nocb ) use precision , only : dp use tdhf_lib , only : iatogen use mathlib , only : pack_matrix implicit none real ( kind = dp ), intent ( in ), dimension (:) :: bvec real ( kind = dp ), intent ( in ), dimension (:,:) :: mo_a , mo_b real ( kind = dp ), intent ( inout ), dimension (:,:) :: abxc real ( kind = dp ), intent ( out ), dimension (:) :: ta , tb integer , intent ( in ) :: noca , nocb integer :: nvirb , nbf real ( kind = dp ), allocatable , dimension (:,:) :: scr1 , scr2 nbf = ubound ( mo_a , 1 ) allocate ( scr1 ( nbf , nbf ), & scr2 ( nbf , nbf ), & source = 0.0_dp ) ! MO(I+,A-) -> AO(M,N) using different alpha/beta MOs nvirb = nbf - nocb call iatogen ( bvec , scr1 , noca , nocb ) call dgemm ( 'n' , 'n' , nbf , nbf , nbf , & 1.0_dp , mo_a , nbf , & scr1 , nbf , & 0.0_dp , scr2 , nbf ) call dgemm ( 'n' , 't' , nbf , nbf , nbf , & 1.0_dp , scr2 , nbf , & mo_b , nbf , & 0.0_dp , abxc , nbf ) ! Unrelaxed difference density matrix ----- ! OCC(Alpha)-OCC(Alpha) call dgemm ( 'n' , 't' , noca , noca , nvirb , & - 1.0_dp , bvec , noca , & bvec , noca , & 0.0_dp , scr1 , noca ) ! MO(I+,J+) -> AO(M,N) call dgemm ( 'n' , 'n' , nbf , noca , noca , & 1.0_dp , mo_a , nbf , & scr1 , noca , & 0.0_dp , scr2 , nbf ) call dgemm ( 'n' , 't' , nbf , nbf , noca , & 1.0_dp , scr2 , nbf , & mo_a , nbf , & 0.0_dp , scr1 , nbf ) call pack_matrix ( scr1 , ta ) call dgemm ( 't' , 'n' , nvirb , nvirb , noca , & 1.0_dp , bvec , noca , & bvec , noca , & 0.0_dp , scr1 , nvirb ) ! MO(A-,B-) -> AO(M,N) call dgemm ( 'n' , 'n' , nbf , nvirb , nvirb , & 1.0_dp , mo_b (:, nocb + 1 :), nbf , & scr1 , nvirb , & 0.0_dp , scr2 , nbf ) call dgemm ( 'n' , 't' , nbf , nbf , nvirb , & 1.0_dp , scr2 , nbf , & mo_b (:, nocb + 1 :), nbf , & 0.0_dp , scr1 , nbf ) call pack_matrix ( scr1 , tb ) deallocate ( scr1 , scr2 ) end subroutine umrsfdmat end module tdhf_mrsf_lib","tags":"","url":"sourcefile/tdhf_mrsf_lib.f90.html"},{"title":"pcg.F90 – OpenQP Fortran API","text":"Source Code module pcg_mod use precision , only : dp use iso_c_binding , only : c_ptr , c_loc , c_null_ptr , c_f_pointer use , intrinsic :: ieee_arithmetic , only : ieee_is_finite implicit none !################################################################# private public PCG_CONVERGED public PCG_OK public PCG_NOT_INITIALIZED public PCG_BAD_ARGUMENT public PCG_BREAKDOWN public pcg_matvec public pcg_t public pcg_optimize !################################################################# integer , parameter :: PCG_CONVERGED = - 1 integer , parameter :: PCG_OK = 0 integer , parameter :: PCG_NOT_INITIALIZED = 1 integer , parameter :: PCG_BAD_ARGUMENT = 2 integer , parameter :: PCG_BREAKDOWN = 3 real ( kind = dp ), parameter :: PCG_DENOMINATOR_FLOOR = 1.0d-24 integer , parameter :: msglen = 32 character ( len = msglen ), parameter :: & errmsg ( - 1 : * ) = [ & character ( len = msglen ) :: & \"PCG_CONVERGED\" & , \"PCG_OK\" & , \"PCG_NOT_INITIALIZED\" & , \"PCG_BAD_ARGUMENT\" & , \"PCG_BREAKDOWN\" & ] interface subroutine pcg_matvec ( y , x , dat ) import real ( kind = dp ) :: x (:) real ( kind = dp ) :: y (:) type ( c_ptr ) :: dat end subroutine end interface !> @brief PCG solver for equation Ax=b type :: pcg_t logical :: initialized = . false . integer ( kind = 8 ) :: errcode = 0 real ( kind = dp ), allocatable :: b (:) real ( kind = dp ), allocatable :: x (:) real ( kind = dp ), allocatable :: Ap (:) real ( kind = dp ), allocatable :: p (:) real ( kind = dp ), allocatable :: r (:) real ( kind = dp ), allocatable :: y (:) real ( kind = dp ) :: error = huge ( 1.0_dp ) real ( kind = dp ) :: rz = 0.0_dp !< carried r.M&#94;-1.r = dot_product(r, y) real ( kind = dp ) :: tol = 0.0_dp procedure ( pcg_matvec ), nopass , pointer :: precond => null () procedure ( pcg_matvec ), nopass , pointer :: update => null () type ( c_ptr ) :: dat = c_null_ptr contains procedure :: init => pcg_init procedure :: clean => pcg_clean procedure :: step => pcg_step end type !################################################################# contains !################################################################# subroutine pcg_init ( this , b , update , precond , dat , x0 , tol ) implicit none class ( pcg_t ), intent ( inout ) :: this real ( kind = dp ), intent ( in ) :: b (:) procedure ( pcg_matvec ) :: update procedure ( pcg_matvec ) :: precond real ( kind = dp ), optional , intent ( in ) :: x0 (:) real ( kind = dp ), optional , intent ( in ) :: tol type ( * ), target :: dat integer :: veclen if ( size ( b ) <= 0 ) then this % errcode = PCG_BAD_ARGUMENT return end if if ( present ( x0 )) then if ( size ( x0 ) /= size ( b )) then this % errcode = PCG_BAD_ARGUMENT return end if end if if (. not . all ( ieee_is_finite ( b ))) then this % errcode = PCG_BREAKDOWN return end if if ( present ( x0 )) then if (. not . all ( ieee_is_finite ( x0 ))) then this % errcode = PCG_BREAKDOWN return end if end if veclen = ubound ( b , 1 ) allocate ( this % x ( veclen ), & this % Ap ( veclen ), & this % b ( veclen ), & this % p ( veclen ), & this % r ( veclen ), & this % y ( veclen ), & source = 0.0_dp ) this % precond => precond this % update => update this % b = b if ( present ( x0 )) this % x = x0 if ( present ( tol )) this % tol = tol this % dat = c_loc ( dat ) call this % update ( this % Ap , this % x , this % dat ) if ( any (. not . ieee_is_finite ( this % Ap ))) then this % errcode = PCG_BREAKDOWN return end if this % r (:) = this % b - this % Ap if ( any (. not . ieee_is_finite ( this % r ))) then this % errcode = PCG_BREAKDOWN return end if call this % precond ( this % y , this % r , this % dat ) if ( any (. not . ieee_is_finite ( this % y ))) then this % errcode = PCG_BREAKDOWN return end if this % p (:) = this % y ! Seed the carried numerator rz = r.M&#94;-1.r so pcg_step never has to ! recompute dot_product(r, y) for the current residual. this % rz = dot_product ( this % r , this % y ) if (. not . ieee_is_finite ( this % rz )) then this % errcode = PCG_BREAKDOWN return end if this % error = norm2 ( this % r ) if (. not . ieee_is_finite ( this % error )) then this % errcode = PCG_BREAKDOWN return end if this % initialized = . true . if ( this % error <= this % tol ) then this % errcode = PCG_CONVERGED return end if end subroutine !################################################################# subroutine pcg_clean ( this ) implicit none class ( pcg_t ), intent ( inout ) :: this if ( allocated ( this % x )) deallocate ( this % x ) if ( allocated ( this % Ap )) deallocate ( this % Ap ) if ( allocated ( this % b )) deallocate ( this % b ) if ( allocated ( this % p )) deallocate ( this % p ) if ( allocated ( this % r )) deallocate ( this % r ) if ( allocated ( this % y )) deallocate ( this % y ) nullify ( this % precond ) nullify ( this % update ) this % dat = c_null_ptr this % error = huge ( 1.0_dp ) this % rz = 0.0_dp this % tol = 0.0_dp this % errcode = 0 this % initialized = . false . end subroutine !################################################################# subroutine pcg_step ( this ) implicit none class ( pcg_t ), intent ( inout ) :: this real ( kind = dp ) :: rz , rz_new , pap , alpha , beta if (. not . this % initialized ) then this % errcode = PCG_NOT_INITIALIZED return end if associate ( x => this % x , Ap => this % Ap , & p => this % p , r => this % r , y => this % y , & error => this % error ) ! Invariant on entry: r, y and the carried rz = dot_product(r, y) were ! already validated finite by pcg_init (or the previous step's ! preconditioner update), and p = y + beta*p was built from finite ! operands.  Rather than rescanning every state vector each iteration ! (which costs several O(n) passes on top of the matvec), we let the ! scalar reductions pap, error and rz_new act as the fail-closed ! detectors: a NaN/Inf anywhere in p, Ap, r or y propagates into one of ! them, so a single finiteness test on each scalar is sufficient. rz = this % rz ! Guard p before the (expensive) operator apply so a corrupted search ! direction never triggers a wasted matvec. if ( any (. not . ieee_is_finite ( p ))) then this % errcode = PCG_BREAKDOWN return end if call this % update ( Ap , p , this % dat ) if ( any (. not . ieee_is_finite ( Ap ))) then this % errcode = PCG_BREAKDOWN return end if pap = dot_product ( p , Ap ) if (. not . ieee_is_finite ( pap ) . or . . not . ieee_is_finite ( rz )) then this % errcode = PCG_BREAKDOWN return end if if (. not . pcg_safe_positive_denominator ( pap ) . or . & . not . pcg_safe_positive_denominator ( rz )) then this % errcode = PCG_BREAKDOWN return end if alpha = rz / pap if (. not . ieee_is_finite ( alpha )) then this % errcode = PCG_BREAKDOWN return end if x (:) = x (:) + alpha * p (:) r (:) = r (:) - alpha * Ap (:) error = norm2 ( r ) if (. not . ieee_is_finite ( error )) then this % errcode = PCG_BREAKDOWN return end if if ( error < this % tol ) then ! Only scan the full solution vector once, at the point we are about ! to hand it back as converged, so a finite residual can never mask a ! non-finite entry that escaped via a zero in Ap. if (. not . all ( ieee_is_finite ( x ))) then this % errcode = PCG_BREAKDOWN return end if this % errcode = PCG_CONVERGED return end if if (. not . pcg_safe_positive_denominator ( error )) then this % errcode = PCG_BREAKDOWN return end if call this % precond ( y , r , this % dat ) if ( any (. not . ieee_is_finite ( y ))) then this % errcode = PCG_BREAKDOWN return end if rz_new = dot_product ( r , y ) if (. not . pcg_safe_positive_denominator ( rz_new )) then this % errcode = PCG_BREAKDOWN return end if beta = rz_new / rz if (. not . ieee_is_finite ( beta )) then this % errcode = PCG_BREAKDOWN return end if p (:) = y (:) + beta * p (:) ! Carry rz forward so the next iteration reuses r.M&#94;-1.r instead of ! recomputing dot_product(r, y). this % rz = rz_new end associate end subroutine !################################################################# logical function pcg_safe_positive_denominator ( value ) implicit none real ( kind = dp ), intent ( in ) :: value pcg_safe_positive_denominator = ieee_is_finite ( value ) . and . & abs ( value ) >= PCG_DENOMINATOR_FLOOR end function pcg_safe_positive_denominator !################################################################# subroutine pcg_optimize ( b , update , precond , dat , mxit , x0 , tol , err , cgiters ) use messages , only : show_message , with_abort implicit none real ( kind = dp ), intent ( inout ) :: b (:) procedure ( pcg_matvec ) :: update procedure ( pcg_matvec ) :: precond real ( kind = dp ), optional , intent ( in ) :: x0 (:) integer , intent ( in ) :: mxit real ( kind = dp ), intent ( in ) :: tol type ( * ), intent ( in ) :: dat real ( kind = dp ), optional , intent ( out ) :: err real ( kind = dp ), optional , intent ( out ) :: cgiters type ( pcg_t ) :: pcg integer :: iter integer :: final_errcode if ( present ( cgiters )) cgiters = 0 call pcg % init ( b = b , update = update , precond = precond , dat = dat , x0 = x0 , tol = tol ) select case ( pcg % errcode ) case ( PCG_OK ) continue case ( PCG_CONVERGED ) b = pcg % x if ( present ( err )) err = pcg % error call pcg % clean () return case default goto 9999 end select do iter = 1 , mxit if ( present ( cgiters )) cgiters = iter call pcg % step () select case ( pcg % errcode ) case ( PCG_OK ) continue case ( PCG_CONVERGED ) exit case default goto 9999 end select end do if ( pcg % errcode == PCG_CONVERGED . or . pcg % errcode == PCG_OK ) then b = pcg % x if ( present ( err )) err = pcg % error end if call pcg % clean () return 9999 continue final_errcode = pcg % errcode call pcg % clean () call show_message ( 'PCG: an error has occured, ' // & trim ( errmsg ( final_errcode )), WITH_ABORT ) end subroutine !################################################################# end module","tags":"","url":"sourcefile/pcg.f90.html"},{"title":"zvector_common.F90 – OpenQP Fortran API","text":"Source Code !> Shared helpers for the TDHF/SF/MRSF z-vector (CPHF/CPKS) solvers. !> !> These routines were previously duplicated, one copy per response module !> (`tdhf_z_vector`, `tdhf_sf_z_vector`, `tdhf_mrsf_z_vector`). They are !> collected here so the three z-vector drivers share a single, tested !> implementation. module zvector_common use precision , only : dp use , intrinsic :: ieee_arithmetic , only : ieee_is_finite implicit none private public :: sanitize_zvector_preconditioner public :: zv_opts_t , zv_read_opts , zv_prog_tau , zv_warm_get , zv_warm_put public :: ZV_SLOT_SF , ZV_SLOT_TDHF !> Shared performance opt-ins for the (RHF/SF) z-vector CG solvers, mirroring !> the MRSF implementation. Read once per solve from env OQP_<PREFIX>_ZV_*. type :: zv_opts_t logical :: warm_on = . true . !< warm-start across steps (default on; result-neutral guess) logical :: prog_on = . false . !< progressive (iteration-dependent) screening (opt-in) logical :: diag_on = . false . !< Jacobi cold-start guess x0 = M&#94;-1 rhs (opt-in) logical :: timers = . false . !< per-section profiler real ( dp ) :: conv_user = - 1.0_dp !< override cnvtol (<0 => use input) real ( dp ) :: prog_k = 1.0e-2_dp !< tau = prog_k * ||r|| real ( dp ) :: prog_cap = 1.0e-6_dp !< loosest tau real ( dp ) :: prog_pin = 1.0e-6_dp !< pin tight once ||r||&#94;2 < this end type zv_opts_t ! Warm-start stores, one per method (persist across steps in one process). integer , parameter :: ZV_SLOT_SF = 1 , ZV_SLOT_TDHF = 2 , ZV_NSLOT = 4 type :: zv_store_t real ( dp ), allocatable :: vec (:,:) logical , allocatable :: has (:) integer :: lzdim = 0 end type zv_store_t type ( zv_store_t ), save :: zv_stores ( ZV_NSLOT ) contains logical function zv_is_false ( s ) character ( len =* ), intent ( in ) :: s character :: c c = s ( 1 : 1 ) zv_is_false = ( c == '0' . or . c == 'n' . or . c == 'N' . or . c == 'f' . or . c == 'F' ) end function zv_is_false !> Read OQP_<prefix>_ZV_* opt-ins (warm-start/progressive/Jacobi default ON). subroutine zv_read_opts ( opts , prefix ) type ( zv_opts_t ), intent ( out ) :: opts character ( len =* ), intent ( in ) :: prefix character ( len = 64 ) :: e_ integer :: ios call get_environment_variable ( 'OQP_' // trim ( prefix ) // '_ZV_WARMSTART' , e_ ) if ( len_trim ( e_ ) > 0 ) opts % warm_on = . not . zv_is_false ( e_ ) call get_environment_variable ( 'OQP_' // trim ( prefix ) // '_ZV_PROG' , e_ ) if ( len_trim ( e_ ) > 0 ) opts % prog_on = . not . zv_is_false ( e_ ) call get_environment_variable ( 'OQP_' // trim ( prefix ) // '_ZV_DIAGGUESS' , e_ ) if ( len_trim ( e_ ) > 0 ) opts % diag_on = . not . zv_is_false ( e_ ) call get_environment_variable ( 'OQP_' // trim ( prefix ) // '_ZV_TIMERS' , e_ ) opts % timers = len_trim ( e_ ) > 0 call get_environment_variable ( 'OQP_' // trim ( prefix ) // '_ZV_CONV' , e_ ) if ( len_trim ( e_ ) > 0 ) then read ( e_ , * , iostat = ios ) opts % conv_user if ( ios /= 0 ) opts % conv_user = - 1.0_dp end if call get_environment_variable ( 'OQP_' // trim ( prefix ) // '_ZV_PROG_CAP' , e_ ) if ( len_trim ( e_ ) > 0 ) read ( e_ , * , iostat = ios ) opts % prog_cap call get_environment_variable ( 'OQP_' // trim ( prefix ) // '_ZV_PROG_K' , e_ ) if ( len_trim ( e_ ) > 0 ) read ( e_ , * , iostat = ios ) opts % prog_k call get_environment_variable ( 'OQP_' // trim ( prefix ) // '_ZV_PROG_PIN' , e_ ) if ( len_trim ( e_ ) > 0 ) read ( e_ , * , iostat = ios ) opts % prog_pin end subroutine zv_read_opts !> Progressive screening threshold for a CG step (tight once pinned). function zv_prog_tau ( opts , error , tight ) result ( tau ) type ( zv_opts_t ), intent ( in ) :: opts real ( dp ), intent ( in ) :: error , tight real ( dp ) :: tau , resid if (. not . ieee_is_finite ( error ) . or . error < opts % prog_pin ) then tau = tight ; return end if resid = sqrt ( max ( error , 0.0_dp )) tau = opts % prog_k * resid if ( tau < tight ) tau = tight if ( tau > opts % prog_cap ) tau = opts % prog_cap end function zv_prog_tau !> Cache a converged z-vector for warm-starting the next step (per method slot). subroutine zv_warm_put ( slot , vec , lzdim , state , nstate ) integer , intent ( in ) :: slot , lzdim , state , nstate real ( dp ), intent ( in ) :: vec (:) integer :: ncol if ( slot < 1 . or . slot > ZV_NSLOT ) return if ( any (. not . ieee_is_finite ( vec ))) return ncol = max ( nstate , state ) if ( zv_stores ( slot )% lzdim /= lzdim . or . . not . allocated ( zv_stores ( slot )% vec )) then if ( allocated ( zv_stores ( slot )% vec )) deallocate ( zv_stores ( slot )% vec ) if ( allocated ( zv_stores ( slot )% has )) deallocate ( zv_stores ( slot )% has ) allocate ( zv_stores ( slot )% vec ( lzdim , ncol ), source = 0.0_dp ) allocate ( zv_stores ( slot )% has ( ncol ), source = . false .) zv_stores ( slot )% lzdim = lzdim else if ( size ( zv_stores ( slot )% has ) < state ) then return end if zv_stores ( slot )% vec (:, state ) = vec zv_stores ( slot )% has ( state ) = . true . end subroutine zv_warm_put !> Fetch a warm-start guess; returns .true. only on a finite, matching hit. function zv_warm_get ( slot , vec , lzdim , state ) result ( used ) integer , intent ( in ) :: slot , lzdim , state real ( dp ), intent ( out ) :: vec (:) logical :: used used = . false . vec = 0.0_dp if ( slot < 1 . or . slot > ZV_NSLOT ) return if (. not . allocated ( zv_stores ( slot )% vec ) . or . . not . allocated ( zv_stores ( slot )% has )) return if ( zv_stores ( slot )% lzdim /= lzdim ) return if ( state < 1 . or . state > size ( zv_stores ( slot )% has )) return if (. not . zv_stores ( slot )% has ( state )) return if ( any (. not . ieee_is_finite ( zv_stores ( slot )% vec (:, state )))) return vec = zv_stores ( slot )% vec (:, state ) used = . true . end function zv_warm_get !> @brief Build a finite diagonal (Jacobi) preconditioner `xminv = 1/xm`. !> !> Each denominator that is non-finite or smaller in magnitude than `floor` !> is replaced by `+/-floor` (sign preserved), so the preconditioner can never !> introduce a NaN/Inf or an overflow. The number of regularized entries is !> reported on `log_unit`, tagged with `tag` (e.g. \"RHF\", \"SF\", \"MRSF\"). !> !> `floor` is supplied by the caller because the response modules use slightly !> different thresholds (1e-12 for RHF/SF, 1e-14 for MRSF). subroutine sanitize_zvector_preconditioner ( xm , xminv , log_unit , floor , tag ) real ( kind = dp ), intent ( in ) :: xm (:) real ( kind = dp ), intent ( out ) :: xminv (:) integer , intent ( in ) :: log_unit real ( kind = dp ), intent ( in ) :: floor character ( len =* ), intent ( in ), optional :: tag integer :: i , regularized real ( kind = dp ) :: denom character ( len = 16 ) :: prefix prefix = '' if ( present ( tag )) prefix = trim ( tag ) // ' ' regularized = 0 do i = 1 , size ( xm ) denom = xm ( i ) if (. not . ieee_is_finite ( denom ) . or . abs ( denom ) < floor ) then if ( ieee_is_finite ( denom ) . and . denom < 0.0_dp ) then denom = - floor else denom = floor end if regularized = regularized + 1 end if xminv ( i ) = 1.0_dp / denom end do if ( regularized > 0 ) then write ( log_unit , '(1x,A,\"z-vector preconditioner regularized \",I0,\" denominator(s)\")' ) & trim ( prefix ), regularized call flush ( log_unit ) end if end subroutine sanitize_zvector_preconditioner end module zvector_common","tags":"","url":"sourcefile/zvector_common.f90.html"},{"title":"guess_huckel.F90 – OpenQP Fortran API","text":"Source Code !> @brief Extended Huckel initial guess drivers ! !> @details The standard (`guess_huckel`) and modified (`guess_modhuckel`) !>          extended Huckel guesses share the same driver; they differ only !>          in the off-diagonal Wolfsberg-Helmholz formula, selected by the !>          `modified` flag. module guess_huckel_mod implicit none character ( len =* ), parameter :: module_name = \"guess_huckel_mod\" contains subroutine guess_huckel_C ( c_handle ) bind ( C , name = \"guess_huckel\" ) use c_interop , only : oqp_handle_t , oqp_handle_get_info use types , only : information type ( oqp_handle_t ) :: c_handle type ( information ), pointer :: inf inf => oqp_handle_get_info ( c_handle ) call guess_huckel_driver ( inf , modified = . false .) end subroutine guess_huckel_C subroutine guess_modhuckel_C ( c_handle ) bind ( C , name = \"guess_modhuckel\" ) use c_interop , only : oqp_handle_t , oqp_handle_get_info use types , only : information type ( oqp_handle_t ) :: c_handle type ( information ), pointer :: inf inf => oqp_handle_get_info ( c_handle ) call guess_huckel_driver ( inf , modified = . true .) end subroutine guess_modhuckel_C subroutine guess_huckel_driver ( infos , modified ) use precision , only : dp use types , only : information use io_constants , only : IW use oqp_tagarray_driver use basis_tools , only : basis_set use guess , only : get_ab_initio_density use huckel , only : huckel_guess use util , only : measure_time use messages , only : show_message , WITH_ABORT use printing , only : print_module_info use iso_c_binding , only : c_char use parallel , only : par_env_t implicit none character ( len =* ), parameter :: subroutine_name = \"guess_huckel_driver\" type ( information ), target , intent ( inout ) :: infos logical , intent ( in ) :: modified integer :: i , nbf , nbf2 type ( basis_set ), pointer :: basis type ( basis_set ) :: huckel_basis character ( len = :), allocatable :: basis_file logical :: err integer , parameter :: root = 0 type ( par_env_t ) :: pe ! tagarray real ( kind = dp ), contiguous , pointer :: & Smat (:), & dmat_a (:), mo_a (:,:), mo_energy_a (:), & dmat_b (:), mo_b (:,:), mo_energy_b (:) character ( len =* ), parameter :: tags_alpha ( 3 ) = ( / character ( len = 80 ) :: & OQP_DM_A , OQP_E_MO_A , OQP_VEC_MO_A / ) character ( len =* ), parameter :: tags_beta ( 3 ) = ( / character ( len = 80 ) :: & OQP_DM_B , OQP_E_MO_B , OQP_VEC_MO_B / ) character ( len =* ), parameter :: tags_general ( 2 ) = ( / character ( len = 80 ) :: & OQP_SM , OQP_hbasis_filename / ) character ( len = 1 , kind = c_char ), contiguous , pointer :: basis_filename (:) ! The Huckel (MINI) basis set file name is passed from Python via tagarray call data_has_tags ( infos % dat , tags_general , module_name , subroutine_name , with_abort ) call tagarray_get_data ( infos % dat , OQP_hbasis_filename , basis_filename ) allocate ( character ( ubound ( basis_filename , 1 )) :: basis_file ) do i = 1 , ubound ( basis_filename , 1 ) basis_file ( i : i ) = basis_filename ( i ) end do open ( unit = IW , file = infos % log_filename , position = \"append\" ) if ( modified ) then call print_module_info ( 'Guess_ModHuckel' , 'Initial guess using modified Huckel theory' ) else call print_module_info ( 'Guess_Huckel' , 'Initial guess using Huckel theory' ) end if ! load the Huckel minimal basis set on the master process basis => infos % basis call pe % init ( infos % mpiinfo % comm , infos % mpiinfo % usempi ) err = . false . if ( pe % rank == root ) then call huckel_basis % from_file ( basis_file , infos % atoms , err ) end if ! Checking error of basis set reading.. infos % control % basis_set_issue = err call pe % bcast ( infos % control % basis_set_issue , 1 ) if ( infos % control % basis_set_issue ) then call show_message ( 'Failed to read the Huckel (MINI) basis set from ' // basis_file , WITH_ABORT ) end if basis % atoms => infos % atoms nbf = basis % nbf nbf2 = nbf * ( nbf + 1 ) / 2 ! load general data call tagarray_get_data ( infos % dat , OQP_SM , smat ) ! allocate alpha call infos % dat % alloc_or_die ( OQP_DM_A , ( / nbf2 / ), dmat_a , description = OQP_DM_A_comment ) call infos % dat % alloc_or_die ( OQP_E_MO_A , ( / nbf / ), mo_energy_a , description = OQP_E_MO_A_comment ) call infos % dat % alloc_or_die ( OQP_VEC_MO_A , ( / nbf , nbf / ), mo_a , description = OQP_VEC_MO_A_comment ) ! UHF/ROHF if ( infos % control % scftype >= 2 ) then ! allocate beta call infos % dat % alloc_or_die ( OQP_DM_B , ( / nbf2 / ), dmat_b , description = OQP_DM_B_comment ) call infos % dat % alloc_or_die ( OQP_E_MO_B , ( / nbf / ), mo_energy_b , description = OQP_E_MO_B_comment ) call infos % dat % alloc_or_die ( OQP_VEC_MO_B , ( / nbf , nbf / ), mo_b , description = OQP_VEC_MO_B_comment ) end if ! Calculate Huckel MOs and the corresponding density matrix. ! All heavy work runs on the master process only; the results are ! broadcast below. mo_energy_a receives the Huckel eigenvalues for ! the projected orbitals (approximate guess orbital energies). if ( pe % rank == root ) then call huckel_guess ( Smat , MO_A , infos , basis , huckel_basis , & modified = modified , mo_energy = mo_energy_a ) !   For ROHF/UHF the beta orbitals start identical to alpha if ( infos % control % scftype >= 2 ) then MO_B = MO_A mo_energy_b = mo_energy_a end if if ( infos % control % scftype == 1 ) then call get_ab_initio_density ( Dmat_A , MO_A , infos = infos , basis = basis ) else call get_ab_initio_density ( Dmat_A , MO_A , Dmat_B , MO_B , infos , basis ) end if end if ! Broadcast MO, MO energy and density matrices to all processes call pe % bcast ( MO_A , nbf * nbf ) call pe % bcast ( mo_energy_a , nbf ) call pe % bcast ( Dmat_A , nbf2 ) if ( infos % control % scftype >= 2 ) then call pe % bcast ( MO_B , nbf * nbf ) call pe % bcast ( mo_energy_b , nbf ) call pe % bcast ( Dmat_B , nbf2 ) end if call pe % barrier () write ( iw , '(/x,a,/)' ) '...... End of initial orbital guess ......' call measure_time ( print_total = 1 , log_unit = iw ) close ( iw ) end subroutine guess_huckel_driver end module guess_huckel_mod","tags":"","url":"sourcefile/guess_huckel.f90.html"},{"title":"int2e.F90 – OpenQP Fortran API","text":"Source Code module int2e_mod use precision , only : dp use int2_compute , only : int2_compute_data_t implicit none character ( len =* ), parameter :: module_name = \"int2e_mod\" private public int2e !> @brief Consumer that scatters computed shell-quartet ERIs into a dense !>        (nbf,nbf,nbf,nbf) AO tensor, applying the full 8-fold permutational !>        symmetry. Mirrors the int2_rhf_data_t consumer but accumulates the !>        raw integrals instead of contracting them into a Fock matrix. type , extends ( int2_compute_data_t ) :: int2_dump_data_t integer :: nbf = 0 real ( kind = dp ), pointer :: eri (:,:,:,:) => null () contains procedure :: parallel_start => dump_parallel_start procedure :: parallel_stop => dump_parallel_stop procedure :: update => dump_update procedure :: clean => dump_clean end type contains subroutine int2e_C ( c_handle ) bind ( C , name = \"int2e\" ) use c_interop , only : oqp_handle_t , oqp_handle_get_info use types , only : information type ( oqp_handle_t ) :: c_handle type ( information ), pointer :: inf inf => oqp_handle_get_info ( c_handle ) call int2e ( inf ) end subroutine int2e_C !> @brief Compute all two-electron repulsion integrals (mu nu|la si) in the AO !>        basis (chemist notation) and store them in the OQP::ERI_AO tag as a !>        full nbf**4 array, so the Python layer can build a FCIDUMP / qubit !>        Hamiltonian. This is the conventional (in-core) path: memory grows as !>        nbf**4, so it is intended for small active systems, not production SCF. subroutine int2e ( infos ) use types , only : information use oqp_tagarray_driver use precision , only : dp use io_constants , only : iw use basis_tools , only : basis_set use printing , only : print_module_info use messages , only : show_message , WITH_ABORT use int2_compute , only : int2_compute_t implicit none character ( len =* ), parameter :: subroutine_name = \"int2e\" type ( information ), target , intent ( inout ) :: infos type ( basis_set ), pointer :: basis type ( int2_compute_t ) :: int2_driver type ( int2_dump_data_t ) :: dump real ( kind = dp ), contiguous , pointer :: eri_flat (:) integer :: nbf integer ( 8 ) :: nbf4 real ( kind = dp ) :: mem_mb open ( unit = iw , file = infos % log_filename , position = \"append\" ) basis => infos % basis basis % atoms => infos % atoms call print_module_info ( 'int2e' , & 'Computing Two-Electron Repulsion Integrals (AO ERIs)' ) nbf = basis % nbf nbf4 = int ( nbf , 8 ) ** 4 mem_mb = real ( nbf4 , dp ) * 8.0d0 / ( 102 4.0d0 * 102 4.0d0 ) write ( iw , '(/1x,\"AO basis functions (nbf): \",i0)' ) nbf write ( iw , '(1x,\"In-core ERI tensor size : \",i0,\" elements (\",f0.1,\" MB)\")' ) & nbf4 , mem_mb !   Guard against an accidental, ruinous allocation. nbf**4 doubles is the !   conventional in-core cost; refuse clearly above ~16 GB rather than thrash. if ( mem_mb > 1638 4.0d0 ) then call show_message ( & \"int2e: in-core AO ERI tensor exceeds 16 GB; this routine targets \" // & \"small active systems for FCIDUMP export, not full production basis \" // & \"sets.\" , WITH_ABORT ) end if !   Allocate and zero the destination tag. Screened (negligible) integrals are !   left at zero, matching standard quantum-chemistry practice. !   nbf4 is integer(8), so the int64-shape low-level create is used here (the !   high-level alloc_or_die only accepts default-integer shapes). if ( infos % dat % create ( OQP_ERI_AO , TA_TYPE_REAL64 , [ nbf4 ], & description = OQP_ERI_AO_comment , override = . true .) /= TA_OK ) & call show_message ( \"int2e: failed to allocate OQP::ERI_AO\" , WITH_ABORT ) call tagarray_get_data ( infos % dat , OQP_ERI_AO , eri_flat ) eri_flat = 0.0d0 !   Remap the flat storage to a rank-4 view for convenient scatter. The full !   8-fold symmetry of the integrals makes the C/Fortran index-order difference !   irrelevant: the Python side reshapes the same bytes to (pq|rs) directly. dump % nbf = nbf dump % eri ( 1 : nbf , 1 : nbf , 1 : nbf , 1 : nbf ) => eri_flat !   Drive the conventional two-electron engine with the dump consumer. No CAM !   attenuation: we want the bare 1/r12 Coulomb integrals. call int2_driver % init ( basis , infos ) call int2_driver % set_screening () call int2_driver % run ( dump ) call int2_driver % clean () dump % eri => null () write ( iw , \"(/1x,'...... End Of Two-Electron Integrals ......'/)\" ) close ( iw ) end subroutine int2e !############################################################################### subroutine dump_parallel_start ( this , basis , nthreads ) use basis_tools , only : basis_set implicit none class ( int2_dump_data_t ), target , intent ( inout ) :: this type ( basis_set ), intent ( in ) :: basis integer , intent ( in ) :: nthreads !   Nothing to set up: distinct shell quartets map to disjoint canonical AO !   index sets, so threads never write the same destination element. if (. false .) then this % nbf = this % nbf if ( basis % nbf < 0 . or . nthreads < 0 ) continue end if end subroutine dump_parallel_start subroutine dump_parallel_stop ( this ) implicit none class ( int2_dump_data_t ), intent ( inout ) :: this !   int2_compute_t distributes shell-quartet work across MPI ranks.  Each rank !   scatters only its local quartets into the dense tensor, so combine the full !   tensor before returning it through OQP::ERI_AO.  For non-MPI runs this is a !   no-op through par_env_t%allreduce. call this % pe % barrier () if ( associated ( this % eri )) then call this % pe % allreduce ( this % eri , size ( this % eri )) end if call this % pe % barrier () end subroutine dump_parallel_stop subroutine dump_clean ( this ) implicit none class ( int2_dump_data_t ), intent ( inout ) :: this if (. false .) this % nbf = this % nbf end subroutine dump_clean !> @brief Scatter one buffer of unique integrals into the dense tensor using !>        the 8-fold permutational symmetry of (ij|kl). subroutine dump_update ( this , buf ) use int2_compute , only : int2_storage_t implicit none class ( int2_dump_data_t ), intent ( inout ) :: this type ( int2_storage_t ), intent ( inout ) :: buf integer :: n , i , j , k , l real ( kind = dp ) :: v do n = 1 , buf % ncur i = buf % ids ( 1 , n ) j = buf % ids ( 2 , n ) k = buf % ids ( 3 , n ) l = buf % ids ( 4 , n ) v = buf % ints ( n ) !     storeints (int2_compute_data_t_storeints) pre-scales the buffered value !     by 0.5 for each \"diagonal\" coincidence so the Fock build can apply !     uniform Coulomb/exchange factors. Undo that scaling here to recover the !     true integral (mu nu|la si) before scattering it into the dense tensor. if ( i == j ) v = v * 2.0d0 if ( k == l ) v = v * 2.0d0 if ( i == k . and . j == l ) v = v * 2.0d0 this % eri ( i , j , k , l ) = v this % eri ( j , i , k , l ) = v this % eri ( i , j , l , k ) = v this % eri ( j , i , l , k ) = v this % eri ( k , l , i , j ) = v this % eri ( l , k , i , j ) = v this % eri ( k , l , j , i ) = v this % eri ( l , k , j , i ) = v end do buf % ncur = 0 end subroutine dump_update end module int2e_mod","tags":"","url":"sourcefile/int2e.f90.html"},{"title":"solvent_pcm.F90 – OpenQP Fortran API","text":"Source Code !> @brief OpenQP <-> ddX PCM reaction-field bridge for the SCF energy path. !> !> @details This module is the Fortran half of the energy-only PCM seam. It !> declares the iso_c_binding interfaces to the two production C adapter !> entry points (source/solvent_ddx_adapter.c) and orchestrates the closed !> reaction-field loop inside a single SCF Fock build: !> !>     D  ->  phi_cav  ->  ddX q_cav  ->  V_pcm  ->  Fock / E_pcm !> !> The C adapter returns status 2 when OpenQP was built without OQP_ENABLE_DDX, !> so a PCM-enabled run on a non-ddX build aborts here with a clear message !> rather than silently producing a vacuum result. !> !> SOURCE CONSISTENCY (ddX forward Phi vs adjoint Psi): !>   * Phi (forward solve RHS): the EXACT total solute potential phi_cav at the !>     cavity points, built from the full AO density (electrostatic_potential_ !>     unweighted) plus the analytic nuclear term. !>   * Psi (adjoint solve source): a FULL-DENSITY source. Atom-centered real !>     solid-harmonic multipoles M_lm are accumulated for l = 0..PCM_PSI_LMAX !>     (=8) from the full AO density by numerical quadrature over a dedicated !>     source-projection molecular grid that reproduces the reference !>     ddCOSMO/ddPCM density partition: per-atom (PARENT-ATOM) point !>     assignment with Becke-original (3-iteration) fuzzy-cell weights and !>     Treutler-Ahlrichs sqrt(R_i/R_j) atomic-size shifting over the Becke !>     Bragg-Slater table (H = 0.35 A), WITH the literature outside-sphere !>     leak continuation q*rsph&#94;(2l+1)/r&#94;(l+1) for r>rsph !>     (build_full_density_multipoles / pcm_grid_update). The moments are in !>     the exact ddX harmonic convention -- the real-solid-harmonic basis is !>     evaluated by ddX's OWN routines (use ddx_harmonics: ylmscale, ylmbas) !>     so ddX stays an external, dynamically-linked dependency and no harmonic !>     code is vendored into OpenQP; only the interior/exterior leak !>     bookkeeping in pcm_accumulate_leak is OpenQP's. They are then mapped !>     to psi by the ddX rule psi(lm,isph)=4*pi/((2l+1) rsph&#94;l) M_lm(isph) !>     using the production cavity radii (oqp_ddx_pcm_radii). The production !>     q_cav is the ddX adjoint charge from oqp_ddx_pcm_solve_psi(psi, !>     phi_cav): both the forward RHS and the adjoint source are full-density !>     quantities. This is recorded by \"PCM diag pcm_source_mode=full_density_ !>     multipoles_lmax8_exact_phi\" and \"PCM diag psi_source=full_density_grid_ !>     multipoles_lmax8_becke3_treutler_parent_atom_leak\". !>   * NOTE: the per-sphere moments are partition-defined integrals !>     (Becke-original/Treutler cells), the same convention the reference !>     ddPCM implementations project on their per-atom Becke grids; the two !>     codes agree in the fine-grid limit, with only quadrature-mesh !>     differences remaining (it is NOT claimed to be bit-identical to !>     PySCF's grid-projected psi). !>   * The legacy l<=2 atom-centered Mulliken multipole solve (Phi AND Psi from !>     the l<=2 source) is still run as a DIAGNOSTIC only, to report the !>     source-vs-exact phi residual and the q_cav shift between the old l<=2 psi !>     and the new full-density psi (PCM diag q_cav_*_vs_*_rms). !> !> VALIDATED SCALAR CONVENTIONS (analytic Born-ion/ddX oracle gate): !>   * phi_cav sign:  phi_total = sum_k Z_k/|r-R_k| + phi_elec !>   * q_cav sign/scale: ddX cavity-projected adjoint charge (ddx_get_xi) used !>     directly as the external-charge vector for external_charge_potential. !>   * E_pcm: -0.5 * dot_product(phi_cav, q_cav), with NO additional dielectric !>     factor: ddX folds the full dielectric response into its ddPCM R_eps !>     operators, so -0.5*<phi_cav, q_cav> = ddx_pcm_energy = the PHYSICAL !>     solvation free energy. Proven by the Born-ion oracle (point charge q !>     centered in a single sphere of radius R): -0.5*<phi,q_cav> reproduces !>     -(1/2)(1-1/eps)*q&#94;2/R to machine precision at eps = 78.3553 and eps = 2. !>     An extra f(eps) = (eps-1)/eps here (as in PySCF's solvent.ddpcm) would !>     double-count the dielectric scaling, by -1.3% at eps=78 and -50% at eps=2. !> The single canonical runtime path and these conventions are pinned by !> tests/test_pcm_canonical_runtime_path.py. module solvent_pcm use precision , only : dp use , intrinsic :: ieee_arithmetic , only : ieee_is_finite use iso_c_binding , only : c_int , c_double , c_char , c_null_char , & c_int64_t , c_bool use types , only : information use basis_tools , only : basis_set use messages , only : show_message , with_abort use io_constants , only : iw use mathlib , only : traceprod_sym_packed use oqp_tagarray_driver , only : OQP_SM , data_has_tags , tagarray_get_data use int1 , only : electrostatic_potential_unweighted , external_charge_potential , & multipole_integrals use mod_dft_molgrid , only : dft_grid_t use mod_dft_gridint , only : xc_engine_t , xc_consumer_t , xc_options_t , run_grid_aos use mod_dft_partfunc , only : PTYPE_BECKE3 use dft , only : dft_initialize ! ddX's own harmonic routines (external, dynamically-linked LGPL library): ! ylmscale builds the real-spherical-harmonic scaling factors and ylmbas ! evaluates the normalised real solid harmonics in ddX's exact convention. ! Using them directly (rather than vendoring a copy) keeps ddX external and ! guarantees the per-l normalisation/ordering matches the model ddX builds. ! Only available when OpenQP is built with ddX (OQP_ENABLE_DDX); the whole ! full-density source projection is unreachable otherwise (the C adapter ! returns status 2 and add_pcm_reaction_field aborts before it is called). #ifdef OQP_ENABLE_DDX use ddx_harmonics , only : ylmscale , ylmbas #endif implicit none private public :: add_pcm_reaction_field ! Maximum angular momentum of the full-density adjoint source Psi. The ddX ! model is built with lmax = 8 (solvent_ddx_adapter.c::build_pcm_model), so ! nbasis = (PCM_PSI_LMAX+1)&#94;2 = 81 must match ddx_get_n_basis(). integer , parameter :: PCM_PSI_LMAX = 8 ! Maximum Lebedev cavity points per atom (must match n_lebedev used when the ! ddX model is built in build_pcm_model(); used only to size the receive ! buffer for the cavity coordinates). integer ( c_int ), parameter :: MAX_CAV_PER_ATOM = 302 integer , parameter :: PCM_FD_MAX_SAMPLES = 3 real ( dp ), parameter :: PCM_FD_STEP = 1.0e-4_dp ! Finite-difference diagnostics below derive this sign/scale.  It is kept as ! an explicit constant so the Fock convention is guarded by runtime evidence. real ( dp ), parameter :: PCM_QCAV_TO_FOCK_SCALE = - 0.5_dp ! Grid consumer for the PCM full-density-Psi production path. It integrates ! the electronic density on a dedicated Becke-original/Treutler-shifted ! molecular grid, assigns each weighted point to its PARENT atom (the atom ! whose atomic grid generated the slice, xce%currAtom), and accumulates the ! corresponding negative electronic charge into ddX-convention real-solid- ! harmonic multipoles through PCM_PSI_LMAX. Nuclear monopoles are added by ! the driver after the grid loop. This reproduces the reference ! ddCOSMO/ddPCM source projection (per-atom Becke-partitioned moments) up ! to quadrature-mesh differences. type , extends ( xc_consumer_t ) :: pcm_psi_grid_consumer_t integer :: lmax = 0 integer :: nbasis = 0 integer :: natom = 0 real ( dp ), pointer :: xyz (:,:) => null () real ( dp ), allocatable :: vscales (:) real ( dp ), allocatable :: radii (:) real ( dp ), allocatable :: multipoles (:,:,:) contains procedure :: parallel_start => pcm_grid_parallel_start procedure :: parallel_stop => pcm_grid_parallel_stop procedure :: update => pcm_grid_update procedure :: postUpdate => pcm_grid_post_update procedure :: clean => pcm_grid_clean end type pcm_psi_grid_consumer_t interface integer ( c_int ) function oqp_ddx_pcm_cavity ( natom , xyz_bohr , charges , & eps , max_cav , ncav_out , cav_xyz_out , message , message_len ) & bind ( C , name = \"oqp_ddx_pcm_cavity\" ) import :: c_int , c_double , c_char integer ( c_int ), value :: natom real ( c_double ), intent ( in ) :: xyz_bohr ( * ) real ( c_double ), intent ( in ) :: charges ( * ) real ( c_double ), value :: eps integer ( c_int ), value :: max_cav integer ( c_int ), intent ( out ) :: ncav_out real ( c_double ), intent ( out ) :: cav_xyz_out ( * ) character ( kind = c_char ), intent ( out ) :: message ( * ) integer ( c_int ), value :: message_len end function oqp_ddx_pcm_cavity integer ( c_int ) function oqp_ddx_pcm_solve ( natom , xyz_bohr , charges , & eps , ncav , phi_cav , q_cav_out , esolv_out , message , message_len ) & bind ( C , name = \"oqp_ddx_pcm_solve\" ) import :: c_int , c_double , c_char integer ( c_int ), value :: natom real ( c_double ), intent ( in ) :: xyz_bohr ( * ) real ( c_double ), intent ( in ) :: charges ( * ) real ( c_double ), value :: eps integer ( c_int ), value :: ncav real ( c_double ), intent ( in ) :: phi_cav ( * ) real ( c_double ), intent ( out ) :: q_cav_out ( * ) real ( c_double ), intent ( out ) :: esolv_out character ( kind = c_char ), intent ( out ) :: message ( * ) integer ( c_int ), value :: message_len end function oqp_ddx_pcm_solve integer ( c_int ) function oqp_ddx_pcm_solve_multipole_source ( natom , & xyz_bohr , cavity_charges , nmultipoles , source_multipoles , eps , ncav , & phi_source_out , q_cav_out , esolv_out , message , message_len ) & bind ( C , name = \"oqp_ddx_pcm_solve_multipole_source\" ) import :: c_int , c_double , c_char integer ( c_int ), value :: natom real ( c_double ), intent ( in ) :: xyz_bohr ( * ) real ( c_double ), intent ( in ) :: cavity_charges ( * ) integer ( c_int ), value :: nmultipoles real ( c_double ), intent ( in ) :: source_multipoles ( * ) real ( c_double ), value :: eps integer ( c_int ), value :: ncav real ( c_double ), intent ( out ) :: phi_source_out ( * ) real ( c_double ), intent ( out ) :: q_cav_out ( * ) real ( c_double ), intent ( out ) :: esolv_out character ( kind = c_char ), intent ( out ) :: message ( * ) integer ( c_int ), value :: message_len end function oqp_ddx_pcm_solve_multipole_source integer ( c_int ) function oqp_ddx_pcm_solve_multipole_source_with_phi ( natom , & xyz_bohr , cavity_charges , nmultipoles , source_multipoles , eps , ncav , & phi_cav , q_cav_out , esolv_out , message , message_len ) & bind ( C , name = \"oqp_ddx_pcm_solve_multipole_source_with_phi\" ) import :: c_int , c_double , c_char integer ( c_int ), value :: natom real ( c_double ), intent ( in ) :: xyz_bohr ( * ) real ( c_double ), intent ( in ) :: cavity_charges ( * ) integer ( c_int ), value :: nmultipoles real ( c_double ), intent ( in ) :: source_multipoles ( * ) real ( c_double ), value :: eps integer ( c_int ), value :: ncav real ( c_double ), intent ( in ) :: phi_cav ( * ) real ( c_double ), intent ( out ) :: q_cav_out ( * ) real ( c_double ), intent ( out ) :: esolv_out character ( kind = c_char ), intent ( out ) :: message ( * ) integer ( c_int ), value :: message_len end function oqp_ddx_pcm_solve_multipole_source_with_phi integer ( c_int ) function oqp_ddx_pcm_radii ( natom , charges , radii_bohr_out , & message , message_len ) bind ( C , name = \"oqp_ddx_pcm_radii\" ) import :: c_int , c_double , c_char integer ( c_int ), value :: natom real ( c_double ), intent ( in ) :: charges ( * ) real ( c_double ), intent ( out ) :: radii_bohr_out ( * ) character ( kind = c_char ), intent ( out ) :: message ( * ) integer ( c_int ), value :: message_len end function oqp_ddx_pcm_radii integer ( c_int ) function oqp_ddx_pcm_solve_psi ( natom , xyz_bohr , charges , & eps , ncav , nbasis , psi , phi_cav , q_cav_out , esolv_out , message , & message_len ) bind ( C , name = \"oqp_ddx_pcm_solve_psi\" ) import :: c_int , c_double , c_char integer ( c_int ), value :: natom real ( c_double ), intent ( in ) :: xyz_bohr ( * ) real ( c_double ), intent ( in ) :: charges ( * ) real ( c_double ), value :: eps integer ( c_int ), value :: ncav integer ( c_int ), value :: nbasis real ( c_double ), intent ( in ) :: psi ( * ) real ( c_double ), intent ( in ) :: phi_cav ( * ) real ( c_double ), intent ( out ) :: q_cav_out ( * ) real ( c_double ), intent ( out ) :: esolv_out character ( kind = c_char ), intent ( out ) :: message ( * ) integer ( c_int ), value :: message_len end function oqp_ddx_pcm_solve_psi end interface contains !> @brief Add the ddX PCM reaction-field operator to the Fock matrices and !>        return the (provisional) PCM energy contribution. !> @param[in]    basis   AO basis (read-only) !> @param[in]    infos   run information; uses control%pcm_epsilon, atoms, natom !> @param[in]    d       packed AO density blocks (nbf_tri, nfocks) !> @param[in]    nfocks  number of spin blocks !> @param[inout] f       packed AO Fock blocks (nbf_tri, nfocks); V_pcm added !> @param[out]   e_pcm   PCM energy contribution (provisional) subroutine add_pcm_reaction_field ( basis , infos , d , nfocks , f , e_pcm ) type ( basis_set ), intent ( in ) :: basis type ( information ), intent ( inout ) :: infos real ( dp ), intent ( in ) :: d (:,:) integer , intent ( in ) :: nfocks real ( dp ), intent ( inout ) :: f (:,:) real ( dp ), intent ( out ) :: e_pcm integer ( c_int ) :: natom , ncav , max_cav , nmultipoles , nbasis integer :: nbf_tri , ii , iat , icav , rc , ndelta real ( dp ) :: eps , f_epsilon , esolv , esolv_source , esolv_l2 , phin , dx , dy , dz , r real ( dp ) :: half_tr_dv , q_cav_sum , q_cav_absnorm , phi_cav_sum , phi_cav_min , phi_cav_max real ( dp ) :: source_charge_sum , phi_source_delta_rms , phi_source_delta_max real ( dp ) :: q_cav_shift_rms , q_cav_full_vs_l2_rms , psi_full_norm , mult_full_norm real ( dp ) :: fd_fock_scale_mean , fd_fock_scale_rms , fd_fock_scale_maxerr integer :: fd_fock_samples logical :: pcm_diag real ( dp ), allocatable :: xyz (:,:), charges (:) real ( dp ), allocatable :: cav_xyz (:), cx (:), cy (:), cz (:) real ( dp ), allocatable :: phi_elec (:), phi_cav (:), phi_source (:), q_cav (:), q_cav_source (:) real ( dp ), allocatable :: q_cav_l2 (:) real ( dp ), allocatable :: dtot (:), vpcm (:) real ( dp ), allocatable :: ao_pop (:), atom_pop (:), source_charges (:) real ( dp ), allocatable :: ao_dip (:,:), atom_dip (:,:), ao_quad (:,:), atom_quad (:,:) real ( dp ), allocatable :: source_multipoles (:,:) real ( dp ), allocatable :: multipoles_full (:,:), psi_full (:,:), radii (:) real ( dp ), contiguous , pointer :: smat (:) character ( kind = c_char ) :: cmsg ( 256 ) character ( len = 256 ) :: fmsg character ( len =* ), parameter :: tags_overlap ( 1 ) = ( / character ( len = 80 ) :: OQP_SM / ) e_pcm = 0.0_dp natom = int ( infos % mol_prop % natom , c_int ) eps = infos % control % pcm_epsilon ! DIAGNOSTIC-ONLY dielectric factor f(eps) = (eps-1)/eps. It is reported in ! the diagnostics below but is NOT applied to e_pcm or the Fock operator: ! ddX folds the COMPLETE dielectric response into its ddPCM R_eps operators, ! so its pcm_energy = 0.5*<xs,psi> (= -0.5*<phi_cav,q_cav> by the adjoint ! identity) is already the physical solvation free energy. This is proven by ! the Born-ion oracle: -0.5*<phi,q_cav> = -(1/2)(1-1/eps)q&#94;2/R to machine ! precision. PySCF's solvent.ddpcm applies an extra 0.5*f_eps*<psi,Xvec> ! scaling on top of its R_eps solve, which is why it FAILS the same Born ! oracle; it must not be imitated here. f_epsilon = ( eps - 1.0_dp ) / eps nbf_tri = size ( d , 1 ) ! Convention self-diagnostics (two extra baseline ddX solves, a finite- ! difference Fock-scale probe, and a ~40-line per-cycle log block) are gated ! to high verbosity. Production runs (verbose <= 2, the default) perform a ! single full-density ddX solve and emit no PCM diag lines. pcm_diag = ( infos % control % verbose >= 3 ) allocate ( xyz ( 3 , natom ), charges ( natom )) xyz (:,:) = infos % atoms % xyz (:, 1 : natom ) charges (:) = infos % atoms % zn ( 1 : natom ) ! ---- Phase 1: build ddX cavity, retrieve cavity-point coordinates ------ max_cav = MAX_CAV_PER_ATOM * natom allocate ( cav_xyz ( 3 * max_cav )) ncav = 0 rc = oqp_ddx_pcm_cavity ( natom , xyz , charges , eps , max_cav , ncav , & cav_xyz , cmsg , int ( size ( cmsg ), c_int )) if ( rc /= 0 ) then call c_message_to_fortran ( cmsg , fmsg ) call show_message ( 'PCM (ddX) cavity build failed: ' // trim ( fmsg ), with_abort ) end if allocate ( cx ( ncav ), cy ( ncav ), cz ( ncav )) do icav = 1 , ncav cx ( icav ) = cav_xyz ( 3 * ( icav - 1 ) + 1 ) cy ( icav ) = cav_xyz ( 3 * ( icav - 1 ) + 2 ) cz ( icav ) = cav_xyz ( 3 * ( icav - 1 ) + 3 ) end do ! ---- Phase 2: total solute electrostatic potential at cavity points ---- ! Electronic part from the AO density on a temporary copy of the total ! density, so the SCF density blocks are not disturbed. allocate ( dtot ( nbf_tri ), source = 0.0_dp ) do ii = 1 , nfocks dtot (:) = dtot (:) + d (:, ii ) end do allocate ( phi_elec ( ncav ), phi_cav ( ncav )) call electrostatic_potential_unweighted ( basis , cx , cy , cz , dtot , phi_elec ) ! phi_total = sum_k Z_k/|r-R_k| + phi_elec, where the OpenQP ! Coulomb-potential primitive returns the electronic contribution with the ! electron-charge sign already included. do icav = 1 , ncav phin = 0.0_dp do iat = 1 , natom dx = cx ( icav ) - xyz ( 1 , iat ) dy = cy ( icav ) - xyz ( 2 , iat ) dz = cz ( icav ) - xyz ( 3 , iat ) r = sqrt ( dx * dx + dy * dy + dz * dz ) if ( r > 1.0e-12_dp ) phin = phin + charges ( iat ) / r end do phi_cav ( icav ) = phin + phi_elec ( icav ) end do ! ---- Phase 3: QM source -> ddX q_cav ----------------------------------- ! The PRODUCTION adjoint source Psi is FULL-DENSITY (3c): atom-centered real ! solid-harmonic multipoles for l = 0..PCM_PSI_LMAX accumulated from the AO ! density by parent-atom Becke-partitioned grid quadrature, in the exact ddX harmonic ! convention, mapped to psi by the ddX rule. The l<=2 Mulliken-multipole ! source (3a/3b) is retained ONLY as a diagnostic baseline. ! Production needs only the full-density adjoint solve (3c) below; q_cav is ! its cavity-projected adjoint charge that drives the Fock matrix and e_pcm. allocate ( q_cav ( ncav )) if ( pcm_diag ) then ! (3a/3b) DIAGNOSTIC ONLY -- the l<=2 Mulliken-multipole source, retained ! as a baseline so the q_cav shift from upgrading to the full-density Psi ! can be measured. Skipped in production: it costs two extra ddX solves per ! SCF cycle and never feeds the Fock matrix or e_pcm. allocate ( ao_pop ( basis % nbf ), atom_pop ( natom ), source_charges ( natom ), & ao_dip ( 3 , basis % nbf ), atom_dip ( 3 , natom ), & ao_quad ( 6 , basis % nbf ), atom_quad ( 6 , natom ), source = 0.0_dp ) call data_has_tags ( infos % dat , tags_overlap , & 'solvent_pcm:add_pcm_reaction_field' , with_abort ) call tagarray_get_data ( infos % dat , OQP_SM , smat ) call mulliken_atomic_population_from_density ( basis , smat , dtot , & ao_pop , atom_pop ) call mulliken_atomic_multipoles_from_density ( basis , dtot , atom_pop , & ao_dip , atom_dip , ao_quad , atom_quad ) source_charges (:) = charges (:) - atom_pop (:) nmultipoles = 9_c_int allocate ( source_multipoles ( nmultipoles , natom ), source = 0.0_dp ) call pack_ddx_l2_multipoles ( source_charges , atom_dip , atom_quad , source_multipoles ) allocate ( phi_source ( ncav ), q_cav_source ( ncav ), q_cav_l2 ( ncav )) ! (3a) legacy all-multipole solve: both Phi and Psi from the l<=2 source. rc = oqp_ddx_pcm_solve_multipole_source ( natom , xyz , charges , & nmultipoles , source_multipoles , eps , ncav , phi_source , q_cav_source , & esolv_source , cmsg , int ( size ( cmsg ), c_int )) if ( rc /= 0 ) then call c_message_to_fortran ( cmsg , fmsg ) call show_message ( 'PCM (ddX) diagnostic source solve failed: ' // trim ( fmsg ), with_abort ) end if ! (3b) previous production path: exact phi_cav + l<=2 multipole Psi. rc = oqp_ddx_pcm_solve_multipole_source_with_phi ( natom , xyz , charges , & nmultipoles , source_multipoles , eps , ncav , phi_cav , q_cav_l2 , esolv_l2 , & cmsg , int ( size ( cmsg ), c_int )) if ( rc /= 0 ) then call c_message_to_fortran ( cmsg , fmsg ) call show_message ( 'PCM (ddX) l2-psi diagnostic solve failed: ' // trim ( fmsg ), with_abort ) end if end if ! (3c) PRODUCTION solve -- full-density Psi (l = 0..PCM_PSI_LMAX) from the AO ! density + the EXACT total cavity potential phi_cav (Phase 2). Both the ! forward RHS and the adjoint source are full-density. q_cav is the ! cavity-projected adjoint charge (ddx_get_xi) from this solve and is what ! drives the Fock matrix and e_pcm. nbasis = int (( PCM_PSI_LMAX + 1 ) ** 2 , c_int ) allocate ( multipoles_full ( nbasis , natom ), psi_full ( nbasis , natom ), radii ( natom )) ! Query the production ddX cavity radii FIRST: the full-density Psi must use ! each sphere's rsph for the outside-sphere \"leak\" continuation (the QM ! density tail beyond the small vdW sphere), exactly as PySCF's ! cache_fake_multipoles does with (r_vdw/r)&#94;(2l+1). rc = oqp_ddx_pcm_radii ( natom , charges , radii , cmsg , int ( size ( cmsg ), c_int )) if ( rc /= 0 ) then call c_message_to_fortran ( cmsg , fmsg ) call show_message ( 'PCM (ddX) radii query failed: ' // trim ( fmsg ), with_abort ) end if call build_full_density_multipoles ( basis , infos , dtot , charges , radii , xyz , & int ( natom ), PCM_PSI_LMAX , multipoles_full , & mult_full_norm ) call multipoles_to_psi ( multipoles_full , radii , PCM_PSI_LMAX , psi_full ) psi_full_norm = sqrt ( sum ( psi_full * psi_full )) rc = oqp_ddx_pcm_solve_psi ( natom , xyz , charges , eps , ncav , nbasis , & psi_full , phi_cav , q_cav , esolv , cmsg , int ( size ( cmsg ), c_int )) if ( rc /= 0 ) then call c_message_to_fortran ( cmsg , fmsg ) call show_message ( 'PCM (ddX) full-density psi solve failed: ' // trim ( fmsg ), with_abort ) end if ! ---- Phase 4: V_pcm AO matrix, add to Fock blocks, report E_pcm -------- allocate ( vpcm ( nbf_tri )) call external_charge_potential ( basis , vpcm , cx , cy , cz , q_cav ) ! FD self-test of dE/dphi = -0.5*q_cav about the EXACT phi_cav baseline ! (verbose >= 3 only): two extra perturbed ddX re-solves per cycle, purely ! for convention validation. Skipped in production. fd_fock_scale_mean = 0.0_dp ; fd_fock_scale_rms = 0.0_dp fd_fock_scale_maxerr = 0.0_dp ; fd_fock_samples = 0 if ( pcm_diag ) then call pcm_fock_scale_fd_diagnostic ( natom , xyz , charges , eps , ncav , nbasis , & psi_full , phi_cav , q_cav , & fd_fock_scale_mean , fd_fock_scale_rms , fd_fock_scale_maxerr , & fd_fock_samples ) end if ! Fock reaction-field operator. The variational PCM free energy !   E_pcm = -0.5 * <phi_cav(D), q_cav(D)> ! is quadratic in D (both phi_cav and q_cav are linear in D for the ! symmetric ddPCM response), so its derivative dE/dD = -ext(q_cav): ! the explicit factor of 1/2 cancels against the two equal D-dependent terms ! (the phi-side and psi-side contributions, equal by the symmetry of the ! continuum reaction-field kernel). The full coupling is therefore ! 2*PCM_QCAV_TO_FOCK_SCALE = -1, NOT the bare -0.5 explicit-phi factor that ! pcm_fock_scale_fd_diagnostic verifies for dE/dphi. No dielectric factor is ! applied: q_cav already carries the full eps response (see f_epsilon note). vpcm (:) = 2.0_dp * PCM_QCAV_TO_FOCK_SCALE * vpcm (:) do ii = 1 , nfocks f (:, ii ) = f (:, ii ) + vpcm (:) end do ! PCM reaction-field (solvation) energy. The apparent surface charges q_cav ! (from the full-density-Psi exact-phi ddX solve) are contracted with the ! EXACT total solute potential at the cavity points (phi_cav = nuclear + ! electronic). The -0.5 factor is the linear-response polarization factor. ! No additional dielectric factor: -0.5*<phi_cav,q_cav> equals ddX's ! pcm_energy and the physical solvation free energy (Born-ion oracle). ! ! FOCK DERIVATIVE SCOPE: the production SCF uses the full linear-dielectric ! coupling V_pcm = -external_charge_potential(q_cav), recorded as ! fock_mode=ddpcm_physical_full_variational_coupling. The finite-difference ! probe above only verifies the explicit dE/dphi relation (-0.5*q_cav); ! future analytic gradients/response work should add a dedicated dPsi/dD ! check for the grid-projected full-density source. e_pcm = PCM_QCAV_TO_FOCK_SCALE * dot_product ( phi_cav , q_cav ) ! ---- Diagnostic block (validation gate; does NOT affect e_pcm or Fock) -- ! Exposes, in Fortran, the quantities needed to validate the QM SCF PCM ! conventions against a reference (see tests/test_pcm_literature_benchmarks.py ! and tests/data/pcm_literature_benchmarks.json). These prints are read-only ! summaries of arrays already computed above; the energy and Fock are ! unchanged. The host-side polarization energy 0.5*Tr[D.V_pcm] is reported ! alongside the ddX esolv so the e_pcm-vs-(1/2)Tr[D.V] bookkeeping question ! can be measured rather than assumed. psi_source records the QM source now ! used consistently for ddX phi and psi. if ( pcm_diag ) then half_tr_dv = 0.5_dp * traceprod_sym_packed ( dtot , vpcm , basis % nbf ) q_cav_sum = sum ( q_cav ) q_cav_absnorm = sqrt ( sum ( q_cav * q_cav )) phi_cav_sum = sum ( phi_cav ) phi_cav_min = minval ( phi_cav ) phi_cav_max = maxval ( phi_cav ) source_charge_sum = sum ( source_charges ) ! RMS shift in the surface charge from the full-density exact-phi production ! solve relative to the legacy all-multipole (l<=2 Phi and Psi) solve. q_cav_shift_rms = sqrt ( sum (( q_cav - q_cav_source ) ** 2 ) / real ( ncav , dp )) ! RMS shift from upgrading the adjoint source from l<=2 multipole Psi to the ! full-density Psi, both with the EXACT phi_cav: the quantitative measure of ! what the full-density Psi buys over the previous production path. q_cav_full_vs_l2_rms = sqrt ( sum (( q_cav - q_cav_l2 ) ** 2 ) / real ( ncav , dp )) phi_source_delta_rms = 0.0_dp phi_source_delta_max = 0.0_dp ndelta = 0 do icav = 1 , ncav if ( ieee_is_finite ( phi_source ( icav )) . and . ieee_is_finite ( phi_cav ( icav ))) then phi_source_delta_rms = phi_source_delta_rms + & ( phi_source ( icav ) - phi_cav ( icav )) ** 2 phi_source_delta_max = max ( phi_source_delta_max , & abs ( phi_source ( icav ) - phi_cav ( icav ))) ndelta = ndelta + 1 end if end do if ( ndelta > 0 ) then phi_source_delta_rms = sqrt ( phi_source_delta_rms / real ( ndelta , dp )) else phi_source_delta_rms = huge ( 1.0_dp ) phi_source_delta_max = huge ( 1.0_dp ) end if write ( iw , '(1x,\"PCM diag e_pcm=\",ES22.14)' ) e_pcm write ( iw , '(1x,\"PCM diag esolv_full_density_psi=\",ES22.14)' ) esolv write ( iw , '(1x,\"PCM diag esolv_l2_psi_exact_phi=\",ES22.14)' ) esolv_l2 write ( iw , '(1x,\"PCM diag esolv_source_multipole=\",ES22.14)' ) esolv_source write ( iw , '(1x,\"PCM diag half_tr_dv=\",ES22.14)' ) half_tr_dv write ( iw , '(1x,\"PCM diag q_cav_sum=\",ES22.14)' ) q_cav_sum write ( iw , '(1x,\"PCM diag q_cav_absnorm=\",ES22.14)' ) q_cav_absnorm write ( iw , '(1x,\"PCM diag fock_q_scale=\",ES22.14)' ) PCM_QCAV_TO_FOCK_SCALE write ( iw , '(1x,\"PCM diag f_epsilon=\",ES22.14)' ) f_epsilon write ( iw , '(1x,\"PCM diag fock_q_coupling=\",ES22.14)' ) & 2.0_dp * PCM_QCAV_TO_FOCK_SCALE write ( iw , '(1x,\"PCM diag fd_fock_scale_mean=\",ES22.14)' ) fd_fock_scale_mean write ( iw , '(1x,\"PCM diag fd_fock_scale_rms=\",ES22.14)' ) fd_fock_scale_rms write ( iw , '(1x,\"PCM diag fd_fock_scale_maxerr=\",ES22.14)' ) fd_fock_scale_maxerr write ( iw , '(1x,\"PCM diag fd_fock_samples=\",I0)' ) fd_fock_samples write ( iw , '(1x,\"PCM diag source_charge_sum=\",ES22.14)' ) source_charge_sum write ( iw , '(1x,\"PCM diag phi_source_vs_exact_rms=\",ES22.14)' ) phi_source_delta_rms write ( iw , '(1x,\"PCM diag phi_source_vs_exact_max=\",ES22.14)' ) phi_source_delta_max write ( iw , '(1x,\"PCM diag phi_cav_sum=\",ES22.14)' ) phi_cav_sum write ( iw , '(1x,\"PCM diag phi_cav_min=\",ES22.14)' ) phi_cav_min write ( iw , '(1x,\"PCM diag phi_cav_max=\",ES22.14)' ) phi_cav_max write ( iw , '(1x,\"PCM diag ncav=\",I0)' ) int ( ncav ) write ( iw , '(1x,\"PCM diag q_cav_source_vs_exact_rms=\",ES22.14)' ) q_cav_shift_rms write ( iw , '(1x,\"PCM diag q_cav_full_vs_l2_rms=\",ES22.14)' ) q_cav_full_vs_l2_rms write ( iw , '(1x,\"PCM diag multipoles_full_norm=\",ES22.14)' ) mult_full_norm write ( iw , '(1x,\"PCM diag psi_full_norm=\",ES22.14)' ) psi_full_norm block integer :: ldiag , mdiag , lmdiag real ( dp ) :: lnorm do ldiag = 0 , PCM_PSI_LMAX lnorm = 0.0_dp do mdiag = - ldiag , ldiag lmdiag = ldiag * ldiag + ldiag + 1 + mdiag lnorm = lnorm + sum ( multipoles_full ( lmdiag ,:) ** 2 ) end do write ( iw , '(1x,\"PCM diag mult_l\",I0,\"_norm=\",ES22.14)' ) ldiag , sqrt ( lnorm ) end do write ( iw , '(1x,\"PCM diag atom_q0=\",10ES16.8)' ) & multipoles_full ( 1 ,:) * sqrt ( 4.0_dp * acos ( - 1.0_dp )) end block write ( iw , '(1x,\"PCM diag pcm_source_mode=full_density_multipoles_lmax8_exact_phi\")' ) write ( iw , '(1x,\"PCM diag psi_source=full_density_grid_multipoles_lmax8_becke3_treutler_parent_atom_leak\")' ) write ( iw , '(1x,\"PCM diag fock_mode=ddpcm_physical_full_variational_coupling\")' ) end if end subroutine add_pcm_reaction_field subroutine mulliken_atomic_population_from_density ( basis , smat , density , ao_pop , atom_pop ) type ( basis_set ), intent ( in ) :: basis real ( dp ), intent ( in ) :: smat (:), density (:) real ( dp ), intent ( out ) :: ao_pop (:), atom_pop (:) integer :: mu , nu , ish , iatom , i0 , i1 , idx ao_pop (:) = 0.0_dp atom_pop (:) = 0.0_dp do mu = 1 , basis % nbf do nu = 1 , basis % nbf idx = packed_index ( mu , nu ) ao_pop ( mu ) = ao_pop ( mu ) + density ( idx ) * smat ( idx ) end do end do do ish = 1 , basis % nshell iatom = basis % origin ( ish ) i0 = basis % ao_offset ( ish ) i1 = basis % ao_offset ( ish ) + basis % naos ( ish ) - 1 atom_pop ( iatom ) = atom_pop ( iatom ) + sum ( ao_pop ( i0 : i1 )) end do end subroutine mulliken_atomic_population_from_density subroutine mulliken_atomic_multipoles_from_density ( basis , density , atom_pop , ao_dip , atom_dip , ao_quad , atom_quad ) type ( basis_set ), intent ( in ) :: basis real ( dp ), intent ( in ) :: density (:) real ( dp ), intent ( in ) :: atom_pop (:) real ( dp ), intent ( out ) :: ao_dip (:,:), atom_dip (:,:) real ( dp ), intent ( out ) :: ao_quad (:,:), atom_quad (:,:) integer :: iat , mu , nu , ish , i0 , i1 , idx integer , allocatable :: ao_atom (:) real ( dp ), allocatable :: moment_ints (:,:) atom_dip (:,:) = 0.0_dp atom_quad (:,:) = 0.0_dp allocate ( ao_atom ( basis % nbf ), moment_ints ( size ( density ), 9 )) moment_ints (:,:) = 0.0_dp ao_atom (:) = 0 do ish = 1 , basis % nshell iat = basis % origin ( ish ) i0 = basis % ao_offset ( ish ) i1 = basis % ao_offset ( ish ) + basis % naos ( ish ) - 1 ao_atom ( i0 : i1 ) = iat end do do iat = 1 , size ( atom_pop ) ao_dip (:,:) = 0.0_dp ao_quad (:,:) = 0.0_dp moment_ints (:,:) = 0.0_dp call multipole_integrals ( basis , moment_ints , basis % atoms % xyz (:, iat ), 2 ) do mu = 1 , basis % nbf if ( ao_atom ( mu ) /= iat ) cycle do nu = 1 , basis % nbf idx = packed_index ( mu , nu ) ao_dip ( 1 , mu ) = ao_dip ( 1 , mu ) + density ( idx ) * moment_ints ( idx , 1 ) ao_dip ( 2 , mu ) = ao_dip ( 2 , mu ) + density ( idx ) * moment_ints ( idx , 2 ) ao_dip ( 3 , mu ) = ao_dip ( 3 , mu ) + density ( idx ) * moment_ints ( idx , 3 ) ao_quad ( 1 , mu ) = ao_quad ( 1 , mu ) + density ( idx ) * moment_ints ( idx , 4 ) ao_quad ( 2 , mu ) = ao_quad ( 2 , mu ) + density ( idx ) * moment_ints ( idx , 5 ) ao_quad ( 3 , mu ) = ao_quad ( 3 , mu ) + density ( idx ) * moment_ints ( idx , 6 ) ao_quad ( 4 , mu ) = ao_quad ( 4 , mu ) + density ( idx ) * moment_ints ( idx , 7 ) ao_quad ( 5 , mu ) = ao_quad ( 5 , mu ) + density ( idx ) * moment_ints ( idx , 8 ) ao_quad ( 6 , mu ) = ao_quad ( 6 , mu ) + density ( idx ) * moment_ints ( idx , 9 ) end do end do atom_dip (:, iat ) = - sum ( ao_dip (:, :), dim = 2 ) atom_quad (:, iat ) = - sum ( ao_quad (:, :), dim = 2 ) end do end subroutine mulliken_atomic_multipoles_from_density subroutine pack_ddx_l2_multipoles ( source_charges , atom_dip , atom_quad , multipoles ) real ( dp ), intent ( in ) :: source_charges (:), atom_dip (:,:), atom_quad (:,:) real ( dp ), intent ( out ) :: multipoles (:,:) integer :: iat real ( dp ) :: sqrt4pi , sqrt4pi_over3 real ( dp ), parameter :: q_xy = 1.0925484305920792_dp real ( dp ), parameter :: q_z2 = 0.31539156525252005_dp real ( dp ), parameter :: q_x2y2 = 0.5462742152960396_dp sqrt4pi = sqrt ( 4.0_dp * acos ( - 1.0_dp )) sqrt4pi_over3 = sqrt ( 4.0_dp * acos ( - 1.0_dp ) / 3.0_dp ) multipoles (:,:) = 0.0_dp do iat = 1 , size ( source_charges ) ! ddX real-solid-harmonic order for l<=2 is: !   1: charge; 2: y dipole; 3: z dipole; 4: x dipole; !   5: xy; 6: yz; 7: z&#94;2; 8: xz; 9: x&#94;2-y&#94;2. multipoles ( 1 , iat ) = source_charges ( iat ) / sqrt4pi multipoles ( 2 , iat ) = - atom_dip ( 2 , iat ) / sqrt4pi_over3 multipoles ( 3 , iat ) = atom_dip ( 3 , iat ) / sqrt4pi_over3 multipoles ( 4 , iat ) = - atom_dip ( 1 , iat ) / sqrt4pi_over3 multipoles ( 5 , iat ) = q_xy * atom_quad ( 4 , iat ) multipoles ( 6 , iat ) = q_xy * atom_quad ( 6 , iat ) multipoles ( 7 , iat ) = q_z2 * ( - atom_quad ( 1 , iat ) - atom_quad ( 2 , iat ) + & 2.0_dp * atom_quad ( 3 , iat )) multipoles ( 8 , iat ) = q_xy * atom_quad ( 5 , iat ) multipoles ( 9 , iat ) = q_x2y2 * ( atom_quad ( 1 , iat ) - atom_quad ( 2 , iat )) end do end subroutine pack_ddx_l2_multipoles !> @brief Accumulate the full-density ddPCM source moment of one grid point !>        onto its parent sphere, with the outside-sphere exterior (\"leak\") !>        continuation. !> !> The real-solid-harmonic basis Y_lm is evaluated by ddX's OWN ylmbas !> (use ddx_harmonics), so the per-l normalisation and (l,m) ordering match !> the multipole array ddX consumes internally (multipole_psi: !> psi(lm,isph)=4*pi/((2l+1) rsph&#94;l) M_lm). ddX therefore stays an external, !> dynamically-linked dependency and no harmonic code is copied into OpenQP. !> Only the interior/exterior bookkeeping below -- the literature leak !> continuation q*rsph&#94;(2l+1)/r&#94;(l+1) for points outside their sphere -- is !> OpenQP's own and is NOT part of ddX's point-to-multipole routine: !> !>   r <= rsph :  M_lm += q * r&#94;l * Y_lm                   (interior) !>   r >  rsph :  M_lm += q * Y_lm * rsph&#94;(2l+1) / r&#94;(l+1) (exterior leak) !>                       = (interior term) * (rsph/r)&#94;(2l+1) !> !> @param[in]    c        radius vector from the charge to the sphere centre !> @param[in]    src_q    charge of the source point !> @param[in]    p        maximal degree !> @param[in]    vscales  scaling factors from ylmscale, dim (p+1)**2 !> @param[in]    rsph     radius of the sphere the moment is accumulated on !> @param[inout] dst_m    multipole coefficients, dim (p+1)**2 (accumulated) subroutine pcm_accumulate_leak ( c , src_q , p , vscales , rsph , dst_m ) integer , intent ( in ) :: p real ( dp ), intent ( in ) :: c ( 3 ), src_q , vscales (( p + 1 ) ** 2 ), rsph real ( dp ), intent ( inout ) :: dst_m (( p + 1 ) ** 2 ) real ( dp ) :: vylm (( p + 1 ) ** 2 ), vplm (( p + 1 ) ** 2 ), vcos ( p + 1 ), vsin ( p + 1 ) real ( dp ) :: rho , ctheta , stheta , cphi , sphi , t , ratio2 , sqrt4pi integer :: n , ind #ifdef OQP_ENABLE_DDX if ( src_q == 0.0_dp ) return sqrt4pi = sqrt ( 4.0_dp * acos ( - 1.0_dp )) ! ddX's own real-solid-harmonic evaluation (external library). call ylmbas ( c , rho , ctheta , stheta , cphi , sphi , p , vscales , vylm , vplm , & vcos , vsin ) if ( rho == 0.0_dp ) then ! Exactly at the sphere centre (e.g. a nuclear charge): only l=0 survives. dst_m ( 1 ) = dst_m ( 1 ) + src_q / sqrt4pi return end if if ( rho <= rsph . or . rsph <= 0.0_dp ) then ! Interior point: standard bare moment q*r&#94;l*Y_lm. t = src_q do n = 0 , p ind = n * n + n + 1 dst_m ( ind - n : ind + n ) = dst_m ( ind - n : ind + n ) + t * vylm ( ind - n : ind + n ) t = t * rho end do else ! Exterior (leak) point: q * rsph&#94;(2l+1)/rho&#94;(l+1) * Y_lm ! (= the interior term q*rho&#94;l scaled by (rsph/rho)&#94;(2l+1)). ratio2 = rsph * ( rsph / rho ) t = src_q * ( rsph / rho ) do n = 0 , p ind = n * n + n + 1 dst_m ( ind - n : ind + n ) = dst_m ( ind - n : ind + n ) + t * vylm ( ind - n : ind + n ) t = t * ratio2 end do end if #else ! Unreachable without ddX (callers gate on the C adapter's ddX-availability ! status); abort defensively. Unused dummy args here are intentional. call show_message ( 'PCM full-density source projection requires a ddX-enabled & &build (OQP_ENABLE_DDX)' , with_abort ) #endif end subroutine pcm_accumulate_leak subroutine build_full_density_multipoles ( basis , infos , density_packed , charges , & radii , xyz , natom , lmax , multipoles , mult_norm ) type ( basis_set ), intent ( in ) :: basis type ( information ), intent ( inout ) :: infos real ( dp ), intent ( in ) :: density_packed (:) real ( dp ), intent ( in ), target :: charges (:), xyz (:,:) real ( dp ), intent ( in ) :: radii (:) integer , intent ( in ) :: natom , lmax real ( dp ), intent ( out ) :: multipoles (:,:) real ( dp ), intent ( out ) :: mult_norm type ( basis_set ) :: basis_work type ( dft_grid_t ), target :: molgrid type ( xc_options_t ) :: xc_opts type ( pcm_psi_grid_consumer_t ) :: dat real ( dp ), allocatable , target :: density_full (:,:) integer :: nbf , i , j , idx , maxl , nang real ( dp ) :: sqrt4pi ! Extra ddX ylmscale outputs we do not use, sized per its interface. real ( dp ) :: v4pi2lp1 ( lmax + 1 ), vscales_rel (( lmax + 1 ) ** 2 ) character ( kind = c_char ) :: saved_xcname ( 20 ) integer ( c_int64_t ) :: saved_partfun , saved_bfc_algo , saved_nrad , & saved_nang , saved_radtype logical ( c_bool ) :: saved_pruned nbf = basis % nbf if ( size ( multipoles , 1 ) /= ( lmax + 1 ) ** 2 . or . size ( multipoles , 2 ) /= natom ) then call show_message ( 'PCM full-density Psi multipole buffer has wrong shape' , with_abort ) end if allocate ( density_full ( nbf , nbf ), source = 0.0_dp ) do i = 1 , nbf do j = 1 , nbf idx = packed_index ( i , j ) density_full ( i , j ) = density_packed ( idx ) * basis % bfnrm ( i ) * basis % bfnrm ( j ) end do end do basis_work = basis ! HF/reference-SCF inputs can leave infos%dft%xc_functional_name unset/garbage. ! dft_set_options still inspects the C-string even when need_functional=.false., ! so follow the existing SAP-grid pattern: temporarily blank the name while ! constructing the quadrature grid, then restore it. saved_xcname = infos % dft % xc_functional_name infos % dft % xc_functional_name = c_null_char ! The PCM source-projection grid is PINNED to the reference ddCOSMO/ddPCM ! density-partition convention, independent of any user XC-grid settings: !   * Becke's ORIGINAL fuzzy-cell partition (3 softening iterations, !     JCP 88, 2547 (1988)) -- PTYPE_BECKE3, !   * Treutler-Ahlrichs atomic-size surface shifting chi = sqrt(R_i/R_j) !     (JCP 102, 346 (1995)) over the Becke Bragg-Slater table (H = 0.35 A) !     -- dft_bfc_algo = 2, !   * unpruned 240x302 atomic grids on the standard (MHL) radial map. ! Together with the parent-atom point assignment in pcm_grid_update this ! makes the per-sphere source moments converge to the SAME partitioned ! integrals as the reference ddPCM implementations (e.g. PySCF's ! ddcosmo.make_psi_vmat on its Becke-partitioned atomic grids); the grid ! mesh itself only controls quadrature accuracy, not the partition limit. saved_partfun = infos % dft % dft_partfun saved_bfc_algo = infos % dft % dft_bfc_algo saved_nrad = infos % dft % grid_rad_size saved_nang = infos % dft % grid_ang_size saved_radtype = infos % dft % rad_grid_type saved_pruned = infos % dft % grid_pruned infos % dft % dft_partfun = int ( PTYPE_BECKE3 , c_int64_t ) infos % dft % dft_bfc_algo = 2_c_int64_t infos % dft % grid_rad_size = 240_c_int64_t infos % dft % grid_ang_size = 302_c_int64_t infos % dft % rad_grid_type = 0_c_int64_t infos % dft % grid_pruned = . false . _ c_bool call dft_initialize ( infos , basis_work , molgrid , verbose = . false ., need_functional = . false .) infos % dft % dft_partfun = saved_partfun infos % dft % dft_bfc_algo = saved_bfc_algo infos % dft % grid_rad_size = saved_nrad infos % dft % grid_ang_size = saved_nang infos % dft % rad_grid_type = saved_radtype infos % dft % grid_pruned = saved_pruned infos % dft % xc_functional_name = saved_xcname dat % lmax = lmax dat % nbasis = ( lmax + 1 ) ** 2 dat % natom = natom dat % xyz => xyz allocate ( dat % vscales ( dat % nbasis )) #ifdef OQP_ENABLE_DDX call ylmscale ( lmax , dat % vscales , v4pi2lp1 , vscales_rel ) #else call show_message ( 'PCM full-density source projection requires a ddX-enabled & &build (OQP_ENABLE_DDX)' , with_abort ) #endif allocate ( dat % radii ( natom )) dat % radii (:) = radii ( 1 : natom ) call dat % pe % init ( infos % mpiinfo % comm , infos % mpiinfo % usempi ) maxl = maxval ( basis_work % am ) nang = maxl + 2 xc_opts % isGGA = . false . xc_opts % needTau = . false . xc_opts % hasBeta = . false . xc_opts % isWFVecs = . false . xc_opts % numAOs = nbf xc_opts % maxPts = molgrid % maxSlicePts xc_opts % limPts = molgrid % maxNRadTimesNAng xc_opts % numAtoms = natom xc_opts % maxAngMom = nang xc_opts % nDer = 0 xc_opts % numOccAlpha = infos % mol_prop % nelec_A xc_opts % numOccBeta = infos % mol_prop % nelec_B xc_opts % wfAlpha => density_full xc_opts % molGrid => molgrid ! No density-based weight screening for the source projection: the Becke ! partition has small but nonzero tail weights on every atom's grid, and ! the per-sphere moments should integrate them like the reference does. xc_opts % dft_threshold = 0.0_dp xc_opts % ao_threshold = infos % dft % grid_ao_threshold ! Keep AO pruning enabled using the normal DFT threshold; the consumer uses ! xce%compMOs/compRho so both pruned and unpruned paths are handled by the engine. xc_opts % ao_sparsity_ratio = infos % dft % grid_ao_sparsity_ratio if ( infos % dft % grid_pruned ) xc_opts % ao_sparsity_ratio = 0.0_dp call run_grid_aos ( xc_opts , dat , basis_work ) multipoles (:,:) = dat % multipoles (:,:, 1 ) ! Add nuclear point charges exactly at their own atom centers. For c=0 only ! the l=0 real harmonic contributes: q * Y_00 = q/sqrt(4*pi). sqrt4pi = sqrt ( 4.0_dp * acos ( - 1.0_dp )) do i = 1 , natom multipoles ( 1 , i ) = multipoles ( 1 , i ) + charges ( i ) / sqrt4pi end do mult_norm = sqrt ( sum ( multipoles * multipoles )) call dat % clean () end subroutine build_full_density_multipoles subroutine multipoles_to_psi ( multipoles , radii , lmax , psi ) real ( dp ), intent ( in ) :: multipoles (:,:), radii (:) integer , intent ( in ) :: lmax real ( dp ), intent ( out ) :: psi (:,:) integer :: iat , l , m , lm real ( dp ) :: pi4 , denom pi4 = 4.0_dp * acos ( - 1.0_dp ) psi (:,:) = 0.0_dp do iat = 1 , size ( multipoles , 2 ) do l = 0 , lmax denom = real ( 2 * l + 1 , dp ) * radii ( iat ) ** l do m = - l , l lm = l * l + l + 1 + m psi ( lm , iat ) = pi4 * multipoles ( lm , iat ) / denom end do end do end do end subroutine multipoles_to_psi subroutine pcm_grid_parallel_start ( self , xce , nthreads ) class ( pcm_psi_grid_consumer_t ), target , intent ( inout ) :: self class ( xc_engine_t ), intent ( in ) :: xce integer , intent ( in ) :: nthreads if ( allocated ( self % multipoles )) deallocate ( self % multipoles ) allocate ( self % multipoles ( self % nbasis , self % natom , nthreads ), source = 0.0_dp ) end subroutine pcm_grid_parallel_start subroutine pcm_grid_parallel_stop ( self ) class ( pcm_psi_grid_consumer_t ), intent ( inout ) :: self if ( allocated ( self % multipoles )) then if ( size ( self % multipoles , 3 ) > 1 ) then self % multipoles (:,:, 1 ) = sum ( self % multipoles , dim = 3 ) end if call self % pe % allreduce ( self % multipoles (:,:, 1 ), size ( self % multipoles (:,:, 1 ))) end if end subroutine pcm_grid_parallel_stop subroutine pcm_grid_update ( self , xce , mythread ) class ( pcm_psi_grid_consumer_t ), intent ( inout ) :: self class ( xc_engine_t ), intent ( in ) :: xce integer :: mythread real ( dp ), allocatable :: rho (:,:) real ( dp ) :: qpt , c ( 3 ) integer :: ipt , iown ! PARENT-ATOM partition, exactly the reference ddCOSMO/ddPCM source ! projection (PySCF ddcosmo.make_psi_vmat): every point of the current ! slice belongs to the atom whose atomic grid generated it ! (xce%currAtom); the fuzzy-cell share of the molecular density at that ! point is already carried by the Becke-original/Treutler-shifted ! partition weight inside xce%wts (see build_full_density_multipoles). ! The multipole about the owning sphere uses the outside-sphere leak ! continuation (q*rsph&#94;(2l+1)/r&#94;(l+1) for r>rsph), exactly as PySCF's ! cache_fake_multipoles caps points beyond the vdW sphere, which keeps ! the QM density tail from blowing up the bare interior moment q*r&#94;l. iown = xce % currAtom if ( iown < 1 . or . iown > self % natom ) then call show_message ( 'PCM psi grid consumer: slice parent atom not set' , & with_abort ) end if call xce % compMOs () allocate ( rho ( 2 , xce % numPts ), source = 0.0_dp ) call xce % compRho ( rho ) do ipt = 1 , xce % numPts qpt = - sum ( rho (:, ipt )) * xce % wts ( ipt ) if ( qpt == 0.0_dp ) cycle c (:) = xce % xyzw ( ipt , 1 : 3 ) - self % xyz (:, iown ) call pcm_accumulate_leak ( c , qpt , self % lmax , self % vscales , & self % radii ( iown ), & self % multipoles (:, iown , mythread )) end do end subroutine pcm_grid_update subroutine pcm_grid_post_update ( self , xce , mythread ) class ( pcm_psi_grid_consumer_t ), intent ( inout ) :: self class ( xc_engine_t ), intent ( in ) :: xce integer :: mythread ! No per-slice postprocessing needed; update accumulates directly. end subroutine pcm_grid_post_update subroutine pcm_grid_clean ( self ) class ( pcm_psi_grid_consumer_t ), intent ( inout ) :: self if ( allocated ( self % vscales )) deallocate ( self % vscales ) if ( allocated ( self % radii )) deallocate ( self % radii ) if ( allocated ( self % multipoles )) deallocate ( self % multipoles ) nullify ( self % xyz ) end subroutine pcm_grid_clean subroutine pcm_fock_scale_fd_diagnostic ( natom , xyz , charges , eps , ncav , & nbasis , psi , phi_cav , q_cav , scale_mean , scale_rms , maxerr , nsample ) integer ( c_int ), intent ( in ) :: natom , ncav , nbasis real ( dp ), intent ( in ) :: xyz (:,:), charges (:), eps real ( dp ), intent ( in ) :: psi (:,:), phi_cav (:), q_cav (:) real ( dp ), intent ( out ) :: scale_mean , scale_rms , maxerr integer , intent ( out ) :: nsample integer :: icav , slot , worst_slot , sample_idx ( PCM_FD_MAX_SAMPLES ), rc real ( dp ) :: sample_abs ( PCM_FD_MAX_SAMPLES ) real ( dp ) :: h , eplus , eminus , fd , scale , err , min_abs real ( dp ), allocatable :: phi_plus (:), phi_minus (:), q_tmp (:) character ( kind = c_char ) :: cmsg ( 256 ) character ( len = 256 ) :: fmsg sample_idx (:) = 0 sample_abs (:) = - 1.0_dp do icav = 1 , ncav if ( abs ( q_cav ( icav )) <= 1.0e-14_dp ) cycle worst_slot = 1 min_abs = sample_abs ( 1 ) do slot = 2 , PCM_FD_MAX_SAMPLES if ( sample_abs ( slot ) < min_abs ) then min_abs = sample_abs ( slot ) worst_slot = slot end if end do if ( abs ( q_cav ( icav )) > min_abs ) then sample_abs ( worst_slot ) = abs ( q_cav ( icav )) sample_idx ( worst_slot ) = icav end if end do scale_mean = 0.0_dp scale_rms = 0.0_dp maxerr = 0.0_dp nsample = 0 h = PCM_FD_STEP allocate ( phi_plus ( ncav ), phi_minus ( ncav ), q_tmp ( ncav )) do slot = 1 , PCM_FD_MAX_SAMPLES icav = sample_idx ( slot ) if ( icav <= 0 ) cycle phi_plus (:) = phi_cav (:) phi_minus (:) = phi_cav (:) phi_plus ( icav ) = phi_plus ( icav ) + h phi_minus ( icav ) = phi_minus ( icav ) - h rc = oqp_ddx_pcm_solve_psi ( natom , xyz , charges , eps , ncav , nbasis , & psi , phi_plus , q_tmp , eplus , cmsg , int ( size ( cmsg ), c_int )) if ( rc /= 0 ) then call c_message_to_fortran ( cmsg , fmsg ) call show_message ( 'PCM (ddX) full-psi phi+ FD solve failed: ' // trim ( fmsg ), with_abort ) end if rc = oqp_ddx_pcm_solve_psi ( natom , xyz , charges , eps , ncav , nbasis , & psi , phi_minus , q_tmp , eminus , cmsg , int ( size ( cmsg ), c_int )) if ( rc /= 0 ) then call c_message_to_fortran ( cmsg , fmsg ) call show_message ( 'PCM (ddX) full-psi phi- FD solve failed: ' // trim ( fmsg ), with_abort ) end if fd = ( eplus - eminus ) / ( 2.0_dp * h ) scale = fd / q_cav ( icav ) err = fd - PCM_QCAV_TO_FOCK_SCALE * q_cav ( icav ) scale_mean = scale_mean + scale scale_rms = scale_rms + scale * scale maxerr = max ( maxerr , abs ( err )) nsample = nsample + 1 end do if ( nsample > 0 ) then scale_mean = scale_mean / real ( nsample , dp ) scale_rms = sqrt ( scale_rms / real ( nsample , dp )) else scale_mean = huge ( 1.0_dp ) scale_rms = huge ( 1.0_dp ) maxerr = huge ( 1.0_dp ) end if end subroutine pcm_fock_scale_fd_diagnostic pure integer function packed_index ( i , j ) result ( idx ) integer , intent ( in ) :: i , j if ( i >= j ) then idx = i * ( i - 1 ) / 2 + j else idx = j * ( j - 1 ) / 2 + i end if end function packed_index !> @brief Copy a NUL-terminated C character buffer into a Fortran string. subroutine c_message_to_fortran ( cmsg , fmsg ) character ( kind = c_char ), intent ( in ) :: cmsg (:) character ( len =* ), intent ( out ) :: fmsg integer :: i fmsg = '' do i = 1 , min ( size ( cmsg ), len ( fmsg )) if ( cmsg ( i ) == c_null_char ) exit fmsg ( i : i ) = cmsg ( i ) end do end subroutine c_message_to_fortran end module solvent_pcm","tags":"","url":"sourcefile/solvent_pcm.f90.html"},{"title":"tdhf_mrsf_ekt.F90 – OpenQP Fortran API","text":"Source Code module tdhf_mrsf_ekt_mod implicit none character ( len =* ), parameter :: module_name = \"tdhf_mrsf_ekt_mod\" contains subroutine tdhf_mrsf_ekt_ip_C ( c_handle ) bind ( C , name = \"tdhf_mrsf_ekt_ip\" ) use c_interop , only : oqp_handle_t , oqp_handle_get_info use types , only : information type ( oqp_handle_t ) :: c_handle type ( information ), pointer :: inf inf => oqp_handle_get_info ( c_handle ) call tdhf_mrsf_ekt ( inf , . false .) end subroutine tdhf_mrsf_ekt_ip_C subroutine tdhf_mrsf_ekt_ea_C ( c_handle ) bind ( C , name = \"tdhf_mrsf_ekt_ea\" ) use c_interop , only : oqp_handle_t , oqp_handle_get_info use types , only : information type ( oqp_handle_t ) :: c_handle type ( information ), pointer :: inf inf => oqp_handle_get_info ( c_handle ) call tdhf_mrsf_ekt ( inf , . true .) end subroutine tdhf_mrsf_ekt_ea_C subroutine tdhf_mrsf_ekt ( infos , electron_affinity ) use io_constants , only : iw use oqp_tagarray_driver use types , only : information , energy_results use basis_tools , only : basis_set use messages , only : show_message , with_abort use util , only : measure_time use precision , only : dp use mathlib , only : unpack_matrix , pack_matrix , orthogonal_transform_sym use eigen , only : diag_symm_full use printing , only : print_module_info use tdhf_mrsf_energy_mod , only : tdhf_mrsf_energy use tdhf_mrsf_z_vector_mod , only : tdhf_mrsf_z_vector use dft , only : dft_initialize use mod_dft_molgrid , only : dft_grid_t use scf_addons , only : calc_fock , scf_energy_t implicit none character ( len =* ), parameter :: subroutine_name = \"tdhf_mrsf_ekt\" type ( information ), target , intent ( inout ) :: infos logical , intent ( in ) :: electron_affinity type ( basis_set ), pointer :: basis integer :: nbf , nbf2 , nroot , ok , i , nfocks , nschwz integer :: nactive integer , allocatable :: dom_mo_idx (:), dom_no_idx (:) ! EKT natural-orbital deflation threshold, matching GAMESS EKT-MRSF ! (thresh = 1.0d-2, sfgrad.src:3298). real ( kind = dp ), parameter :: ekt_occ_tol = 1.0e-2_dp real ( kind = dp ), parameter :: hartree_to_ev = 2 7.211386245988_dp real ( kind = dp ), allocatable :: fock_pack (:) type ( dft_grid_t ), target :: ea_molgrid type ( scf_energy_t ) :: ea_energy type ( energy_results ) :: saved_mol_energy real ( kind = dp ), allocatable :: density_alpha_ao (:), density_beta_ao (:) real ( kind = dp ), allocatable :: density_alpha_mo (:,:), density_beta_mo (:,:) real ( kind = dp ), allocatable :: density_ip_mo (:,:), density_ea_mo (:,:) real ( kind = dp ), allocatable :: smat (:) real ( kind = dp ), allocatable :: density_mo (:,:), fock_mo (:,:), lagrangian_mo (:,:) real ( kind = dp ), allocatable :: ea_density_ao (:,:), ea_fock_ao (:,:), saved_fock_ao (:,:) real ( kind = dp ), allocatable :: ekt_metric (:,:), ekt_operator (:,:) real ( kind = dp ), allocatable :: eig (:) real ( kind = dp ), allocatable :: orbitals (:,:), strengths (:), metric_norms (:) real ( kind = dp ), allocatable :: dom_mo_coeff (:), dom_no_coeff (:), dom_no_occ (:) real ( kind = dp ), contiguous , pointer :: fock_a (:), fock_b (:), dmat_a (:), dmat_b (:), mo_a (:,:), td_p (:,:), wao (:) real ( kind = dp ), contiguous , pointer :: density_store (:,:), lagrangian_store (:,:) real ( kind = dp ), contiguous , pointer :: fock_store (:,:), orbital_store (:,:), eig_store (:), strength_store (:) character ( len =* ), parameter :: tags_required ( 7 ) = ( / character ( len = 80 ) :: & OQP_FOCK_A , OQP_DM_A , OQP_DM_B , OQP_VEC_MO_A , OQP_td_p , OQP_WAO , OQP_td_bvec_mo / ) character ( len =* ), parameter :: tags_alloc ( 6 ) = ( / character ( len = 80 ) :: & OQP_mrsf_ekt_density_mo , OQP_mrsf_ekt_lagrangian_mo , OQP_mrsf_ekt_fock_mo , & OQP_mrsf_ekt_orbitals_mo , OQP_mrsf_ekt_eigenvalues , OQP_mrsf_ekt_strengths / ) ! Run the parent MRSF calculation and Z-vector first so the selected ! neutral state's relaxed density P and energy-weighted density / ! Lagrangian W are available.  The EKT step then builds the IP/EA ! generalized eigenproblem in the MRSF molecular-orbital basis. call tdhf_mrsf_energy ( infos ) call tdhf_mrsf_z_vector ( infos ) open ( unit = iw , file = infos % log_filename , position = \"append\" ) if ( electron_affinity ) then call print_module_info ( 'MRSF_EKT_EA' , 'Computing MRSF-EKT electron affinities' ) else call print_module_info ( 'MRSF_EKT_IP' , 'Computing MRSF-EKT ionization potentials' ) end if basis => infos % basis nbf = basis % nbf nbf2 = nbf * ( nbf + 1 ) / 2 ! Print/store all retained EKT Dyson roots available after the natural- ! orbital deflation, matching the GAMESS behavior.  The TDDFT NSTATE input ! still controls the parent MRSF calculation; it is not an EKT print cap. nroot = nbf select case ( infos % control % scftype ) case ( 1 ) nfocks = 1 case default nfocks = 2 end select call data_has_tags ( infos % dat , tags_required , module_name , subroutine_name , WITH_ABORT ) call tagarray_get_data ( infos % dat , OQP_FOCK_A , fock_a ) call tagarray_get_data ( infos % dat , OQP_DM_A , dmat_a ) call tagarray_get_data ( infos % dat , OQP_DM_B , dmat_b ) call tagarray_get_data ( infos % dat , OQP_VEC_MO_A , mo_a ) call tagarray_get_data ( infos % dat , OQP_td_p , td_p ) call tagarray_get_data ( infos % dat , OQP_WAO , wao ) allocate ( fock_pack ( nbf2 ), & ea_density_ao ( nbf2 , nfocks ), ea_fock_ao ( nbf2 , nfocks ), saved_fock_ao ( nbf2 , nfocks ), & density_alpha_ao ( nbf2 ), density_beta_ao ( nbf2 ), & density_alpha_mo ( nbf , nbf ), density_beta_mo ( nbf , nbf ), & density_ip_mo ( nbf , nbf ), density_ea_mo ( nbf , nbf ), & density_mo ( nbf , nbf ), fock_mo ( nbf , nbf ), & lagrangian_mo ( nbf , nbf ), ekt_metric ( nbf , nbf ), ekt_operator ( nbf , nbf ), & orbitals ( nbf , nroot ), strengths ( nroot ), smat ( nbf2 ), source = 0.0_dp , stat = ok ) if ( ok /= 0 ) call show_message ( 'Cannot allocate memory' , WITH_ABORT ) ! MRSF-EKT uses the relaxed target-state one-particle density P and the ! relaxed energy-weighted density / Lagrangian W generated by the MRSF ! Z-vector.  OQP_td_p is the MRSF Z-vector relaxed *difference* density in ! the AO basis, spin-blocked (alpha,beta), in the same contravariant ! C*M*C&#94;T convention as dmat and already 0.5-scaled in tdhf_mrsf_z_vector. ! Hence dmat_sigma + td_p(:,sigma) is the total relaxed one-particle ! density of the target (S0) response state for each spin. density_alpha_ao = dmat_a + td_p (:, 1 ) density_beta_ao = dmat_b + td_p (:, 2 ) ! AO -> MO transform of the one-particle DENSITY.  A density is ! contravariant: its natural-orbital (MO) representation is obtained with ! the metric-covariant form  D_MO = C&#94;T S P S C, NOT C&#94;T P C.  The SCF ! MOs satisfy C&#94;T S C = I, so plain C&#94;T P C mis-scales by the overlap and ! gives Tr(D_MO) != N_elec.  Operators (Fock, Lagrangian) keep the plain ! C&#94;T A C transform below. call get_overlap_matrix ( infos , nbf , smat ) call density_ao_to_mo ( nbf , nbf2 , density_alpha_ao , smat , mo_a , density_alpha_mo ) call density_ao_to_mo ( nbf , nbf2 , density_beta_ao , smat , mo_a , density_beta_mo ) density_ip_mo = density_alpha_mo density_ea_mo = density_beta_mo ! Acceptance checks (printed): AO electron counts Tr(P_sigma * S) and the ! MO-density traces must both equal nelec_sigma, and MO occupations must ! be physically bounded. call ekt_density_trace_checks ( infos , nbf , nbf2 , density_alpha_ao , & density_beta_ao , smat , density_alpha_mo , density_beta_mo , iw ) call orthogonal_transform_sym ( nbf , nbf , fock_a , mo_a , nbf , fock_pack ) call unpack_matrix ( fock_pack , fock_mo , nbf , 'U' ) ! --------------------------------------------------------------------- ! EKT-MRSF state-specific Lagrangian W~, reproduced exactly from the ! GAMESS-US reference implementation (sfgrad.src, the IF(MREKT) block; ! Pomogaev et al., JPCL 2021, eq 5): ! !   W~_MO = -1/2 ( WMO + Lambda_MO ) ! ! where, in the MO basis and using the density metric C&#94;T S M S C ! (a Lagrangian density is contravariant, like D): !   * Lambda = energy-weighted density Sum_k eps_k C_k C_k&#94;T  (= eijden / !     GAMESS DAF record 36).  OpenQP's eijden halves the packed diagonal !     (a gradient-consumer convention, grd1.src:624); the GAMESS EKT path !     reads the raw record, so the half-diagonal is undone here. !   * WMO = the MRSF response Lagrangian.  OpenQP stores !     wao = 1/4 C WMO C&#94;T (z-vector applies two halves), while GAMESS uses !     the bare WMO (records 419/429 = 1/2 C WMO C&#94;T).  Hence !     WMO = 2 C&#94;T S wao S C. ! --------------------------------------------------------------------- block use grd1 , only : eijden real ( kind = dp ), allocatable :: lam_ao (:), lam_mo (:,:), wmo_mo (:,:) integer :: gok , kk , ijd allocate ( lam_ao ( nbf2 ), lam_mo ( nbf , nbf ), wmo_mo ( nbf , nbf ), & source = 0.0_dp , stat = gok ) if ( gok /= 0 ) call show_message ( 'Cannot allocate memory' , WITH_ABORT ) call eijden ( lam_ao , nbf , infos ) ijd = 0 do kk = 1 , nbf ijd = ijd + kk ! packed-upper diagonal index lam_ao ( ijd ) = 2.0_dp * lam_ao ( ijd ) ! undo eijden's half-diagonal end do call density_ao_to_mo ( nbf , nbf2 , lam_ao , smat , mo_a , lam_mo ) ! C&#94;T S Lambda S C call density_ao_to_mo ( nbf , nbf2 , wao , smat , mo_a , wmo_mo ) ! C&#94;T S wao S C wmo_mo = 2.0_dp * wmo_mo ! bare GAMESS WMO lagrangian_mo = - 0.5_dp * ( wmo_mo + lam_mo ) lagrangian_mo = 0.5_dp * ( lagrangian_mo + transpose ( lagrangian_mo )) deallocate ( lam_ao , lam_mo , wmo_mo ) end block if ( electron_affinity ) then ! EKT-EA: (F - W) * x = (I - P) * x * lambda. ! GAMESS rebuilds the Fock matrix for EA from the relaxed MRSF density ! (sfgrad.src:3269-3280, BUILDFOCK(..., MRDEA)) before forming F-W. ! Reproduce that path here instead of using the reference SCF Fock. ! GAMESS MRDEA uses the spin-averaged relaxed MRSF density ! P = 1/2*(Da+Db) for the EA complement metric, not beta alone. density_mo = 0.5_dp * ( density_ip_mo + density_ea_mo ) ekt_metric = - density_mo do i = 1 , nbf ekt_metric ( i , i ) = ekt_metric ( i , i ) + 1.0_dp end do ! GAMESS MRDEA builds a closed-shell Fock from the spin-summed ! relaxed density: LDVAL = AO(Pavg), DSCAL(2), BUILDFOCK; internally ! its DFT path halves that total density for alpha=beta. ea_density_ao (:, 1 ) = 0.5_dp * ( density_alpha_ao + density_beta_ao ) if ( nfocks > 1 ) ea_density_ao (:, 2 ) = ea_density_ao (:, 1 ) saved_fock_ao (:, 1 ) = fock_a if ( nfocks > 1 ) then call tagarray_get_data ( infos % dat , OQP_FOCK_B , fock_b ) saved_fock_ao (:, 2 ) = fock_b end if saved_mol_energy = infos % mol_energy nschwz = 0 if ( infos % control % hamilton >= 20 ) call dft_initialize ( infos , basis , ea_molgrid ) call calc_fock ( basis , infos , ea_molgrid , ea_fock_ao , ea_energy , & mo_a_in = mo_a , dens_in = ea_density_ao , nschwz = nschwz ) ! calc_fock updates the stored SCF Fock and infos%mol_energy%energy as ! side effects; restore them because this EA-specific relaxed-density ! Fock is only an EKT operator ingredient, not a new SCF reference. fock_a = saved_fock_ao (:, 1 ) if ( nfocks > 1 ) fock_b = saved_fock_ao (:, 2 ) infos % mol_energy = saved_mol_energy call orthogonal_transform_sym ( nbf , nbf , ea_fock_ao (:, 1 ), mo_a , nbf , fock_pack ) call unpack_matrix ( fock_pack , fock_mo , nbf , 'U' ) write ( iw , '(/,2x,\"EKT-EA: rebuilt relaxed-density Fock for EA operator (GAMESS MRDEA path)\")' ) ekt_operator = fock_mo - lagrangian_mo else ! EKT: W * x = P * x * lambda.  Metric is the spin-summed relaxed ! density P = 1/2 (Da_MO + Db_MO) (GAMESS sfgrad.src:3115); for H2O S0 ! this gives 5 occupied natural orbitals at occupation ~1. density_mo = 0.5_dp * ( density_ip_mo + density_ea_mo ) ekt_metric = density_mo ekt_operator = lagrangian_mo end if ! Natural-orbital occupation deflation + EKT generalized solve. ! The metric D_MO is non-diagonal, so a diag(D) > tol active-space ! selection is mathematically invalid.  Diagonalize the metric to obtain ! natural orbitals/occupations, keep occ > occ_tol, project W and D into ! the retained NO subspace, solve the generalized eigenproblem there, ! metric-normalize, and back-transform the Dyson orbitals.  Pole strengths ! come out <= 1 by construction. allocate ( eig ( nroot ), metric_norms ( nroot ), dom_mo_coeff ( nroot ), dom_no_coeff ( nroot ), & dom_no_occ ( nroot ), source = 0.0_dp , stat = ok ) if ( ok /= 0 ) call show_message ( 'Cannot allocate memory' , WITH_ABORT ) allocate ( dom_mo_idx ( nroot ), dom_no_idx ( nroot ), source = 0 , stat = ok ) if ( ok /= 0 ) call show_message ( 'Cannot allocate memory' , WITH_ABORT ) ! Deflation threshold matches GAMESS EKT (thresh = 1.0d-2, sfgrad.src:3298): ! keep only natural orbitals with occupation > 1e-2, removing low-occupation ! null/relaxation channels. call solve_ekt_no_deflation ( nbf , nroot , ekt_operator , ekt_metric , & ekt_occ_tol , eig , orbitals , strengths , metric_norms , dom_mo_idx , & dom_mo_coeff , dom_no_idx , dom_no_coeff , dom_no_occ , nactive , iw ) call infos % dat % alloc_or_die ( OQP_mrsf_ekt_density_mo , ( / nbf , nbf / ), density_store , & description = 'MRSF-EKT metric density P in MO basis' ) call infos % dat % alloc_or_die ( OQP_mrsf_ekt_lagrangian_mo , ( / nbf , nbf / ), lagrangian_store , & description = 'MRSF-EKT Lagrangian W in MO basis' ) call infos % dat % alloc_or_die ( OQP_mrsf_ekt_fock_mo , ( / nbf , nbf / ), fock_store , & description = 'MRSF-EKT Fock matrix in MO basis' ) call infos % dat % alloc_or_die ( OQP_mrsf_ekt_orbitals_mo , ( / nbf , nroot / ), orbital_store , & description = 'MRSF-EKT Dyson-like orbital coefficients in MO basis' ) call infos % dat % alloc_or_die ( OQP_mrsf_ekt_eigenvalues , ( / nroot / ), eig_store , & description = 'MRSF-EKT generalized-eigenproblem eigenvalues in Hartree' ) call infos % dat % alloc_or_die ( OQP_mrsf_ekt_strengths , ( / nroot / ), strength_store , & description = 'MRSF-EKT pole strengths' ) density_store = density_mo lagrangian_store = lagrangian_mo fock_store = fock_mo orbital_store = orbitals eig_store = eig strength_store = strengths if ( electron_affinity ) then write ( iw , '(/,2x,\"MRSF-EKT electron affinities (Dyson roots)\")' ) else write ( iw , '(/,2x,\"MRSF-EKT ionization potentials (Dyson roots)\")' ) end if write ( iw , '(2x,\"Rows index EKT Dyson roots/orbitals, not TDDFT excited states.\")' ) ! eig holds the EKT eigenvalues epsilon of  W C = D C epsilon.  The ! electron binding energy (IP) of a detachment is -epsilon; print both ! the eigenvalue and the eBE in hartree and eV with the Dyson pole ! strength (norm of the Dyson vector, <= 1 for a physical root). write ( iw , '(2x,\"dyson\",6x,\"eig(ha)\",8x,\"eBE(ha)\",8x,\"eBE(eV)\",7x,\"metric\",7x,\"strength\")' ) do i = 1 , min ( nroot , nactive ) write ( iw , '(2x,I5,2x,F14.6,2x,F14.6,2x,F12.4,2x,F12.6,2x,F12.6)' ) & i , eig ( i ), - eig ( i ), - eig ( i ) * hartree_to_ev , metric_norms ( i ), strengths ( i ) end do write ( iw , '(/,2x,\"--- EKT Dyson-root character diagnostics ---\")' ) write ( iw , '(2x,\"dyson\",2x,\"dom_mo\",2x,\"mo_coeff\",2x,\"dom_no\",2x,\"no_coeff\",2x,\"no_occ\",2x,\"character\",2x,\"spurious\")' ) do i = 1 , min ( nroot , nactive ) write ( iw , '(2x,I5,2x,I6,2x,F10.6,2x,I6,2x,F10.6,2x,F10.6,2x,A12,2x,L1)' ) & i , dom_mo_idx ( i ), dom_mo_coeff ( i ), dom_no_idx ( i ), dom_no_coeff ( i ), & dom_no_occ ( i ), ekt_root_character ( dom_no_occ ( i ), electron_affinity ), & ekt_is_spurious ( - eig ( i ) * hartree_to_ev , metric_norms ( i ), strengths ( i )) end do write ( iw , '(2x,\"--------------------------------------\")' ) if ( electron_affinity ) then write ( iw , '(/,2x,\"MRSF-EKT Dyson orbitals (AO-basis coefficients, GAMESS-style layout; columns = EA roots)\")' ) else write ( iw , '(/,2x,\"MRSF-EKT Dyson orbitals (AO-basis coefficients, GAMESS-style layout; columns = IP roots)\")' ) end if call print_dyson_orbitals ( basis , mo_a , orbitals , eig , strengths , nbf , min ( nroot , nactive )) call flush ( iw ) call measure_time ( print_total = 1 , log_unit = iw ) close ( iw ) end subroutine tdhf_mrsf_ekt !> @brief Print Dyson orbitals in a GAMESS-like block. !> @detail The EKT solver returns Dyson-orbital coefficients in the OpenQP !>         MO basis.  For direct log-level comparison with GAMESS, transform !>         them back to the AO basis and print five roots per block with !>         ENERGY and STRENGTH header rows followed by AO basis-function !>         labels and coefficients.  This routine is output-only: it does not !>         change eigenvalues, strengths, root selection, or stored MO-basis !>         Dyson orbitals. subroutine print_dyson_orbitals ( basis , mo_a , dyson_mo , eig , strengths , nbf , nroot ) use precision , only : dp use io_constants , only : iw use basis_tools , only : basis_set implicit none type ( basis_set ), intent ( in ) :: basis integer , intent ( in ) :: nbf , nroot real ( kind = dp ), intent ( in ) :: mo_a ( nbf , nbf ), dyson_mo ( nbf , * ), eig ( * ), strengths ( * ) integer , parameter :: mxlen = 5 integer :: i , j , k , i0 , i1 real ( kind = dp ), allocatable :: dyson_ao (:,:) allocate ( dyson_ao ( nbf , nroot ), source = 0.0_dp ) do i = 1 , nroot do k = 1 , nbf do j = 1 , nbf dyson_ao ( j , i ) = dyson_ao ( j , i ) + mo_a ( j , k ) * dyson_mo ( k , i ) end do end do end do write ( iw , '(/,10x,46(\"-\"))' ) write ( iw , '(12x,\"EKT DYSON ORBITALS, ENERGIES AND NORMS\")' ) write ( iw , '(12x,\"OpenQP AO-basis coefficients; GAMESS-style layout\")' ) write ( iw , '(10x,46(\"-\"))' ) do i0 = 1 , nroot , mxlen i1 = min ( nroot , i0 + mxlen - 1 ) write ( iw , '(/,14x,5i11)' ) ( i , i = i0 , i1 ) write ( iw , '(5x,\"ENERGY\",3x,5f11.6)' ) ( eig ( i ), i = i0 , i1 ) write ( iw , '(5x,\"STRENGTH\",1x,5f11.6)' ) ( strengths ( i ), i = i0 , i1 ) write ( iw , '(14x,5(10x,a1))' ) ( \"A\" , i = i0 , i1 ) do j = 1 , nbf write ( iw , '(i5,2x,a8,5f11.6)' ) j , basis % bf_label ( j ), ( dyson_ao ( j , i ), i = i0 , i1 ) end do end do deallocate ( dyson_ao ) end subroutine print_dyson_orbitals !> @brief Fetch the packed AO overlap matrix S (OQP_SM) into smat(nbf2). subroutine get_overlap_matrix ( infos , nbf , smat ) use types , only : information use oqp_tagarray_driver use precision , only : dp use messages , only : show_message , with_abort implicit none type ( information ), target , intent ( inout ) :: infos integer , intent ( in ) :: nbf real ( kind = dp ), intent ( out ) :: smat (:) real ( kind = dp ), contiguous , pointer :: s_p (:) character ( len =* ), parameter :: sn = \"get_overlap_matrix\" call data_has_tags ( infos % dat , ( / character ( len = 80 ) :: OQP_SM / ), & module_name , sn , WITH_ABORT ) call tagarray_get_data ( infos % dat , OQP_SM , s_p ) smat ( 1 : nbf * ( nbf + 1 ) / 2 ) = s_p ( 1 : nbf * ( nbf + 1 ) / 2 ) end subroutine get_overlap_matrix !> @brief Metric-covariant AO->MO transform of a one-particle density: !>          D_MO = C&#94;T (S P S) C !> @details A density is contravariant, so its MO (natural-orbital) !>          representation needs the overlap metric on both sides.  With !>          C&#94;T S C = I this yields Tr(D_MO) = Tr(P S) = N_elec and MO !>          occupations bounded in [0,1] (per spin).  Plain C&#94;T P C (used !>          for operators) is WRONG for a density. subroutine density_ao_to_mo ( nbf , nbf2 , p_ao_pack , s_pack , mo , d_mo ) use precision , only : dp use mathlib , only : unpack_matrix , pack_matrix , orthogonal_transform_sym use messages , only : show_message , with_abort implicit none integer , intent ( in ) :: nbf , nbf2 real ( kind = dp ), intent ( in ) :: p_ao_pack (:) ! packed AO density (upper) real ( kind = dp ), intent ( in ) :: s_pack (:) ! packed AO overlap (upper) real ( kind = dp ), intent ( in ) :: mo ( nbf , nbf ) ! MO coefficients C (AO x MO) real ( kind = dp ), intent ( out ) :: d_mo ( nbf , nbf ) ! MO-basis density real ( kind = dp ), allocatable :: p_ao (:,:), s_ao (:,:), sps (:,:), tmp (:,:), sps_pack (:) integer :: ok allocate ( p_ao ( nbf , nbf ), s_ao ( nbf , nbf ), sps ( nbf , nbf ), tmp ( nbf , nbf ), & sps_pack ( nbf2 ), source = 0.0_dp , stat = ok ) if ( ok /= 0 ) call show_message ( 'Cannot allocate memory' , WITH_ABORT ) call unpack_matrix ( p_ao_pack , p_ao , nbf , 'U' ) call unpack_matrix ( s_pack , s_ao , nbf , 'U' ) tmp = matmul ( s_ao , p_ao ) ! S P sps = matmul ( tmp , s_ao ) ! S P S  (symmetric) sps = 0.5_dp * ( sps + transpose ( sps )) call pack_matrix ( sps , sps_pack , 'U' ) call orthogonal_transform_sym ( nbf , nbf , sps_pack , mo , nbf , sps_pack ) call unpack_matrix ( sps_pack , d_mo , nbf , 'U' ) deallocate ( p_ao , s_ao , sps , tmp , sps_pack ) end subroutine density_ao_to_mo !> @brief Acceptance/trace checks for the EKT relaxed density (printed). !> @details Verifies Tr(P_sigma S) = nelec_sigma in the AO basis and that !>          the MO-density trace matches, with bounded MO occupations. subroutine ekt_density_trace_checks ( infos , nbf , nbf2 , pa_ao_pack , pb_ao_pack , & s_pack , da_mo , db_mo , iw ) use types , only : information use precision , only : dp use mathlib , only : unpack_matrix use messages , only : show_message , with_abort implicit none type ( information ), target , intent ( inout ) :: infos integer , intent ( in ) :: nbf , nbf2 , iw real ( kind = dp ), intent ( in ) :: pa_ao_pack (:), pb_ao_pack (:), s_pack (:) real ( kind = dp ), intent ( in ) :: da_mo ( nbf , nbf ), db_mo ( nbf , nbf ) real ( kind = dp ), allocatable :: pa (:,:), pb (:,:), s_ao (:,:) real ( kind = dp ) :: trPaS , trPbS , trDa , trDb , occ_min , occ_max integer :: i , j , nea , neb , ok allocate ( pa ( nbf , nbf ), pb ( nbf , nbf ), s_ao ( nbf , nbf ), source = 0.0_dp , stat = ok ) if ( ok /= 0 ) call show_message ( 'Cannot allocate memory' , WITH_ABORT ) call unpack_matrix ( pa_ao_pack , pa , nbf , 'U' ) call unpack_matrix ( pb_ao_pack , pb , nbf , 'U' ) call unpack_matrix ( s_pack , s_ao , nbf , 'U' ) nea = int ( infos % mol_prop % nelec_A ) neb = int ( infos % mol_prop % nelec_B ) trPaS = 0.0_dp ; trPbS = 0.0_dp do i = 1 , nbf do j = 1 , nbf trPaS = trPaS + pa ( i , j ) * s_ao ( j , i ) trPbS = trPbS + pb ( i , j ) * s_ao ( j , i ) end do end do trDa = 0.0_dp ; trDb = 0.0_dp ; occ_min = 1.0d30 ; occ_max = - 1.0d30 do i = 1 , nbf trDa = trDa + da_mo ( i , i ) trDb = trDb + db_mo ( i , i ) occ_min = min ( occ_min , da_mo ( i , i ), db_mo ( i , i )) occ_max = max ( occ_max , da_mo ( i , i ), db_mo ( i , i )) end do write ( iw , '(/,2x,\"--- EKT relaxed-density acceptance checks ---\")' ) write ( iw , '(2x,\"Tr(Pa S) = \",f12.6,\"   Tr(Da_MO) = \",f12.6)' ) trPaS , trDa write ( iw , '(2x,\"Tr(Pb S) = \",f12.6,\"   Tr(Db_MO) = \",f12.6)' ) trPbS , trDb write ( iw , '(2x,\"(AO and MO traces must agree; target-state singlet S0)\")' ) write ( iw , '(2x,\"MO occupations range: [\",f10.6,\",\",f10.6,\"]\")' ) occ_min , occ_max write ( iw , '(2x,\"--------------------------------------------\",/)' ) call flush ( iw ) deallocate ( pa , pb , s_ao ) end subroutine ekt_density_trace_checks !> @brief EKT solve with natural-orbital occupation deflation. !> @details Solves  W X = D X eps  where the metric D (= ekt_metric) is the !>          relaxed one-particle density (IP) or its particle complement (EA), !>          and W (= ekt_operator) is the EKT Lagrangian.  Because D is !>          non-diagonal, deflation must be done on its NATURAL ORBITALS, not !>          its diagonal: !>            1. symmetrize D !>            2. diagonalize  D U = U n   (natural orbitals U, occupations n) !>            3. keep NOs with n_i > occ_tol !>            4. project  D_NO = U_keep&#94;T D U_keep,  W_NO = U_keep&#94;T W U_keep !>            5. solve the generalized problem in the retained NO space !>            6. metric-normalize eigenvectors:  X&#94;T D_NO X = 1 !>            7. back-transform Dyson orbitals  C = U_keep X !>            8. pole strength = X&#94;T D_NO X  (<= 1 physical) subroutine solve_ekt_no_deflation ( nbf , nroot , wmat , dmat , occ_tol , & eig , dyson_mo , strengths , metric_norms , dom_mo_idx , dom_mo_coeff , & dom_no_idx , dom_no_coeff , dom_no_occ , nkeep , iw ) use precision , only : dp use eigen , only : diag_symm_full use messages , only : show_message , with_abort implicit none integer , intent ( in ) :: nbf , nroot , iw real ( kind = dp ), intent ( in ) :: wmat ( nbf , nbf ), dmat ( nbf , nbf ), occ_tol real ( kind = dp ), intent ( out ) :: eig ( nroot ) real ( kind = dp ), intent ( out ) :: dyson_mo ( nbf , nroot ) real ( kind = dp ), intent ( out ) :: strengths ( nroot ) real ( kind = dp ), intent ( out ) :: metric_norms ( nroot ) integer , intent ( out ) :: dom_mo_idx ( nroot ), dom_no_idx ( nroot ) real ( kind = dp ), intent ( out ) :: dom_mo_coeff ( nroot ), dom_no_coeff ( nroot ), dom_no_occ ( nroot ) integer , intent ( out ) :: nkeep real ( kind = dp ), allocatable :: dsym (:,:), nocc (:), uno (:,:), ukeep (:,:) integer , allocatable :: kept_idx (:) real ( kind = dp ), allocatable :: d_no (:,:), w_no (:,:), tmp (:,:) real ( kind = dp ), allocatable :: xvec (:,:), eps (:), cdys (:,:), d_times_x (:) real ( kind = dp ) :: tr_disc , occ_min , occ_max , xnorm , str , coeff_abs , best_abs integer :: i , j , m , ierr , ok , nout , best_idx , out_idx , n_skipped ! EKT eigenvalue print/retention threshold.  GAMESS skips near-zero EKT ! eigenvalues (|eps| <= thresh) when transferring solved EKT roots to its ! output (sfgrad.src:3411, thresh = 1.0d-2 Ha); mirror that here so the ! printed/stored Dyson ladder aligns with GAMESS without a one-root shift. ! Kept separate from the NO occupation tolerance (ekt_occ_tol) which only ! governs natural-orbital deflation. real ( kind = dp ), parameter :: ekt_eig_tol = 1.0e-2_dp ! (1) symmetrize the metric allocate ( dsym ( nbf , nbf ), nocc ( nbf ), uno ( nbf , nbf ), source = 0.0_dp , stat = ok ) if ( ok /= 0 ) call show_message ( 'Cannot allocate memory' , WITH_ABORT ) do j = 1 , nbf do i = 1 , nbf dsym ( i , j ) = 0.5_dp * ( dmat ( i , j ) + dmat ( j , i )) end do end do ! (2) diagonalize the metric -> natural orbitals U, occupations n uno = dsym call diag_symm_full ( 1 , nbf , uno , nbf , nocc , ierr ) if ( ierr /= 0 ) call show_message ( 'EKT: NO diagonalization failed' , WITH_ABORT ) ! (3) keep NOs with physical occupation n_i > occ_tol m = 0 tr_disc = 0.0_dp do i = 1 , nbf if ( nocc ( i ) > occ_tol ) then m = m + 1 else tr_disc = tr_disc + nocc ( i ) end if end do if ( m == 0 ) call show_message ( 'EKT: no NOs above occupation tolerance' , WITH_ABORT ) allocate ( ukeep ( nbf , m ), source = 0.0_dp , stat = ok ) if ( ok /= 0 ) call show_message ( 'Cannot allocate memory' , WITH_ABORT ) allocate ( kept_idx ( m ), source = 0 , stat = ok ) if ( ok /= 0 ) call show_message ( 'Cannot allocate memory' , WITH_ABORT ) j = 0 occ_min = 1.0d30 ; occ_max = - 1.0d30 do i = 1 , nbf if ( nocc ( i ) > occ_tol ) then j = j + 1 ukeep (:, j ) = uno (:, i ) kept_idx ( j ) = i occ_min = min ( occ_min , nocc ( i )) occ_max = max ( occ_max , nocc ( i )) end if end do ! (4) deflation diagnostics write ( iw , '(/,2x,\"--- EKT natural-orbital deflation ---\")' ) write ( iw , '(2x,\"occ_tol = \",es10.2,\"   retained NOs = \",i0,\" / \",i0)' ) occ_tol , m , nbf write ( iw , '(2x,\"discarded trace = \",f12.6,\"   retained occ range = [\",f10.6,\",\",f10.6,\"]\")' ) & tr_disc , occ_min , occ_max write ( iw , '(2x,\"eig_tol = \",es10.2,\" Ha   (skip EKT roots with |eps| <= eig_tol; GAMESS sfgrad.src)\")' ) & ekt_eig_tol write ( iw , '(2x,\"-------------------------------------\",/)' ) ! (5) project D and W into the retained NO space allocate ( d_no ( m , m ), w_no ( m , m ), tmp ( nbf , m ), source = 0.0_dp , stat = ok ) if ( ok /= 0 ) call show_message ( 'Cannot allocate memory' , WITH_ABORT ) tmp = matmul ( dsym , ukeep ) d_no = matmul ( transpose ( ukeep ), tmp ) tmp = matmul ( wmat , ukeep ) w_no = matmul ( transpose ( ukeep ), tmp ) d_no = 0.5_dp * ( d_no + transpose ( d_no )) w_no = 0.5_dp * ( w_no + transpose ( w_no )) ! (6) solve the generalized problem in the retained NO space allocate ( xvec ( m , m ), eps ( m ), source = 0.0_dp , stat = ok ) if ( ok /= 0 ) call show_message ( 'Cannot allocate memory' , WITH_ABORT ) call solve_symmetric_generalized ( w_no , d_no , eps , xvec , m , ierr ) if ( ierr /= 0 ) call show_message ( '(A,I0)' , & 'EKT: NO-space generalized solve failed; info=' , ierr , WITH_ABORT ) ! (7) metric-normalize eigenvectors:  X&#94;T D_NO X = 1 do j = 1 , m xnorm = 0.0_dp do i = 1 , m xnorm = xnorm + xvec ( i , j ) * dot_product ( d_no ( i ,:), xvec (:, j )) end do if ( xnorm > 1.0e-14_dp ) xvec (:, j ) = xvec (:, j ) / sqrt ( xnorm ) end do ! (8) back-transform Dyson orbitals to the MO basis  C = U_keep X. !     Metric norms are X&#94;T D_NO X after normalization (=1 for retained !     physical roots).  EKT pole strengths follow the GAMESS/Pomogaev !     definition X&#94;T D_NO&#94;2 X; weak Dyson roots therefore retain small !     strengths instead of being forced to 1 by metric normalization. allocate ( cdys ( nbf , m ), d_times_x ( m ), source = 0.0_dp , stat = ok ) if ( ok /= 0 ) call show_message ( 'Cannot allocate memory' , WITH_ABORT ) cdys = matmul ( ukeep , xvec ) eig = 0.0_dp dyson_mo = 0.0_dp strengths = 0.0_dp metric_norms = 0.0_dp dom_mo_idx = 0 dom_no_idx = 0 dom_mo_coeff = 0.0_dp dom_no_coeff = 0.0_dp dom_no_occ = 0.0_dp ! Transfer solved EKT roots to the output arrays, skipping near-zero EKT ! eigenvalues the GAMESS way (|eps| <= ekt_eig_tol).  The source eigenpair ! index is j (xvec/cdys/eps); out_idx is a separate compressed counter into ! the output arrays so the printed/stored ladder matches GAMESS. out_idx = 0 n_skipped = 0 do j = 1 , m if ( abs ( eps ( j )) <= ekt_eig_tol ) then n_skipped = n_skipped + 1 cycle end if out_idx = out_idx + 1 if ( out_idx > nroot ) exit eig ( out_idx ) = eps ( j ) dyson_mo (:, out_idx ) = cdys (:, j ) str = 0.0_dp do i = 1 , m str = str + xvec ( i , j ) * dot_product ( d_no ( i ,:), xvec (:, j )) end do metric_norms ( out_idx ) = str d_times_x = matmul ( d_no , xvec (:, j )) strengths ( out_idx ) = dot_product ( d_times_x , d_times_x ) best_abs = - 1.0_dp best_idx = 0 do i = 1 , nbf coeff_abs = abs ( cdys ( i , j )) if ( coeff_abs > best_abs ) then best_abs = coeff_abs best_idx = i end if end do dom_mo_idx ( out_idx ) = best_idx if ( best_idx > 0 ) dom_mo_coeff ( out_idx ) = cdys ( best_idx , j ) best_abs = - 1.0_dp best_idx = 0 do i = 1 , m coeff_abs = abs ( xvec ( i , j )) if ( coeff_abs > best_abs ) then best_abs = coeff_abs best_idx = i end if end do if ( best_idx > 0 ) then dom_no_idx ( out_idx ) = kept_idx ( best_idx ) dom_no_coeff ( out_idx ) = xvec ( best_idx , j ) dom_no_occ ( out_idx ) = nocc ( kept_idx ( best_idx )) end if end do nout = min ( out_idx , nroot ) ! The caller uses nkeep as nactive when printing rows/Dyson orbitals, so it ! must reflect the number of stored output roots (nout), not the retained ! NO-space dimension (m); otherwise a zero row is printed for skipped roots. nkeep = nout write ( iw , '(2x,\"EKT eigenvalue filter: skipped \",i0,\" near-zero root(s) \", & &\"(|eps| <= \",es10.2,\" Ha); stored \",i0,\" / \",i0,\" roots\")' ) & n_skipped , ekt_eig_tol , nout , nroot deallocate ( dsym , nocc , uno , ukeep , kept_idx , d_no , w_no , tmp , xvec , eps , cdys , d_times_x ) end subroutine solve_ekt_no_deflation pure logical function ekt_is_spurious ( ebe_ev , metric_norm , pole_strength ) result ( flag ) use precision , only : dp implicit none real ( kind = dp ), intent ( in ) :: ebe_ev , metric_norm , pole_strength flag = ( abs ( ebe_ev ) > 1.0e4_dp ) . or . ( metric_norm < 0.0_dp ) . or . & ( metric_norm > 1.05_dp ) . or . ( pole_strength < 0.0_dp ) . or . & ( pole_strength > 1.05_dp ) end function ekt_is_spurious pure function ekt_root_character ( no_occ , electron_affinity ) result ( label ) use precision , only : dp implicit none real ( kind = dp ), intent ( in ) :: no_occ logical , intent ( in ) :: electron_affinity character ( len = 12 ) :: label if ( electron_affinity ) then if ( no_occ < 0.20_dp ) then label = 'virtual' else if ( no_occ > 0.80_dp ) then label = 'occupied' else label = 'mixed' end if else if ( no_occ > 0.80_dp ) then label = 'occupied' else if ( no_occ < 0.20_dp ) then label = 'virtual' else label = 'mixed' end if end if end function ekt_root_character !> @brief Solve the EKT generalized eigenproblem  op * C = metric * C * lambda !> @details The EKT working equation (eq 1 of Park et al., JCTC 2024) is a !>          symmetric generalized eigenproblem in which the metric is the !>          relaxed one-particle density (IP) or its particle complement (EA). !>          That metric is symmetric positive semidefinite but in general NOT !>          diagonal: the MRSF Z-vector relaxation introduces off-diagonal !>          occupation couplings in the ground-state MO basis.  We therefore !>          reduce the problem by Loewdin (symmetric) orthogonalization built !>          from the full eigendecomposition of the metric, discarding the !>          null-space directions whose occupation eigenvalues fall below a !>          tolerance.  This is the rigorous replacement for a diagonal-only !>          metric scaling, which is exact only when the metric is diagonal. subroutine solve_symmetric_generalized ( operator , metric , eigenvalues , eigenvectors , n , ierr ) use precision , only : dp use eigen , only : diag_symm_full use messages , only : show_message , with_abort implicit none integer , intent ( in ) :: n real ( kind = dp ), intent ( inout ) :: operator ( n , n ) real ( kind = dp ), intent ( in ) :: metric ( n , n ) real ( kind = dp ), intent ( out ) :: eigenvalues ( n ), eigenvectors ( n , n ) integer , intent ( out ) :: ierr integer :: i , j , m , ok real ( kind = dp ), parameter :: metric_eval_tol = 1.0e-10_dp real ( kind = dp ), allocatable :: smat (:,:), seval (:), xorth (:,:) real ( kind = dp ), allocatable :: opsym (:,:), tmp (:,:), reduced (:,:) real ( kind = dp ), allocatable :: vec (:,:), eval_red (:) ierr = 0 eigenvalues = 0.0_dp eigenvectors = 0.0_dp if ( n <= 0 ) return ! Eigendecomposition of the (symmetrized) metric:  S = U diag(seval) U&#94;T allocate ( smat ( n , n ), seval ( n ), source = 0.0_dp , stat = ok ) if ( ok /= 0 ) call show_message ( 'Cannot allocate memory' , WITH_ABORT ) do j = 1 , n do i = 1 , n smat ( i , j ) = 0.5_dp * ( metric ( i , j ) + metric ( j , i )) end do end do call diag_symm_full ( 1 , n , smat , n , seval , ierr ) if ( ierr /= 0 ) return ! Keep only directions with positive occupation (rank of the metric). m = 0 do i = 1 , n if ( seval ( i ) > metric_eval_tol ) m = m + 1 end do if ( m == 0 ) then ierr = - 1 return end if ! Symmetric orthogonalizer  X = U_kept * diag(seval_kept)&#94;(-1/2)   (n x m) allocate ( xorth ( n , m ), source = 0.0_dp , stat = ok ) if ( ok /= 0 ) call show_message ( 'Cannot allocate memory' , WITH_ABORT ) j = 0 do i = 1 , n if ( seval ( i ) > metric_eval_tol ) then j = j + 1 xorth (:, j ) = smat (:, i ) / sqrt ( seval ( i )) end if end do ! Reduced operator in the orthonormal metric basis:  reduced = X&#94;T op X allocate ( opsym ( n , n ), tmp ( n , m ), reduced ( m , m ), source = 0.0_dp , stat = ok ) if ( ok /= 0 ) call show_message ( 'Cannot allocate memory' , WITH_ABORT ) do j = 1 , n do i = 1 , n opsym ( i , j ) = 0.5_dp * ( operator ( i , j ) + operator ( j , i )) end do end do tmp = matmul ( opsym , xorth ) reduced = matmul ( transpose ( xorth ), tmp ) reduced = 0.5_dp * ( reduced + transpose ( reduced )) ! Standard symmetric eigenproblem on the reduced operator. allocate ( vec ( m , m ), eval_red ( m ), source = 0.0_dp , stat = ok ) if ( ok /= 0 ) call show_message ( 'Cannot allocate memory' , WITH_ABORT ) vec = reduced call diag_symm_full ( 1 , m , vec , m , eval_red , ierr ) if ( ierr /= 0 ) return ! Map results back:  eigenvalues are lambda, eigenvectors C = X * vec. eigenvalues ( 1 : m ) = eval_red ( 1 : m ) eigenvectors (:, 1 : m ) = matmul ( xorth , vec ) end subroutine solve_symmetric_generalized end module tdhf_mrsf_ekt_mod","tags":"","url":"sourcefile/tdhf_mrsf_ekt.f90.html"},{"title":"int2.F90 – OpenQP Fortran API","text":"Source Code #define UNUSED_DUMMY(x) if (.false.) then ; if (size(shape(x))<0) continue ; end if module int2_compute use precision , only : dp use int2e_libint , only : libint_t , libint2_active use int2e_rys , only : int2_rys_data_t use basis_tools , only : basis_set use atomic_structure_m , only : atomic_structure use int2_pairs , only : & int2_cutoffs_t , & int2_pair_storage use messages , only : show_message , WITH_ABORT use parallel , only : par_env_t implicit none !############################################################################### character ( len =* ), parameter :: module_name = \"int2_compute\" !############################################################################### integer , parameter :: ERR_CAM_PARAM = 1 !############################################################################### private public int2_compute_t public int2_storage_t public int2_compute_data_t public int2_fock_data_t public int2_rhf_data_t public int2_urohf_data_t public ints_exchange public petite_quartet_weight public load_petite_shell_map !############################################################################### type eri_data_t logical :: attenuated_ints = . false . logical :: rys_only = . false . integer :: ids ( 4 ) integer :: flips ( 4 ) integer :: am ( 4 ) integer :: nbf ( 4 ) real ( kind = dp ) :: mu2 = 1.0d99 ! Petite-list orbit weight (q4); 1 unless symmetry reduction is active. real ( kind = dp ) :: weight = 1.0d0 ! Weighted screening thresholds: needed by the non-abelian full-group ! tier (orbit members have unequal magnitudes); the abelian tier keeps ! the C1-identical unweighted cutoff for exact cancellation. logical :: weighted_cutoff = . false . real ( kind = dp ), pointer :: pints (:,:,:,:) type ( libint_t ), allocatable :: erieval (:) type ( int2_rys_data_t ), allocatable :: gdat real ( kind = dp ), allocatable :: ints (:) end type eri_data_t !############################################################################### type :: int2_storage_t integer :: ncur = 0 integer :: buf_size = 0 integer :: thread_id = 1 integer ( 2 ), allocatable :: ids (:,:) real ( kind = dp ), allocatable , dimension (:) :: ints contains procedure , pass :: init => int2_storage_init procedure , pass :: clean => int2_storage_clean end type !############################################################################### type , abstract :: int2_compute_data_t logical :: multipass = . false . integer :: num_passes = 1 integer :: cur_pass = 1 real ( kind = dp ) :: scale_coulomb = 1.0d0 real ( kind = dp ) :: scale_exchange = 1.0d0 type ( par_env_t ) :: pe contains !    procedure, pass :: storeints => int2_compute_data_t_storeints procedure ( int2_compute_data_parallel_start ), deferred , pass :: parallel_start procedure ( int2_compute_data_parallel_stop ), deferred , pass :: parallel_stop procedure ( int2_compute_data_update ), deferred , pass :: update procedure ( int2_compute_data_clean ), deferred , pass :: clean procedure , pass :: screen_ij => int2_compute_data_t_screen_ij procedure , pass :: screen_ijkl => int2_compute_data_t_screen_ijkl generic :: screen => screen_ij , screen_ijkl end type !############################################################################### type , abstract , extends ( int2_compute_data_t ) :: int2_fock_data_t integer :: nshells = 0 integer :: fockdim = 0 integer :: nthreads = 1 integer :: nfocks = 1 real ( kind = dp ), allocatable :: f (:,:,:) real ( kind = dp ), allocatable :: dsh (:,:) real ( kind = dp ) :: max_den = 1.0d0 real ( kind = dp ), pointer :: d (:,:) => null () !> Memory mode for the per-thread Fock accumulator.  Default (.false.) keeps !> one full Fock copy PER THREAD (fast, no contention) and reduces at the end !> -- O(fockdim*nthreads) memory.  When .true. a SINGLE shared Fock is used !> with atomic updates -- O(fockdim) memory, ~Nthreads x smaller, for very !> large systems.  Auto-enabled when the replicated buffers would exceed !> OQP_FOCK_MEM_MB (default 4096); forced by OQP_FOCK_ATOMIC=1/0. logical :: atomic_fock = . false . contains procedure :: parallel_start => int2_fock_data_t_parallel_start procedure :: parallel_stop => int2_fock_data_t_parallel_stop procedure :: clean => int2_fock_data_t_clean procedure :: init_screen => int2_fock_data_t_init_screen procedure :: screen_ij => int2_fock_data_t_screen_ij procedure :: screen_ijkl => int2_fock_data_t_screen_ijkl procedure :: int2_fock_data_t_parallel_start procedure :: int2_fock_data_t_parallel_stop end type type , extends ( int2_fock_data_t ) :: int2_rhf_data_t contains procedure :: parallel_start => int2_rhf_data_t_parallel_start procedure :: update => int2_rhf_data_t_update end type type , extends ( int2_fock_data_t ) :: int2_urohf_data_t contains procedure :: parallel_start => int2_urohf_data_t_parallel_start procedure :: update => int2_urohf_data_t_update end type !############################################################################### type :: int2_compute_t type ( basis_set ), pointer :: basis type ( atomic_structure ), pointer :: atoms real ( kind = dp ), allocatable :: schwarz_ints_regular (:,:) real ( kind = dp ), allocatable :: schwarz_ints_attenuated (:,:) real ( kind = dp ), contiguous , pointer :: schwarz_ints (:,:) => null () logical :: schwarz = . true . integer :: buf_size = 50000 integer :: skipped = 0 type ( int2_cutoffs_t ) :: cutoffs type ( int2_pair_storage ) :: ppairs logical :: attenuated = . false . !> Force the native Rys path for all L>2 quartets, bypassing libint even !> when it is compiled in.  Consumers whose validated reference data was !> produced with the Rys kernels (e.g. the NMR magnetic response) set this. logical :: rys_only = . false . real ( kind = dp ) :: mu = 1.0d99 ! Symmetry petite list (loaded from tagarray when pyoqp enables ! use_integral_symmetry). The shell map is 1-based, stored flat with ! shell index fastest: map(shell, op) = sym_shell_map((op-1)*nshell+shell). logical :: petite = . false . logical :: sym_full = . false . integer :: sym_nops = 0 integer ( 8 ), contiguous , pointer :: sym_shell_map (:) => null () type ( par_env_t ) :: pe contains private !    procedure, pass :: storeints => int2_compute_data_t_storeints procedure , public , pass :: init => int2_compute_t_init procedure , public , pass :: enable_petite => int2_compute_t_enable_petite procedure , public , pass :: set_screening => int2_compute_t_set_screening procedure , public , pass :: set_cutoff => int2_compute_t_set_cutoff procedure , public , pass :: clean => int2_compute_t_clean procedure , public , pass :: run => int2_run procedure , public , pass :: run_generic => int2_twoei procedure , public , pass :: run_cam => int2_run_cam end type !############################################################################### abstract interface subroutine int2_process ( this ) import :: int2_compute_t implicit none class ( int2_compute_t ), intent ( inout ) :: this end subroutine subroutine int2_compute_data_parallel_start ( this , basis , nthreads ) import :: int2_compute_data_t , basis_set implicit none class ( int2_compute_data_t ), target , intent ( inout ) :: this type ( basis_set ), intent ( in ) :: basis integer , intent ( in ) :: nthreads end subroutine subroutine int2_compute_data_parallel_stop ( this ) import :: int2_compute_data_t implicit none class ( int2_compute_data_t ), intent ( inout ) :: this end subroutine subroutine int2_compute_data_clean ( this ) import :: int2_compute_data_t implicit none class ( int2_compute_data_t ), intent ( inout ) :: this end subroutine subroutine int2_compute_data_update ( this , buf ) import :: int2_compute_data_t , int2_storage_t , dp implicit none class ( int2_compute_data_t ), intent ( inout ) :: this type ( int2_storage_t ), intent ( inout ) :: buf end subroutine end interface !############################################################################### contains !############################################################################### subroutine int2_compute_t_clean ( this ) implicit none class ( int2_compute_t ), intent ( inout ) :: this call this % ppairs % clean () this % basis => null () this % atoms => null () if ( allocated ( this % schwarz_ints_regular )) deallocate ( this % schwarz_ints_regular ) if ( allocated ( this % schwarz_ints_attenuated )) deallocate ( this % schwarz_ints_attenuated ) this % skipped = 0 end subroutine !############################################################################### subroutine int2_compute_t_init ( this , basis , infos ) use types , only : information use oqp_tagarray_driver use int2e_libint , only : & libint_static_init implicit none character ( len =* ), parameter :: subroutine_name = \"int2_compute_t_init\" class ( int2_compute_t ), intent ( inout ) :: this type ( information ), target , intent ( inout ) :: infos type ( basis_set ), target :: basis real ( kind = dp ) :: cutoff real ( kind = dp ), parameter :: ec1 = 1.0d-02 , ec2 = 1.0d-04 real ( kind = dp ), parameter :: cx1 = 2 5.0d+00 integer ( 4 ) :: status this % basis => basis this % atoms => infos % atoms allocate ( this % schwarz_ints_regular ( basis % nshell , basis % nshell ), source = 0 d0 ) this % skipped = 0 call basis % init_shell_centers () cutoff = infos % control % int2e_cutoff call this % cutoffs % set ( cutoff , ec1 * cutoff , ec2 * cutoff , cx1 * log ( 1 0.0d0 )) call this % pe % init ( infos % mpiinfo % comm , infos % mpiinfo % usempi ) if ( libint2_active ) call libint_static_init call this % ppairs % alloc ( basis , this % cutoffs ) call this % ppairs % compute ( basis , this % cutoffs ) ! Note: the petite-list reduction is NOT loaded here. It is only valid ! for totally symmetric densities (SCF Fock), so the SCF caller opts in ! explicitly via enable_petite(); response/CPHF builders must not. this % petite = . false . this % sym_nops = 0 this % sym_shell_map => null () end subroutine int2_compute_t_init !############################################################################### !> @brief Opt into the symmetry petite-list reduction (skeleton Fock). !> @detail Loads the shell map written by pyoqp when use_integral_symmetry !>   is enabled. Only valid when the contracted density is totally !>   symmetric and the caller symmetrizes the resulting skeleton matrix. subroutine int2_compute_t_enable_petite ( this , infos ) use types , only : information use oqp_tagarray_driver use tagarray , only : TA_OK implicit none class ( int2_compute_t ), intent ( inout ) :: this type ( information ), target , intent ( inout ) :: infos integer ( 8 ), contiguous , pointer :: petite_flag (:) integer ( 4 ) :: status call tagarray_get_data ( infos % dat , OQP_sym_petite , petite_flag , status = status ) if ( status /= TA_OK ) return if ( petite_flag ( 1 ) == 0 ) return call tagarray_get_data ( infos % dat , OQP_sym_shell_map , this % sym_shell_map , status = status ) if ( status /= TA_OK ) then this % sym_shell_map => null () return end if if ( mod ( size ( this % sym_shell_map ), this % basis % nshell ) /= 0 ) then ! Stale map from a different basis: ignore (fail-safe to C1). this % sym_shell_map => null () return end if this % sym_nops = int ( size ( this % sym_shell_map ) / this % basis % nshell ) this % petite = this % sym_nops > 1 block real ( kind = dp ), contiguous , pointer :: blocks (:) call tagarray_get_data ( infos % dat , OQP_sym_op_blocks , blocks , status = status ) this % sym_full = status == TA_OK end block end subroutine int2_compute_t_enable_petite !############################################################################### !> @brief Load the petite-list shell map written by pyoqp, if enabled. !> @detail nops = 0 when the reduction is disabled or the map is stale. subroutine load_petite_shell_map ( infos , nshell , map , nops ) use types , only : information use oqp_tagarray_driver use tagarray , only : TA_OK implicit none type ( information ), target , intent ( inout ) :: infos integer , intent ( in ) :: nshell integer ( 8 ), contiguous , pointer , intent ( out ) :: map (:) integer , intent ( out ) :: nops integer ( 8 ), contiguous , pointer :: petite_flag (:) integer ( 4 ) :: status map => null () nops = 0 call tagarray_get_data ( infos % dat , OQP_sym_petite , petite_flag , status = status ) if ( status /= TA_OK ) return if ( petite_flag ( 1 ) == 0 ) return call tagarray_get_data ( infos % dat , OQP_sym_shell_map , map , status = status ) if ( status /= TA_OK ) then map => null () return end if if ( mod ( size ( map ), nshell ) /= 0 ) then map => null () return end if nops = int ( size ( map ) / nshell ) if ( nops < 2 ) then map => null () nops = 0 end if end subroutine load_petite_shell_map !############################################################################### !> @brief Petite-list weight of a canonical shell quartet. !> @detail Returns 0 if (i,j,k,l) is not the lexicographically largest !>   member of its orbit under the abelian group (the caller skips it), !>   otherwise the orbit size |G|/|stabilizer|. The quartet must be in !>   canonical order (i>=j, (i,j)>=(k,l), k>=l), which the int2_twoei !>   loop guarantees. integer function petite_quartet_weight ( map , nops , nshell , i , j , k , l ) result ( q4 ) implicit none integer ( 8 ), intent ( in ) :: map (:) integer , intent ( in ) :: nops , nshell , i , j , k , l integer :: iop , nstab , t , base integer :: pi , pj , pk , pl , a1 , a2 , b1 , b2 nstab = 0 do iop = 1 , nops base = ( iop - 1 ) * nshell pi = int ( map ( base + i )) pj = int ( map ( base + j )) pk = int ( map ( base + k )) pl = int ( map ( base + l )) a1 = max ( pi , pj ); a2 = min ( pi , pj ) b1 = max ( pk , pl ); b2 = min ( pk , pl ) if ( a1 < b1 . or . ( a1 == b1 . and . a2 < b2 )) then t = a1 ; a1 = b1 ; b1 = t t = a2 ; a2 = b2 ; b2 = t end if if ( a1 /= i ) then if ( a1 > i ) then q4 = 0 return end if else if ( a2 /= j ) then if ( a2 > j ) then q4 = 0 return end if else if ( b1 /= k ) then if ( b1 > k ) then q4 = 0 return end if else if ( b2 /= l ) then if ( b2 > l ) then q4 = 0 return end if else nstab = nstab + 1 end if end do q4 = nops / nstab end function petite_quartet_weight !############################################################################### subroutine int2_compute_t_set_screening ( this ) implicit none class ( int2_compute_t ), intent ( inout ) :: this call ints_exchange ( this % basis , this % schwarz_ints_regular , rys_only = this % rys_only ) end subroutine int2_compute_t_set_screening !############################################################################### !> @brief Update only the run-time integral-screening threshold (no rebuild). !> @detail The Schwarz bounds (set_screening) and the shell-pair list (init) are !>   cutoff-independent / superset-safe, so changing the quartet/pair screening !>   threshold is just a scalar update of `this%cutoffs` using the same scaling !>   as init. This enables progressive (iteration-dependent) screening: a driver !>   initialised at the TIGHT cutoff can be loosened during the early, inexact !>   phase of an iterative solve and pinned back to tight before convergence so !>   the final result is unchanged. The exponent cutoff is kept fixed (as init). subroutine int2_compute_t_set_cutoff ( this , cutoff ) implicit none class ( int2_compute_t ), intent ( inout ) :: this real ( kind = dp ), intent ( in ) :: cutoff real ( kind = dp ), parameter :: ec1 = 1.0d-02 , ec2 = 1.0d-04 real ( kind = dp ), parameter :: cx1 = 2 5.0d+00 call this % cutoffs % set ( cutoff , ec1 * cutoff , ec2 * cutoff , cx1 * log ( 1 0.0d0 )) end subroutine int2_compute_t_set_cutoff !############################################################################### subroutine int2_run ( this , int2_consumer , stat , cam , alpha , beta , mu , & alpha_coulomb , beta_coulomb ) implicit none class ( int2_compute_t ), intent ( inout ) :: this class ( int2_compute_data_t ), intent ( inout ) :: int2_consumer logical , optional , intent ( in ) :: cam integer , optional , intent ( out ) :: stat real ( kind = dp ), optional , intent ( in ) :: alpha , beta , mu , & alpha_coulomb , beta_coulomb logical :: do_cam = . false . if ( present ( cam )) do_cam = cam if ( present ( stat )) stat = 0 if ( do_cam ) then if ( present ( alpha ). and . present ( beta ). and . present ( mu )) then if ( present ( alpha_coulomb ). and . present ( beta_coulomb )) then call this % run_cam ( int2_consumer , alpha , beta , mu , & alpha_coulomb , beta_coulomb ) else call this % run_cam ( int2_consumer , alpha , beta , mu ) end if else if ( present ( stat )) then stat = ERR_CAM_PARAM else call show_message ( \"No CAM parameters given\" , WITH_ABORT ) end if else call this % run_generic ( int2_consumer ) end if end subroutine int2_run !############################################################################### subroutine int2_run_cam ( this , int2_consumer , alpha , beta , mu , & alpha_coulomb , beta_coulomb ) implicit none class ( int2_compute_t ), intent ( inout ) :: this class ( int2_compute_data_t ), intent ( inout ) :: int2_consumer real ( kind = dp ), intent ( in ) :: alpha , beta , mu real ( kind = dp ), intent ( in ), optional :: alpha_coulomb , beta_coulomb logical :: attenuated_save real ( kind = dp ) :: mu_save attenuated_save = this % attenuated mu_save = this % mu int2_consumer % multipass = . true . int2_consumer % num_passes = 2 int2_consumer % cur_pass = 1 ! Regular Coulomb and exchange this % attenuated = . false . int2_consumer % scale_coulomb = 1.0d0 if ( present ( alpha_coulomb )) & int2_consumer % scale_coulomb = alpha_coulomb int2_consumer % scale_exchange = alpha call this % run_generic ( int2_consumer ) int2_consumer % cur_pass = 2 ! Short-range exchange: this % attenuated = . true . this % mu = mu int2_consumer % scale_coulomb = 0.0d0 if ( present ( beta_coulomb )) & int2_consumer % scale_coulomb = beta_coulomb int2_consumer % scale_exchange = beta call this % run_generic ( int2_consumer ) int2_consumer % multipass = . false . int2_consumer % num_passes = 1 int2_consumer % cur_pass = 1 this % attenuated = attenuated_save this % mu = mu_save end subroutine int2_run_cam !############################################################################### !############################################################################### subroutine int2_twoei ( this , int2_consumer ) use int2e_libint , ONLY : libint2_init_eri , libint2_cleanup_eri use , intrinsic :: iso_c_binding , only : C_NULL_PTR , C_INT , c_int64_t use types , only : information use constants , only : NUM_CART_BF use blas_thread , only : blas_thread_count , blas_thread_set !$  use omp_lib implicit none class ( int2_compute_t ), target , intent ( inout ) :: this class ( int2_compute_data_t ), intent ( inout ) :: int2_consumer integer :: i , j , k , l , ij_pair , npairs integer , allocatable :: pair_i (:), pair_j (:) integer :: lmax integer :: nint integer :: q4 real ( kind = dp ) :: test integer :: nshell integer :: nthreads , ithread , thr_nshq , jork , nschwz real ( kind = dp ) :: tim0 , tim1 , tim2 , tim3 , tim4 character ( len =* ), parameter :: & dbgfmt1 = '(/2x,& &\"Thread | Number of |\",19X,\"Timing\",& &/1x,\" number | quartets  |  Integrals |   F update  \",& &\"|   Schwartz  |    Total    |\")' , & dbgfmt2 = '(i5,4x,\"|\",i10,\" |\",4(f9.2,\" s | \"))' logical , parameter :: oflag = . false . !    logical, parameter :: oflag = .true. logical :: omp logical :: zero_shq type ( int2_storage_t ) :: int2_storage type ( eri_data_t ), allocatable :: eri_data integer :: ok integer ( c_int64_t ) :: nBlasThreads nshell = this % basis % nshell npairs = nshell * ( nshell + 1 ) / 2 allocate ( pair_i ( npairs ), pair_j ( npairs )) call int2_build_shell_pair_map ( nshell , pair_i , pair_j ) ! Hardwire BLAS to a single thread for the duration of the OpenMP 2e build. ! The Fock build is OpenMP-parallel and calls no BLAS itself, but a threaded ! BLAS keeps an idle worker pool that spins and oversubscribes the cores ! against the integral threads (measured ~1.5x slowdown at 28 threads). This ! uses the BLAS library's own runtime setter (openblas_set_num_threads / ! MKL_Set_Num_Threads / BLIS) so it CANNOT be overridden by a stray ! OPENBLAS_NUM_THREADS/MKL_NUM_THREADS in the environment.  The previous ! thread count is restored on exit, so diagonalisation and other BLAS-heavy ! phases outside this routine keep their full threading.  No-op (-1) for ! reference BLAS / Apple Accelerate where no setter is exported. nBlasThreads = - 1 nBlasThreads = blas_thread_count () if ( nBlasThreads > 0 ) call blas_thread_set ( 1_c_int64_t ) ! preparations for screening if ( this % schwarz ) then if ( this % attenuated ) then if (. not . allocated ( this % schwarz_ints_attenuated )) then allocate ( this % schwarz_ints_attenuated , mold = this % schwarz_ints_regular ) call ints_exchange ( this % basis , this % schwarz_ints_attenuated , this % mu ** 2 , & rys_only = this % rys_only ) end if this % schwarz_ints => this % schwarz_ints_attenuated else this % schwarz_ints => this % schwarz_ints_regular end if end if omp = . false . !$  omp = .true. nschwz = 0 lmax = maxval ( this % basis % am ) if ( lmax < 0 . or . lmax > 6 ) & call show_message ( \"Basis set agular momentum exceeds max. supported\" , WITH_ABORT ) if ( oflag ) write ( * , dbgfmt1 ) !$omp parallel & !$omp   private( & !$omp   i, j, k, l, ij_pair, jork, q4, & !$omp   tim0, tim1, tim2, tim3, tim4, ithread,   & !$omp   test, & !$omp   int2_storage, & !$omp   eri_data, & !$omp   nthreads, & !$omp   zero_shq) & !$omp   shared(int2_consumer) & !$omp   reduction(+:nschwz, nint, thr_nshq) nint = 0 ithread = 0 nthreads = 1 !$  nthreads = omp_get_num_threads() !$  ithread  = omp_get_thread_num() !$  if (oflag) then !$    thr_nshq = 0 !$    tim1     = 0.0d0 !$    tim2     = 0.0d0 !$    tim3     = 0.0d0 !$    tim4     = 0.0d0 !$    tim0     = omp_get_wtime() !$  end if !$omp master call int2_consumer % parallel_start ( this % basis , nthreads ) !$omp end master !$omp barrier allocate ( eri_data ) allocate ( eri_data % ints ( NUM_CART_BF ( lmax ) ** 4 ), source = 0.0d0 ) allocate ( eri_data % gdat ) eri_data % attenuated_ints = this % attenuated eri_data % rys_only = this % rys_only eri_data % mu2 = this % mu ** 2 if ( libint2_active ) then allocate ( eri_data % erieval ( this % basis % mxcontr ** 4 )) call libint2_init_eri ( eri_data % erieval , int ( 4 , C_INT ), C_NULL_PTR ) end if call eri_data % gdat % init ( lmax , this % cutoffs , ok ) call int2_storage % init ( this % buf_size ) int2_storage % thread_id = ithread + 1 !$omp barrier ! Distribute shell pairs through one flat dynamic workshare per int2_twoei ! parallel region.  The previous structure opened a fresh dynamic workshare ! for every (i,j) shell pair and needed a barrier after every shell pair to ! keep OpenMP runtimes from overlapping workshares with different k-loop ! bounds.  A flat shell-pair workshare keeps scheduling granular without any ! synchronization point inside the shell-pair loop. !$omp do schedule(dynamic,1) do ij_pair = 1 , npairs i = pair_i ( ij_pair ) j = pair_j ( ij_pair ) if ( this % pe % size > 1 ) then if ( mod ( ij_pair , this % pe % size ) /= this % pe % rank ) cycle end if if ( this % schwarz ) then test = int2_consumer % screen_ij ( this % schwarz_ints , i , j ) ! With the petite list active the surviving representative carries ! up to |G| weight, so the pair-level skip must be conservative by ! the same factor (orbit members of non-abelian operations live in ! different shell pairs with different bounds). if ( this % petite . and . this % sym_full ) test = test * real ( this % sym_nops , dp ) if ( test < this % cutoffs % integral_cutoff ) then nschwz = nschwz + i * ( i - 1 ) / 2 + j cycle end if end if do k = 1 , i jork = k if ( i == k ) jork = j do l = 1 , jork !$          if (oflag) tim1 = omp_get_wtime() ! Petite list: keep only the orbit representative, weighted by ! the orbit size; the skeleton Fock is symmetrized afterwards. if ( this % petite ) then q4 = petite_quartet_weight ( this % sym_shell_map , this % sym_nops , & nshell , i , j , k , l ) if ( q4 == 0 ) cycle eri_data % weight = real ( q4 , dp ) eri_data % weighted_cutoff = this % sym_full else eri_data % weight = 1.0d0 eri_data % weighted_cutoff = . false . end if if ( this % schwarz ) then test = int2_consumer % screen_ijkl ( this % schwarz_ints , i , j , k , l ) ! Screen the weighted contribution: non-abelian orbit members ! have unequal element magnitudes, so the unweighted threshold ! would leak a systematic cutoff-level error into the skeleton. if ( eri_data % weighted_cutoff ) test = test * eri_data % weight if ( test < this % cutoffs % integral_cutoff ) then nschwz = nschwz + 1 cycle end if end if thr_nshq = thr_nshq + 1 !$          if (oflag) tim2 = tim2 + omp_get_wtime() - tim1 eri_data % ids (:) = [ i , j , k , l ] call shellquartet ( this % basis , this % ppairs , this % cutoffs , eri_data , zero_shq ) !$          if (oflag) tim3 = tim3 + omp_get_wtime() - tim1 if ( zero_shq ) cycle call int2_compute_data_t_storeints ( int2_consumer , & this % basis , eri_data , int2_storage , this % cutoffs % integral_cutoff , nint ) !$          if (oflag) tim4 = tim4 + omp_get_wtime() - tim1 end do end do end do !$omp end do call int2_consumer % update ( int2_storage ) !$  if (oflag) tim0 = omp_get_wtime() - tim0 !  Debug timing output if ( omp . and . oflag ) then !$omp do ordered do i = 0 , nthreads - 1 !$omp ordered write ( * , dbgfmt2 ) ithread , thr_nshq , tim3 - tim2 , tim4 - tim3 , tim2 , tim0 !$omp end ordered end do !$omp end do end if if ( libint2_active ) then call libint2_cleanup_eri ( eri_data % erieval ) deallocate ( eri_data % erieval ) end if call eri_data % gdat % clean () call int2_storage % clean () deallocate ( eri_data ) !$omp end parallel ! restore BLAS threading for diagonalisation / other BLAS-heavy phases if ( nBlasThreads > 0 ) call blas_thread_set ( nBlasThreads ) deallocate ( pair_i , pair_j ) call int2_consumer % pe % init ( this % pe % comm , this % pe % use_mpi ) call int2_consumer % parallel_stop () this % skipped = nschwz contains subroutine int2_build_shell_pair_map ( nshell , shell_pair_i , shell_pair_j ) !> Build the flat shell-pair work list, ordered by DESCENDING estimated cost !> so the dynamic OpenMP schedule hands out the expensive quartets first and !> the cheap ones fill the tail -- minimising the end-of-region load-imbalance !> barrier wait (\"adaptive dynamic dispatch\").  Cost ~ nbf_i*nbf_j*i captures !> both the per-quartet kernel size (angular momentum) and the k,l iteration !> count (~i), and -- when available -- the Schwarz magnitude of the bra pair !> (its SPARSITY: diffuse/negligible pairs are mostly screened and do little !> work, so they sink to the tail).  A counting sort over log2(cost) classes !> keeps this O(n); reordering only changes work distribution, never results. implicit none integer , intent ( in ) :: nshell integer , intent ( out ) :: shell_pair_i (:), shell_pair_j (:) integer :: i , j , ij_pair , c , nbfi , nbfj , ami , amj integer , parameter :: NCLASS = 64 , OFFS = 42 integer :: cnt ( 0 : NCLASS ), off ( 0 : NCLASS ), cls real ( kind = dp ) :: cost , sw logical :: use_sw use_sw = this % schwarz . and . allocated ( this % schwarz_ints_regular ) ! Pass 1: count pairs per cost-class (class 0 = most expensive). cnt = 0 do i = nshell , 1 , - 1 ami = this % basis % am ( i ); nbfi = ( ami + 1 ) * ( ami + 2 ) / 2 do j = 1 , i amj = this % basis % am ( j ); nbfj = ( amj + 1 ) * ( amj + 2 ) / 2 sw = 1.0d0 if ( use_sw ) sw = max ( this % schwarz_ints_regular ( i , j ), 1.0d-30 ) cost = sw * real ( nbfi * nbfj , dp ) * real ( i , dp ) cls = NCLASS - max ( 0 , min ( NCLASS , int ( log ( cost ) / log ( 2.0d0 )) + OFFS )) cnt ( cls ) = cnt ( cls ) + 1 end do end do ! Prefix offsets (ascending class index = descending cost). off ( 0 ) = 0 do c = 1 , NCLASS off ( c ) = off ( c - 1 ) + cnt ( c - 1 ) end do ! Pass 2: scatter pairs into cost-sorted positions (stable within a class, ! preserving the i-descending build order as the secondary key). do i = nshell , 1 , - 1 ami = this % basis % am ( i ); nbfi = ( ami + 1 ) * ( ami + 2 ) / 2 do j = 1 , i amj = this % basis % am ( j ); nbfj = ( amj + 1 ) * ( amj + 2 ) / 2 sw = 1.0d0 if ( use_sw ) sw = max ( this % schwarz_ints_regular ( i , j ), 1.0d-30 ) cost = sw * real ( nbfi * nbfj , dp ) * real ( i , dp ) cls = NCLASS - max ( 0 , min ( NCLASS , int ( log ( cost ) / log ( 2.0d0 )) + OFFS )) off ( cls ) = off ( cls ) + 1 ij_pair = off ( cls ) shell_pair_i ( ij_pair ) = i shell_pair_j ( ij_pair ) = j end do end do end subroutine int2_build_shell_pair_map end subroutine int2_twoei !############################################################################### !############################################################################### function int2_compute_data_t_screen_ij ( this , xints , i , j ) result ( res ) implicit none class ( int2_compute_data_t ), intent ( in ) :: this real ( kind = dp ), contiguous , intent ( in ) :: xints (:,:) real ( kind = dp ) :: res integer , intent ( in ) :: i , j res = 1 return UNUSED_DUMMY ( this ) UNUSED_DUMMY ( xints ) UNUSED_DUMMY ( i ) UNUSED_DUMMY ( j ) end function int2_compute_data_t_screen_ij !############################################################################### function int2_compute_data_t_screen_ijkl ( this , xints , i , j , k , l ) result ( res ) implicit none class ( int2_compute_data_t ), intent ( in ) :: this real ( kind = dp ), contiguous , intent ( in ) :: xints (:,:) real ( kind = dp ) :: res integer , intent ( in ) :: i , j , k , l res = 1 return UNUSED_DUMMY ( this ) UNUSED_DUMMY ( xints ) UNUSED_DUMMY ( i ) UNUSED_DUMMY ( j ) UNUSED_DUMMY ( k ) UNUSED_DUMMY ( l ) end function int2_compute_data_t_screen_ijkl !############################################################################### !############################################################################### function int2_fock_data_t_screen_ij ( this , xints , i , j ) result ( res ) implicit none class ( int2_fock_data_t ), intent ( in ) :: this real ( kind = dp ), contiguous , intent ( in ) :: xints (:,:) real ( kind = dp ) :: res integer , intent ( in ) :: i , j integer :: ij res = xints ( i , j ) * this % max_den end function int2_fock_data_t_screen_ij !############################################################################### function int2_fock_data_t_screen_ijkl ( this , xints , i , j , k , l ) result ( res ) implicit none class ( int2_fock_data_t ), intent ( in ) :: this real ( kind = dp ), contiguous , intent ( in ) :: xints (:,:) real ( kind = dp ) :: res integer , intent ( in ) :: i , j , k , l integer :: ij , kl res = xints ( i , j ) * xints ( k , l ) if ( allocated ( this % dsh )) then res = res * max ( 4 * this % dsh ( i , j ), 4 * this % dsh ( k , l ), this % dsh ( j , l ), this % dsh ( j , k ), this % dsh ( i , l ), this % dsh ( i , k )) end if end function int2_fock_data_t_screen_ijkl !############################################################################### !> @brief Computes the shell density matrix from the given density matrix and basis set. !> !> @details This subroutine calculates the shell density matrix `shell_density` !>          by determining the maximum density values for each shell pair from !>          the provided density matrix `density_matrix` and the basis set information. !> !> @param[out] shell_density  The computed shell density matrix. !> @param[in]  density_matrix The input density matrix in AO basis. !> @param[in]  basis          The basis set information including shell data. !> subroutine shlden ( shell_density , density_matrix , basis ) use basis_tools , only : basis_set implicit none type ( basis_set ), intent ( in ) :: basis !< Basis set information real ( kind = dp ), intent ( out ) :: shell_density (:,:) !< Density matrix compressed to shells real ( kind = dp ), intent ( in ) :: density_matrix (:,:) !< Density matrix in AO basis integer :: shell_i , shell_j , i , j , ij integer :: mini , maxi , minj , maxj , fock_index real ( kind = dp ) :: dmax ! Initialize shell density to zero shell_density = 0 ! Loop over each Fock matrix do fock_index = 1 , ubound ( density_matrix , 2 ) ! Loop over shells do shell_i = 1 , basis % nshell mini = basis % ao_offset ( shell_i ) maxi = mini + basis % naos ( shell_i ) - 1 ! Loop over shells again for symmetry do shell_j = 1 , shell_i minj = basis % ao_offset ( shell_j ) maxj = minj + basis % naos ( shell_j ) - 1 dmax = 0.0d0 ! Loop over basis functions within shells do i = mini , maxi if ( shell_i == shell_j ) maxj = i do j = minj , maxj ij = i * ( i - 1 ) / 2 + j dmax = max ( abs ( density_matrix ( ij , fock_index )), dmax ) end do end do shell_density ( shell_i , shell_j ) = max ( dmax , shell_density ( shell_i , shell_j )) end do end do end do ! Symmetrize do shell_i = 1 , basis % nshell do shell_j = shell_i + 1 , basis % nshell shell_density ( shell_i , shell_j ) = shell_density ( shell_j , shell_i ) end do end do end subroutine shlden !############################################################################### subroutine shellquartet ( basis , ppairs , cutoffs , eri_data , zero_shq ) use io_constants , only : iw use int2e_rotaxis , only : genr22 , genr22_pure , genr22_reduce_pure use int2e_libint , only : libint_compute_eri , libint_print_eri use int2e_rys , only : int2_rys_compute , int2_rys_reduce_pure , rys_print_eri use iso_c_binding , only : c_f_pointer use constants , only : HARMONIC_ACTIVE use int2_pure_generated , only : int2_project_pure_block implicit none type ( basis_set ), intent ( in ) :: basis type ( int2_pair_storage ), intent ( in ) :: ppairs type ( int2_cutoffs_t ), intent ( in ) :: cutoffs type ( eri_data_t ), intent ( inout ), target :: eri_data logical , intent ( out ) :: zero_shq logical :: rotspd , libint , rys integer :: nbf ( 4 ) integer :: s_ , fp_ , orig_ , am_s ( 4 ), pure_s ( 4 ), nbf_s ( 4 ), nbf_out_s ( 4 ) logical , parameter :: dbg_output = . false . !    logical, parameter :: dbg_output = .true. integer :: max_am logical :: err zero_shq = . false . eri_data % am = basis % am ( eri_data % ids ) max_am = maxval ( eri_data % am ) eri_data % nbf = ( eri_data % am + 1 ) * ( eri_data % am + 2 ) / 2 rotspd = max_am <= 2 libint = . not . rotspd . and . libint2_active . and .. not . eri_data % attenuated_ints & . and .. not . eri_data % rys_only rys = . not . rotspd . and .. not . libint if ( rotspd ) then if ( HARMONIC_ACTIVE . and . & any ( basis % harmonic ( eri_data % ids ) == 1 . and . eri_data % am >= 2 )) then ! direct pure-spherical output: lab rotation and c2s fused per index if ( eri_data % attenuated_ints ) then call genr22_pure ( basis , ppairs , eri_data % ints , eri_data % ids , eri_data % flips , & cutoffs , eri_data % nbf , eri_data % mu2 ) else call genr22_pure ( basis , ppairs , eri_data % ints , eri_data % ids , eri_data % flips , & cutoffs , eri_data % nbf ) end if else if ( eri_data % attenuated_ints ) then ! erf-attenuated integrals call genr22 ( basis , ppairs , eri_data % ints , eri_data % ids , eri_data % flips , cutoffs , eri_data % mu2 ) else ! regular integrals call genr22 ( basis , ppairs , eri_data % ints , eri_data % ids , eri_data % flips , cutoffs ) end if eri_data % nbf = eri_data % nbf ( eri_data % flips ) call genr22_reduce_pure ( basis , eri_data % ids , eri_data % flips , eri_data % ints , eri_data % nbf ) end if eri_data % pints ( 1 : eri_data % nbf ( 4 ), 1 : eri_data % nbf ( 3 ), 1 : eri_data % nbf ( 2 ), 1 : eri_data % nbf ( 1 )) => eri_data % ints else if ( libint ) then call libint_compute_eri ( basis , ppairs , cutoffs , eri_data % ids , 0 , eri_data % erieval , eri_data % flips , zero_shq ) if ( zero_shq ) return nbf = eri_data % nbf ( eri_data % flips ) eri_data % nbf = nbf call c_f_pointer ( eri_data % erieval ( 1 )% targets ( 1 ), eri_data % pints , shape = nbf ([ 4 , 3 , 2 , 1 ])) call normalize_ints ( nbf , eri_data % am ( eri_data % flips ), eri_data % pints ) else if ( rys ) then call eri_data % gdat % set_ids ( basis , eri_data % ids ) if ( eri_data % attenuated_ints ) then ! erf-attenuated integrals call int2_rys_compute ( eri_data % ints , eri_data % gdat , ppairs , zero_shq , & mu2 = eri_data % mu2 , basis = basis , direct_pure = . true .) else ! regular integrals call int2_rys_compute ( eri_data % ints , eri_data % gdat , ppairs , zero_shq , & basis = basis , direct_pure = . true .) end if if ( zero_shq ) return nbf = eri_data % gdat % nbf eri_data % flips = eri_data % gdat % flips if ( eri_data % gdat % direct_pure ) then eri_data % nbf = nbf eri_data % pints ( 1 : nbf ( 4 ), 1 : nbf ( 3 ), 1 : nbf ( 2 ), 1 : nbf ( 1 )) => eri_data % ints else eri_data % pints ( 1 : nbf ( 4 ), 1 : nbf ( 3 ), 1 : nbf ( 2 ), 1 : nbf ( 1 )) => eri_data % ints call normalize_ints ( nbf , eri_data % gdat % am , eri_data % pints ) call int2_rys_reduce_pure ( basis , eri_data % gdat , eri_data % ints , nbf ) eri_data % nbf = nbf eri_data % pints ( 1 : nbf ( 4 ), 1 : nbf ( 3 ), 1 : nbf ( 2 ), 1 : nbf ( 1 )) => eri_data % ints end if end if ! Libint returns a normalized Cartesian target buffer. Stage it into the ! owned ERI buffer before reducing harmonic-flagged shells to pure output. if ( HARMONIC_ACTIVE . and . libint ) then do s_ = 1 , 4 fp_ = 5 - s_ ! pints storage dim s_ <-> flipped position fp_ orig_ = eri_data % flips ( fp_ ) ! original shell index at that position am_s ( s_ ) = eri_data % am ( orig_ ) pure_s ( s_ ) = basis % harmonic ( eri_data % ids ( orig_ )) nbf_s ( s_ ) = eri_data % nbf ( fp_ ) end do if ( any ( pure_s == 1 . and . am_s >= 2 )) then eri_data % ints ( 1 : product ( nbf_s )) = reshape ( eri_data % pints , [ product ( nbf_s )]) call int2_project_pure_block ( eri_data % ints , am_s , pure_s , nbf_s , nbf_out_s ) do s_ = 1 , 4 eri_data % nbf ( 5 - s_ ) = nbf_out_s ( s_ ) end do eri_data % pints ( 1 : eri_data % nbf ( 4 ), 1 : eri_data % nbf ( 3 ), & 1 : eri_data % nbf ( 2 ), 1 : eri_data % nbf ( 1 )) => eri_data % ints end if end if if ( dbg_output ) then block integer :: len1 , len2 , len3 , len4 write ( iw , '(\"shells\", 4i5, \" :\", 4i5, \" :\", 4i5, \" :\", 4i5)' ) & eri_data % ids , & eri_data % am , & eri_data % am ( eri_data % flips ), & eri_data % flips end block if ( libint ) call libint_print_eri ( basis , eri_data % ids , 0 , eri_data % erieval , eri_data % flips ) if ( rys ) call rys_print_eri ( eri_data % gdat , eri_data % pints ) end if end subroutine shellquartet !############################################################################### subroutine normalize_ints ( nbf , am , ints ) use constants , only : shells_pnrm2 implicit none integer , intent ( in ) :: nbf ( 4 ), am ( 4 ) real ( kind = dp ), contiguous , intent ( inout ) :: ints (:,:,:,:) integer :: na , nb , nc , nd real ( kind = dp ), pointer :: pnorma (:), pnormb (:), pnormc (:), pnormd (:) pnorma => shells_pnrm2 (:, am ( 1 )) pnormb => shells_pnrm2 (:, am ( 2 )) pnormc => shells_pnrm2 (:, am ( 3 )) pnormd => shells_pnrm2 (:, am ( 4 )) do concurrent ( na = 1 : nbf ( 1 ), nb = 1 : nbf ( 2 ), nc = 1 : nbf ( 3 ), nd = 1 : nbf ( 4 )) ints ( nd , nc , nb , na ) = ints ( nd , nc , nb , na ) & * pnorma ( na ) * pnormb ( nb ) & * pnormc ( nc ) * pnormd ( nd ) end do end subroutine !############################################################################### subroutine int2_storage_init ( this , buf_size ) implicit none class ( int2_storage_t ), intent ( inout ) :: this integer , intent ( in ) :: buf_size if ( allocated ( this % ids )) call this % clean () this % buf_size = buf_size this % ncur = 0 allocate ( this % ids ( 4 , this % buf_size ) ) allocate ( this % ints ( this % buf_size ) ) end subroutine !############################################################################### subroutine int2_storage_clean ( this ) implicit none class ( int2_storage_t ), intent ( inout ) :: this deallocate ( this % ids ) deallocate ( this % ints ) this % buf_size = 0 this % ncur = 0 end subroutine !############################################################################### !############################################################################### subroutine int2_fock_data_t_parallel_start ( this , basis , nthreads ) implicit none class ( int2_fock_data_t ), target , intent ( inout ) :: this type ( basis_set ), intent ( in ) :: basis integer , intent ( in ) :: nthreads integer :: nsh , ncopy , si , sj , npair_sh , nsig character ( len = 32 ) :: sval integer :: ln real ( kind = dp ) :: repl_mb , cap_mb , frac_sig , spthr , sptol this % nthreads = nthreads nsh = basis % nshell if ( allocated ( this % dsh )) then if ( size ( this % dsh ) /= nsh * nsh ) deallocate ( this % dsh ) end if if (. not . allocated ( this % dsh )) then allocate ( this % dsh ( nsh , nsh ), source = 0.0d0 ) else this % dsh = 0 end if !   Form the shell density first -- it drives both screening and the Fock-memory !   mode decision below. call this % init_screen ( basis ) !   Decide Fock accumulator memory mode.  Replicated (one copy/thread) is fastest !   but costs fockdim*nfocks*nthreads*8 bytes; for very large systems that blows !   up.  A single shared atomic Fock uses ~Nthreads x less memory, but per-integral !   atomics contend -- cheaply only when few quartets survive, i.e. when the DENSITY !   IS SPARSE.  So switch to the low-memory atomic buffer only when (a) the !   replicated buffers would exceed OQP_FOCK_MEM_MB (default 4096) AND (b) the !   shell density is sparse (significant-pair fraction < OQP_FOCK_SPARSITY, !   default 0.5).  Dense density keeps the fast replicated path.  OQP_FOCK_ATOMIC !   forces the choice. cap_mb = 409 6.0d0 call get_environment_variable ( \"OQP_FOCK_MEM_MB\" , sval , ln ) if ( ln > 0 ) read ( sval , * , iostat = ln ) cap_mb spthr = 0.5d0 call get_environment_variable ( \"OQP_FOCK_SPARSITY\" , sval , ln ) if ( ln > 0 ) read ( sval , * , iostat = ln ) spthr repl_mb = real ( this % fockdim , dp ) * this % nfocks * nthreads * 8.0d0 / 1.048576d6 ! density sparsity = fraction of shell pairs carrying significant density sptol = 1.0d-4 npair_sh = nsh * ( nsh + 1 ) / 2 nsig = 0 do si = 1 , nsh do sj = 1 , si if ( this % dsh ( si , sj ) > sptol * this % max_den ) nsig = nsig + 1 end do end do frac_sig = real ( nsig , dp ) / real ( max ( 1 , npair_sh ), dp ) this % atomic_fock = ( nthreads > 1 ) . and . ( repl_mb > cap_mb ) . and . ( frac_sig < spthr ) call get_environment_variable ( \"OQP_FOCK_ATOMIC\" , sval , ln ) if ( ln > 0 ) then this % atomic_fock = ( sval ( 1 : 1 ) == '1' . or . sval ( 1 : 1 ) == 'y' . or . sval ( 1 : 1 ) == 'Y' & . or . sval ( 1 : 1 ) == 't' . or . sval ( 1 : 1 ) == 'T' ) end if ncopy = nthreads if ( this % atomic_fock ) ncopy = 1 if ( this % cur_pass == 1 . and . this % atomic_fock ) then write ( * , '(2x,a,f9.1,a,f9.1,a,i0,a,f5.2,a)' ) & \"Fock accumulator: shared+atomic (low-memory) using \" , & real ( this % fockdim , dp ) * this % nfocks * 8.0d0 / 1.048576d6 , \" MB vs \" , & repl_mb , \" MB replicated (\" , nthreads , \" threads), density frac_sig=\" , & frac_sig , \"\" end if if ( this % cur_pass == 1 ) then if ( allocated ( this % f )) then if ( any (( shape ( this % f ) - [ this % fockdim , this % nfocks , ncopy ]) /= 0 ) ) then deallocate ( this % f ) end if end if if (. not . allocated ( this % f )) then allocate ( this % f ( this % fockdim , this % nfocks , ncopy ), source = 0.0d0 ) else this % f = 0 end if end if end subroutine !############################################################################### subroutine int2_fock_data_t_init_screen ( this , basis ) implicit none class ( int2_fock_data_t ), target , intent ( inout ) :: this type ( basis_set ), intent ( in ) :: basis !   Form shell density call shlden ( this % dsh , this % d , basis ) this % max_den = maxval ( abs ( this % dsh )) end subroutine !############################################################################### subroutine int2_rhf_data_t_parallel_start ( this , basis , nthreads ) implicit none class ( int2_rhf_data_t ), target , intent ( inout ) :: this type ( basis_set ), intent ( in ) :: basis integer , intent ( in ) :: nthreads this % fockdim = basis % nbf * ( basis % nbf + 1 ) / 2 this % nfocks = ubound ( this % d , size ( shape ( this % d ))) call this % int2_fock_data_t_parallel_start ( basis , nthreads ) end subroutine !############################################################################### subroutine int2_urohf_data_t_parallel_start ( this , basis , nthreads ) implicit none class ( int2_urohf_data_t ), target , intent ( inout ) :: this type ( basis_set ), intent ( in ) :: basis integer , intent ( in ) :: nthreads this % fockdim = basis % nbf * ( basis % nbf + 1 ) / 2 this % nfocks = 2 call this % int2_fock_data_t_parallel_start ( basis , nthreads ) end subroutine !############################################################################### subroutine int2_fock_data_t_parallel_stop ( this ) implicit none class ( int2_fock_data_t ), intent ( inout ) :: this call this % pe % barrier () if ( this % cur_pass /= this % num_passes ) return ! atomic_fock already accumulated into the single shared copy (dim3==1); ! only the replicated mode needs the cross-thread reduction. if ( this % nthreads /= 1 . and . . not . this % atomic_fock ) then this % f (:,:, lbound ( this % f , 3 )) = sum ( this % f , dim = size ( shape ( this % f ))) end if call this % pe % allreduce ( this % f (:,:, 1 ), & size ( this % f (:,:, 1 ))) call this % pe % barrier () this % nthreads = 1 end subroutine !############################################################################### subroutine int2_fock_data_t_clean ( this ) implicit none class ( int2_fock_data_t ), intent ( inout ) :: this deallocate ( this % f ) deallocate ( this % dsh ) nullify ( this % d ) end subroutine !############################################################################### subroutine int2_rhf_data_t_update ( this , buf ) implicit none class ( int2_rhf_data_t ), intent ( inout ) :: this type ( int2_storage_t ), intent ( inout ) :: buf integer :: ii , jj , kk , ll , ij , ik , il , jk , jl , kl , n , ii2 , jj2 , kk2 real ( kind = dp ) :: xval1 , xval4 , val , val1 , val4 real ( kind = dp ) :: aij , akl , aik , ajl , ail , ajk integer :: ifock , mythread xval1 = this % scale_exchange xval4 = 4 * this % scale_coulomb mythread = buf % thread_id if ( this % atomic_fock ) mythread = 1 do ifock = 1 , this % nfocks do n = 1 , buf % ncur ii = buf % ids ( 1 , n ) jj = buf % ids ( 2 , n ) kk = buf % ids ( 3 , n ) ll = buf % ids ( 4 , n ) val = buf % ints ( n ) ii2 = ii * ( ii - 1 ) / 2 jj2 = jj * ( jj - 1 ) / 2 kk2 = kk * ( kk - 1 ) / 2 ij = ii2 + jj ik = ii2 + kk il = ii2 + ll jk = jj2 + kk jl = jj2 + ll kl = kk2 + ll if ( jj < kk ) jk = kk2 + jj if ( jj < ll ) jl = ll * ( ll - 1 ) / 2 + jj val1 = val * xval1 val4 = val * xval4 if ( this % atomic_fock ) then ! single shared Fock: atomic accumulation (low-memory mode). ! Contributions are precomputed into locals so the atomic statement's ! RHS references no component of `this` (gfortran atomic requirement). aij = val4 * this % d ( kl , ifock ); akl = val4 * this % d ( ij , ifock ) aik = - val1 * this % d ( jl , ifock ); ajl = - val1 * this % d ( ik , ifock ) ail = - val1 * this % d ( jk , ifock ); ajk = - val1 * this % d ( il , ifock ) !$omp atomic update this % f ( ij , ifock , 1 ) = this % f ( ij , ifock , 1 ) + aij !$omp atomic update this % f ( kl , ifock , 1 ) = this % f ( kl , ifock , 1 ) + akl !$omp atomic update this % f ( ik , ifock , 1 ) = this % f ( ik , ifock , 1 ) + aik !$omp atomic update this % f ( jl , ifock , 1 ) = this % f ( jl , ifock , 1 ) + ajl !$omp atomic update this % f ( il , ifock , 1 ) = this % f ( il , ifock , 1 ) + ail !$omp atomic update this % f ( jk , ifock , 1 ) = this % f ( jk , ifock , 1 ) + ajk else this % f ( ij , ifock , mythread ) = this % f ( ij , ifock , mythread ) + val4 * this % d ( kl , ifock ) this % f ( kl , ifock , mythread ) = this % f ( kl , ifock , mythread ) + val4 * this % d ( ij , ifock ) this % f ( ik , ifock , mythread ) = this % f ( ik , ifock , mythread ) - val1 * this % d ( jl , ifock ) this % f ( jl , ifock , mythread ) = this % f ( jl , ifock , mythread ) - val1 * this % d ( ik , ifock ) this % f ( il , ifock , mythread ) = this % f ( il , ifock , mythread ) - val1 * this % d ( jk , ifock ) this % f ( jk , ifock , mythread ) = this % f ( jk , ifock , mythread ) - val1 * this % d ( il , ifock ) end if end do end do buf % ncur = 0 end subroutine int2_rhf_data_t_update !############################################################################### subroutine int2_urohf_data_t_update ( this , buf ) implicit none class ( int2_urohf_data_t ), intent ( inout ) :: this type ( int2_storage_t ), intent ( inout ) :: buf integer :: ii , jj , kk , ll , ij , ik , il , jk , jl , kl , n , ii2 , jj2 , kk2 real ( kind = dp ) :: xval2 , xval4 , val , val1 , val4 , cij , ckl real ( kind = dp ) :: a1ik , a1jl , a1il , a1jk , a2ik , a2jl , a2il , a2jk integer :: mythread xval2 = 2 * this % scale_exchange xval4 = 4 * this % scale_coulomb mythread = buf % thread_id if ( this % atomic_fock ) mythread = 1 do n = 1 , buf % ncur ii = buf % ids ( 1 , n ) jj = buf % ids ( 2 , n ) kk = buf % ids ( 3 , n ) ll = buf % ids ( 4 , n ) val = buf % ints ( n ) ii2 = ii * ( ii - 1 ) / 2 jj2 = jj * ( jj - 1 ) / 2 kk2 = kk * ( kk - 1 ) / 2 ij = ii2 + jj ik = ii2 + kk il = ii2 + ll jk = jj2 + kk jl = jj2 + ll kl = kk2 + ll if ( jj < kk ) jk = kk2 + jj if ( jj < ll ) jl = ll * ( ll - 1 ) / 2 + jj val1 = val * xval2 val4 = val * xval4 cij = val4 * sum ( this % d ( ij , 1 : 2 )) ckl = val4 * sum ( this % d ( kl , 1 : 2 )) if ( this % atomic_fock ) then ! locals so atomic RHS references no component of `this` a1ik = - val1 * this % d ( jl , 1 ); a1jl = - val1 * this % d ( ik , 1 ) a1il = - val1 * this % d ( jk , 1 ); a1jk = - val1 * this % d ( il , 1 ) a2ik = - val1 * this % d ( jl , 2 ); a2jl = - val1 * this % d ( ik , 2 ) a2il = - val1 * this % d ( jk , 2 ); a2jk = - val1 * this % d ( il , 2 ) !$omp atomic update this % f ( ij , 1 , 1 ) = this % f ( ij , 1 , 1 ) + ckl !$omp atomic update this % f ( kl , 1 , 1 ) = this % f ( kl , 1 , 1 ) + cij !$omp atomic update this % f ( ik , 1 , 1 ) = this % f ( ik , 1 , 1 ) + a1ik !$omp atomic update this % f ( jl , 1 , 1 ) = this % f ( jl , 1 , 1 ) + a1jl !$omp atomic update this % f ( il , 1 , 1 ) = this % f ( il , 1 , 1 ) + a1il !$omp atomic update this % f ( jk , 1 , 1 ) = this % f ( jk , 1 , 1 ) + a1jk !$omp atomic update this % f ( ij , 2 , 1 ) = this % f ( ij , 2 , 1 ) + ckl !$omp atomic update this % f ( kl , 2 , 1 ) = this % f ( kl , 2 , 1 ) + cij !$omp atomic update this % f ( ik , 2 , 1 ) = this % f ( ik , 2 , 1 ) + a2ik !$omp atomic update this % f ( jl , 2 , 1 ) = this % f ( jl , 2 , 1 ) + a2jl !$omp atomic update this % f ( il , 2 , 1 ) = this % f ( il , 2 , 1 ) + a2il !$omp atomic update this % f ( jk , 2 , 1 ) = this % f ( jk , 2 , 1 ) + a2jk else this % f ( ij , 1 , mythread ) = this % f ( ij , 1 , mythread ) + ckl this % f ( kl , 1 , mythread ) = this % f ( kl , 1 , mythread ) + cij this % f ( ik , 1 , mythread ) = this % f ( ik , 1 , mythread ) - val1 * this % d ( jl , 1 ) this % f ( jl , 1 , mythread ) = this % f ( jl , 1 , mythread ) - val1 * this % d ( ik , 1 ) this % f ( il , 1 , mythread ) = this % f ( il , 1 , mythread ) - val1 * this % d ( jk , 1 ) this % f ( jk , 1 , mythread ) = this % f ( jk , 1 , mythread ) - val1 * this % d ( il , 1 ) this % f ( ij , 2 , mythread ) = this % f ( ij , 2 , mythread ) + ckl this % f ( kl , 2 , mythread ) = this % f ( kl , 2 , mythread ) + cij this % f ( ik , 2 , mythread ) = this % f ( ik , 2 , mythread ) - val1 * this % d ( jl , 2 ) this % f ( jl , 2 , mythread ) = this % f ( jl , 2 , mythread ) - val1 * this % d ( ik , 2 ) this % f ( il , 2 , mythread ) = this % f ( il , 2 , mythread ) - val1 * this % d ( jk , 2 ) this % f ( jk , 2 , mythread ) = this % f ( jk , 2 , mythread ) - val1 * this % d ( il , 2 ) end if end do buf % ncur = 0 end subroutine int2_urohf_data_t_update !############################################################################### subroutine ints_exchange ( basis , schwarz_ints , mu2 , rys_only ) use int2e_rotaxis , only : genr22 , genr22_pure , genr22_reduce_pure use int2e_libint , only : libint2_init_eri , libint2_cleanup_eri use int2e_libint , only : libint_compute_eri , libint_print_eri use int2e_libint , only : libint_t , libint2_active use int2e_rys , only : int2_rys_compute , int2_rys_reduce_pure use types , only : information use constants , only : HARMONIC_ACTIVE , NUM_CART_BF use int2_pure_generated , only : int2_project_pure_block use , intrinsic :: iso_c_binding , only : C_NULL_PTR , C_INT , c_f_pointer implicit none type ( basis_set ), intent ( in ) :: basis real ( kind = dp ), intent ( inout ) :: schwarz_ints (:,:) real ( kind = dp ), optional , intent ( in ) :: mu2 logical , optional , intent ( in ) :: rys_only real ( kind = dp ), parameter :: & ic_exchng = 1.0d-15 , & ei1_exchng = 1.0d-17 , & ei2_exchng = 1.0d-17 , & cux_exchng = 5 0.0 integer :: flips ( 4 ) integer :: shell_ids ( 4 ) integer :: nbf ( 4 ) integer :: lmax integer :: ish , jsh integer :: i , j , jmax integer :: am ( 4 ), max_am integer :: s_ , fp_ , orig_ , am_s ( 4 ), pure_s ( 4 ), nbf_s ( 4 ), nbf_out_s ( 4 ) integer :: ok logical :: rotspd , libint , zero_shq , rys logical :: attenuated , rys_only_ real ( kind = dp ) :: vmax real ( kind = dp ), allocatable , target :: ints (:) real ( kind = dp ), pointer :: pints (:,:,:,:) type ( libint_t ), allocatable :: erieval (:) type ( int2_rys_data_t ) :: gdat type ( int2_cutoffs_t ) :: cutoffs type ( int2_pair_storage ) :: ppairs attenuated = present ( mu2 ) rys_only_ = . false . if ( present ( rys_only )) rys_only_ = rys_only lmax = maxval ( basis % am ) if ( lmax < 0 . or . lmax > 6 ) call show_message ( \"Basis set agular momentum exceeds max. supported\" , WITH_ABORT ) !   Set very tight cutoff call cutoffs % set ( ic_exchng , ei1_exchng , ei2_exchng , cux_exchng ) if ( libint2_active ) then allocate ( erieval ( basis % mxcontr ** 4 )) call libint2_init_eri ( erieval , int ( 4 , C_INT ), C_NULL_PTR ) end if allocate ( ints ( NUM_CART_BF ( lmax ) ** 4 ), source = 0.0d0 ) call gdat % init ( lmax , cutoffs , ok ) call ppairs % alloc ( basis , cutoffs ) call ppairs % compute ( basis , cutoffs ) do ish = 1 , basis % nshell do jsh = 1 , ish shell_ids = [ ish , jsh , ish , jsh ] am = basis % am ( shell_ids ) max_am = maxval ( am ) rotspd = max_am <= 2 libint = . not . rotspd . and . libint2_active . and .. not . attenuated . and .. not . rys_only_ rys = . not . rotspd . and .. not . libint if ( rotspd ) then if ( HARMONIC_ACTIVE . and . any ( basis % harmonic ( shell_ids ) == 1 . and . am >= 2 )) then ! direct pure-spherical output: lab rotation and c2s fused per index if ( attenuated ) then call genr22_pure ( basis , ppairs , ints , shell_ids , flips , cutoffs , nbf , mu2 ) else call genr22_pure ( basis , ppairs , ints , shell_ids , flips , cutoffs , nbf ) end if else if ( attenuated ) then call genr22 ( basis , ppairs , ints , shell_ids , flips , cutoffs , mu2 ) else call genr22 ( basis , ppairs , ints , shell_ids , flips , cutoffs ) end if nbf = NUM_CART_BF ( am ( flips )) call genr22_reduce_pure ( basis , shell_ids , flips , ints , nbf ) end if vmax = maxval ( abs ( ints ( 1 : product ( nbf )))) else if ( libint ) then call libint_compute_eri ( basis , ppairs , cutoffs , shell_ids , 0 , erieval , flips , zero_shq ) ! flips is intent(out) of libint_compute_eri; only valid afterwards nbf = NUM_CART_BF ( am ( flips )) if ( zero_shq ) then vmax = 0.0_dp else call c_f_pointer ( erieval ( 1 )% targets ( 1 ), pints , shape = nbf ([ 4 , 3 , 2 , 1 ])) call normalize_ints ( nbf , am ( flips ), pints ) if ( HARMONIC_ACTIVE ) then do s_ = 1 , 4 fp_ = 5 - s_ orig_ = flips ( fp_ ) am_s ( s_ ) = am ( orig_ ) pure_s ( s_ ) = basis % harmonic ( shell_ids ( orig_ )) nbf_s ( s_ ) = nbf ( fp_ ) end do if ( any ( pure_s == 1 . and . am_s >= 2 )) then ints ( 1 : product ( nbf_s )) = reshape ( pints , [ product ( nbf_s )]) call int2_project_pure_block ( ints , am_s , pure_s , nbf_s , nbf_out_s ) do s_ = 1 , 4 nbf ( 5 - s_ ) = nbf_out_s ( s_ ) end do vmax = maxval ( abs ( ints ( 1 : product ( nbf )))) else vmax = maxval ( abs ( pints )) end if else vmax = maxval ( abs ( pints )) end if end if else if ( rys ) then call gdat % set_ids ( basis , shell_ids ) if ( attenuated ) then call int2_rys_compute ( ints , gdat , ppairs , zero_shq , & mu2 = mu2 , basis = basis , direct_pure = . true .) else call int2_rys_compute ( ints , gdat , ppairs , zero_shq , & basis = basis , direct_pure = . true .) end if if ( zero_shq ) then vmax = 0.0_dp else nbf = gdat % nbf if ( gdat % direct_pure ) then pints ( 1 : nbf ( 4 ), 1 : nbf ( 3 ), 1 : nbf ( 2 ), 1 : nbf ( 1 )) => ints else pints ( 1 : nbf ( 4 ), 1 : nbf ( 3 ), 1 : nbf ( 2 ), 1 : nbf ( 1 )) => ints call normalize_ints ( nbf , gdat % am , pints ) call int2_rys_reduce_pure ( basis , gdat , ints , nbf ) end if vmax = maxval ( abs ( ints ( 1 : product ( nbf )))) end if end if schwarz_ints ( ish , jsh ) = sqrt ( vmax ) schwarz_ints ( jsh , ish ) = sqrt ( vmax ) end do end do if ( libint2_active ) then call libint2_cleanup_eri ( erieval ) deallocate ( erieval ) end if call gdat % clean () end subroutine ints_exchange !############################################################################### subroutine int2_compute_data_t_storeints ( consumer , basis , eri_data , & buf , cutoff , nint ) use precision , only : dp use basis_tools , only : basis_set implicit none class ( int2_compute_data_t ), intent ( inout ) :: consumer type ( int2_storage_t ), intent ( inout ) :: buf type ( eri_data_t ), target , intent ( inout ) :: eri_data type ( basis_set ), intent ( in ) :: basis real ( kind = dp ), intent ( in ) :: cutoff integer , intent ( inout ) :: nint logical :: iandj , kandl , same integer :: itmp , nij , nkl , maxj , maxl , & i , i1 , ii , loci , & j , j1 , jj , locj , & k , k1 , kk , lock , & l , l1 , ll , locl integer :: ids ( 4 ), flips ( 4 ), nbf ( 4 ) real ( kind = dp ) :: val ids = eri_data % ids ( eri_data % flips ) nbf = eri_data % nbf same = ids ( 1 ) == ids ( 3 ) . and . ids ( 2 ) == ids ( 4 ) iandj = ids ( 1 ) == ids ( 2 ) kandl = ids ( 3 ) == ids ( 4 ) loci = basis % ao_offset ( ids ( 1 )) - 1 locj = basis % ao_offset ( ids ( 2 )) - 1 lock = basis % ao_offset ( ids ( 3 )) - 1 locl = basis % ao_offset ( ids ( 4 )) - 1 nij = 0 maxj = nbf ( 2 ) do i = 1 , nbf ( 1 ) if ( iandj ) maxj = i jc : do j = 1 , maxj nij = nij + 1 nkl = nij maxl = nbf ( 4 ) do k = 1 , nbf ( 3 ) if ( kandl ) maxl = k if ( same ) then ! account for non-unique permutations itmp = min ( maxl , nkl ) if ( itmp == 0 ) cycle jc maxl = itmp nkl = nkl - itmp end if do l = 1 , maxl ! Element cutoff on the weighted magnitude: the stored value ! carries the orbit weight, so the effective threshold matches ! the C1 path even when non-abelian orbit members have unequal ! element magnitudes. val = eri_data % pints ( l , k , j , i ) if ( eri_data % weighted_cutoff ) then if ( abs ( val ) * eri_data % weight < cutoff ) cycle else ! Abelian tier: C1-identical element set (exact cancellation). if ( abs ( val ) < cutoff ) cycle end if val = val * eri_data % weight nint = nint + 1 i1 = i + loci j1 = j + locj k1 = k + lock l1 = l + locl if ( i1 < j1 ) then ! sort <ij| j1 = i + loci i1 = j + locj end if if ( k1 < l1 ) then ! sort |kl> l1 = k + lock k1 = l + locl end if ii = i1 jj = j1 kk = k1 ll = l1 if ( ii < kk ) then ! sort <ij|kl> ii = k1 jj = l1 kk = i1 ll = j1 else if ( ii == kk . and . jj < ll ) then ! sort <ij|il> ii = i1 jj = l1 kk = k1 ll = j1 end if !           Account for identical permutations. if ( ii == jj ) val = val * 0.5d0 if ( kk == ll ) val = val * 0.5d0 if ( ii == kk . and . jj == ll ) val = val * 0.5d0 buf % ncur = buf % ncur + 1 buf % ids ( 1 , buf % ncur ) = int ( ii , 2 ) buf % ids ( 2 , buf % ncur ) = int ( jj , 2 ) buf % ids ( 3 , buf % ncur ) = int ( kk , 2 ) buf % ids ( 4 , buf % ncur ) = int ( ll , 2 ) buf % ints ( buf % ncur ) = val if ( buf % ncur == buf % buf_size ) call consumer % update ( buf ) end do end do end do jc end do end subroutine int2_compute_data_t_storeints !############################################################################### end module int2_compute","tags":"","url":"sourcefile/int2.f90.html"},{"title":"types.F90 – OpenQP Fortran API","text":"Source Code !  17 Aug 12 - CHC - Initial file module types !  Definition of types use precision , only : dp use , intrinsic :: iso_c_binding , only : c_ptr , c_int64_t , c_double , c_char , c_bool , c_int use tagarray , only : container_t use functionals , only : functional_t use atomic_structure_m , only : atomic_structure use parallel , only : MPI_COMM_NULL use basis_tools , only : basis_set implicit none private !     The information of a system type , public , bind ( C ) :: molecule integer ( c_int64_t ) :: natom = 0 !< The number of atom integer ( c_int64_t ) :: charge = 0 !< Molecular charge integer ( c_int64_t ) :: nelec = 0 !< The number of electron integer ( c_int64_t ) :: nelec_A = 0 !< The number of alpha electron integer ( c_int64_t ) :: nelec_B = 0 !< The number of beta electron integer ( c_int64_t ) :: mult = 0 !< Spin multiplicity integer ( c_int64_t ) :: nvelec = 0 !< The number of valence electron integer ( c_int64_t ) :: nocc = 0 !< The number of occupied orbitals !< nOCC = nelec/2 for RHF !< nOCC = nelec_A for ROHF/UHF with mult=3 !< nOCC = nelec/2 for ROHF/UHF with mult=1 end type molecule type , public , bind ( C ) :: dft_parameters character ( kind = c_char ) :: XC_functional_name ( 20 ) !< Name of XC functional real ( c_double ) :: hfscale = 1.0_dp !< HF scale for global hybrids real ( c_double ) :: cam_alpha = 0.0_dp !< alpha coefficient real ( c_double ) :: cam_beta = 0.0_dp !< beta coefficient real ( c_double ) :: cam_mu = 0.0_dp !< mu coefficient real ( c_double ) :: MP2SS_Scale = 0.0_dp !< coefficient of non-local MP2 same-spin correlation real ( c_double ) :: MP2OS_Scale = 0.0_dp !< coefficient of non-local MP2 opposite-spin correlation logical ( c_bool ) :: cam_flag = . false . !< switch Coulomb-Attenuating Method (CAM-) \\frac{1}{r_{12}} = \\frac{1-[cam_{alpha}+cam_{beta}*\\erf(cam_{mu}*r_{12})]}{r_{12}} + \\frac{cam_{alpha}+cam_{beta}*\\erf(cam_{mu}*r_{12})}{r_{12}} logical ( c_bool ) :: dh_flag = . false . !< logical flag of using DH-DFT functionals logical ( c_bool ) :: grid_pruned = . false . !< true if pruned grid (e.g. sg1) is used logical ( c_bool ) :: grid_ao_pruned = . true . !< true if grid is pruned by AO distance real ( c_double ) :: grid_ao_threshold = 0.0_dp !< Prune grid AOs with threshold real ( c_double ) :: grid_ao_sparsity_ratio = 0.9_dp !< Prune grid AOs if sparsity exceeds 10% character ( c_char ) :: grid_pruned_name ( 16 ) = '' !< prune grid name integer ( c_int64_t ) :: grid_num_ang_grids = 0 !< number of angular grids, >1 means pruned grid integer ( c_int64_t ) :: grid_rad_size = 96 !< number of radial grid pts. integer ( c_int64_t ) :: grid_ang_size = 302 !< number of angular grid pts. real ( c_double ) :: grid_density_cutoff = 0.0d0 !< grid DFT density cutoff integer ( c_int64_t ) :: dft_partfun = 0 !< partition function type in grid-based DFT !< -  0 (default) - SSF original polynomial !< -  1           - Becke's 4th degree polynomial !< -  2           - Modified SSF ( erf(x/(1-x**2)) ) !< -  3           - Modified SSF (smoothstep-2, 5th order) !< -  4           - Modified SSF (smoothstep-3, 7rd order) !< -  5           - Modified SSF (smoothstep-4, 9th order) !< -  6           - Modified SSF (smoothstep-5,11th order) !< Note: Becke's polynomial with 1 iteration is actually !< a smoothstep-1 polynomial (3*x**2 - 2*x**3) integer ( c_int64_t ) :: rad_grid_type = 0 !< type of the radial grid in DFT: !< - 0 (default) - Euler-Maclaurin grid (Murray et al.) !< - 1           - Log3 grid (Mura and Knowles) !< - 2           - Treutler and Ahlrichs radial grid !< - 3           - Becke's grid integer ( c_int64_t ) :: dft_bfc_algo = 0 !< type of the Becke's fuzzy cell method !< - 0 (default) - SSF-like algorithm !< - 1           - Becke's algorithm logical ( c_bool ) :: dft_wt_der = . false . !< .TRUE. if quadrature weights derivative !<  contribution to the nuclear gradient is needed !< Weight derivatives are not always required, !< especially if the fine grid is used end type dft_parameters type , public , bind ( C ) :: energy_results real ( c_double ) :: energy = 0.0_dp !< Total energy real ( c_double ) :: enuc = 0.0_dp !< Nuclear repulsion energy real ( c_double ) :: psinrm = 0.0_dp !< wavefunction normalization real ( c_double ) :: ehf1 = 0.0_dp !< one-electron energy real ( c_double ) :: vee = 0.0_dp !< two-electron energy real ( c_double ) :: nenergy = 0.0_dp !< nuclear repulsion energy real ( c_double ) :: etot = 0.0_dp !< total energy real ( c_double ) :: vne = 0.0_dp !< nucleus-electron potential energy real ( c_double ) :: vnn = 0.0_dp !< nucleus-nucleus potential energy real ( c_double ) :: vtot = 0.0_dp !< total potential energy real ( c_double ) :: tkin = 0.0_dp !< total kinetic energy real ( c_double ) :: virial = 0.0_dp !< virial ratio (v/t) real ( c_double ) :: excited_energy = 0.0_dp !< targeted excited state energy logical ( c_bool ) :: SCF_converged = . false . !< Convergence checking Flag for SCF logical ( c_bool ) :: Davidson_converged = . false . !< Convergence checking Flag for Davidson Iteration logical ( c_bool ) :: Z_Vector_converged = . false . !< Convergence checking Flag for Z-Vector Iteration end type energy_results type , public , bind ( C ) :: control_parameters integer ( c_int64_t ) :: hamilton = 10 !< The method of calculations: 10=HF, 20=DFT integer ( c_int64_t ) :: scftype = 1 !< Refence wavefuction, 1= RHF 2= UHF 3= ROHF character ( c_char ) :: runtype ( 20 ) = '' !<  Run type: energy, grad, etc. integer ( c_int64_t ) :: guess = 1 !< used guess integer ( c_int64_t ) :: active_basis = 0 !< Choose data basis: 0 -> info%basis, 1 -> info%alt_basis integer ( c_int64_t ) :: maxit = 3 !< The maximum number of iterations integer ( c_int64_t ) :: maxit_dav = 50 !< The maximum number of iterations in Davidson eigensolver integer ( c_int64_t ) :: maxit_zv = 50 !< The maximum number of CG iterations in Z-vector subroutines integer ( c_int64_t ) :: maxdiis = 7 !< The maximum number of diis equations integer ( c_int64_t ) :: diis_reset_mod = 10 !< The maximum number of diis iteration before resetting real ( c_double ) :: diis_reset_conv = 0.005_dp !< Convergency criteria of DIIS reset integer ( c_int64_t ) :: diis_type = 5 !< 1: none, 2: cdiis, 3: ediis, 4: adiis, 5: vdiis real ( c_double ) :: cdiis_switch = 0.3_dp !< DIIS error below which the cascade switches to C-DIIS real ( c_double ) :: vdiis_vshift_switch = 0.003_dp !< DIIS error below which the level shift is turned off real ( c_double ) :: vshift = 0.0_dp !< Virtual orbital shift for ROHF logical ( c_bool ) :: mom = . false . !< Maximum Overlap Method for SCF Convergency logical ( c_bool ) :: pfon = . false . !< Pseudo-Fractional Occupation Number Method (pFON) for scf real ( c_double ) :: mom_switch = 0.003_dp !< Turn on criteria of DIIS error real ( c_double ) :: pfon_start_temp = 200 0.0_dp !< Starting tempreature for pFON real ( c_double ) :: pfon_cooling_rate = 5 0.0_dp !< Tempreature cooling rate for pFON real ( c_double ) :: pfon_nsmear = 5.0_dp !< Num. of smearing orbitals for pFON if = 0, all real ( c_double ) :: conv = 1e-6_dp !< Convergency criteria of SCF integer ( c_int64_t ) :: scf_incremental = 1 !< Enable/disable incremental Fock build real ( c_double ) :: int2e_cutoff = 5e-11_dp !< 2e-integrals cutoff ! Progressive (iteration-dependent) integral screening. Default OFF. ! When on, the 2e Schwarz/density cutoff is loosened in early SCF iterations ! (coupled to the DIIS error) and tightened back to int2e_cutoff as the SCF ! converges, so the converged energy is unchanged but early Fock builds are ! cheaper. Composes with the incremental Fock build (full rebuild on the pin). integer ( c_int64_t ) :: scf_pscreen = 0 !< 0=off (default), 1=on real ( c_double ) :: pscreen_k = 1e-2_dp !< tau_iter = pscreen_k * diis_error (safety fraction, <1) real ( c_double ) :: pscreen_cap = 1e-8_dp !< loosest allowed cutoff (upper clamp on tau_iter); 1e-8 is !< the validated safe ceiling -- looser derails DIIS on dense !< systems (the err_screen << |SCF update| invariant) real ( c_double ) :: pscreen_tight = 1e-4_dp !< pin tau_iter to int2e_cutoff once diis_error < this ! Progressive XC: during the loose phase (diis_error >= pscreen_tight) override the ! DFT grid density cutoff and AO-prune threshold with these looser values, so early ! XC builds prune more AOs / skip more low-density points; restored to baseline (pinned) ! once diis_error < pscreen_tight. 0 = that knob is not ramped. Same scf_pscreen gate. real ( c_double ) :: pscreen_xc_dcut = 0.0_dp !< loose grid density cutoff during descent (0=off) real ( c_double ) :: pscreen_xc_aocut = 0.0_dp !< loose grid AO-prune threshold during descent (0=off) ! Progressive XC coarse->fine grid ramp: use a coarse (pscreen_grid_rad x ! pscreen_grid_ang Lebedev) grid during the descent, the full grid once pinned. ! 0 = off. The coarse grid is built in hf_energy (dft_initialize needs basis ! intent(inout)) and selected per-iteration in scf_driver. Energy-neutral: the ! tail uses the full grid, and the XC build is non-incremental. integer ( c_int64_t ) :: pscreen_grid_rad = 0 !< coarse radial points during descent (0=off) integer ( c_int64_t ) :: pscreen_grid_ang = 0 !< coarse angular (Lebedev) points during descent (0=off) integer ( c_int64_t ) :: esp = 0 !< (R)ESP charges, 0 - skip, 1 - ESP, 2 - RESP integer ( c_int64_t ) :: resp_target = 0 !< RESP charges target: 0 - zero, 1 - Mulliken real ( c_double ) :: resp_constr = 0.01 !< RESP charges constraint logical ( c_bool ) :: basis_set_issue = . false . !< Basis set issue flag real ( c_double ) :: conf_print_threshold = 5.0d-02 !< The threshold for configuration printout logical ( c_bool ) :: rstctmo = . false . !< Restrict new MO similar to previous MO. This is similar to MOM method ! Scalar relativistic correction Parameters integer ( c_int64_t ) :: scal_rel = 0 !< Douglas–Kroll–Hess correction (DKH) to the hcore !< 0   - no DKH correction !< 1   - first-order  DKH !< 2   - second-order DKH integer ( c_int64_t ) :: soc_2e = 1 !< SOC 2e solution: 0=off (1e only), 1=on (1e+2e) ! SCF converger selection integer ( c_int64_t ) :: converger_type = 0 !< SCF converger: 0=DIIS, 1=SOSCF, 2=TRAH real ( c_double ) :: soscf_lvl_shift = 0.0_dp !< Level shifting parameter for SOSCF integer ( c_int64_t ) :: verbose = 1 !< Controls output verbosity: 0 for minimal, 1+ for detailed. ! Opentrustregion Parameter logical ( c_bool ) :: trh_stab = . false . !< Enable stability check before/at convergence logical ( c_bool ) :: trh_ls = . false . !< Enable logarithmic line search on accepted steps integer ( c_int64_t ) :: trh_sub_solver = 0 !< subsystem solver. 0: \"davidson\", 1 :\"jacobi-davidson\",2: \"tcg\" integer ( c_int64_t ) :: trh_nrtv = 1 !< # of random trial vectors for initial subspace real ( c_double ) :: trh_r0 = 0.4d0 !< Initial trust-region radius integer ( c_int64_t ) :: trh_jd_start = 30 !< Number of micro iterations -> switches to the Jacobi-Davidson method. integer ( c_int64_t ) :: trh_nmic = 50 !< Max micro-iterations per macro step real ( c_double ) :: trh_gred = 1.0d-3 !< Global trust-radius reduction factor (0<gred<1) real ( c_double ) :: trh_lred = 1.0d-4 !< Local trust-radius reduction factor (0<lred<1) integer ( c_int64_t ) :: trh_impl = 1 !< TRAH solver: 1=native Fortran (default), 0=OpenTrustRegion (external) ! SD parameters logical ( c_bool ) :: sd_scf = . true . !< prevent running the first SD-SCF calculation ! PCM implicit solvent (energy-only, ddX backend; off by default) logical ( c_bool ) :: pcm_enabled = . false . !< Enable PCM reaction-field contribution to SCF real ( c_double ) :: pcm_epsilon = 7 8.3553_dp !< Solvent dielectric constant (water default) ! Performance knobs -- set from input keys via the control struct (see ! pyoqp utils/perf_levels.py and the `perf` preset). Defaults reproduce the ! historic behaviour. Kept in sync with struct control_parameters in include/oqp.h. integer ( c_int64_t ) :: xc_c2f = 1 !< coarse-to-fine XC grid (1=on, default) integer ( c_int64_t ) :: xc_phi_cache = 0 !< cache collocation Phi across SCF iters integer ( c_int64_t ) :: xc_incdft = 0 !< incremental DFT (experimental) real ( c_double ) :: grad_cutoff = 1.0d-10 !< 2e-derivative Schwarz cutoff (gradient) real ( c_double ) :: mrsf_resp_cutoff = 1.0d-8 !< MRSF response 2e cutoff integer ( c_int64_t ) :: mrsf_fp32 = 0 !< FP32 MRSF response digestion integer ( c_int64_t ) :: mrsf_zv_warmstart = 1 !< MRSF z-vector warm-start (1=on, default) logical ( c_bool ) :: qmmm_flag = . false . !< QM/MM Flag end type control_parameters type , public , bind ( c ) :: tddft_parameters integer ( c_int64_t ) :: nstate = 1 !< Number of excited states integer ( c_int64_t ) :: target_state = 1 !< Target excited state for properties calculation, ground state == 0 integer ( c_int64_t ) :: maxvec = 50 !< Max number of trial vectors integer ( c_int64_t ) :: mult = 1 !< MRSF multiplicity real ( c_double ) :: cnvtol = 1.0e-10_dp !< convergence tolerance in the iterative TD-DFT step real ( c_double ) :: zvconv = 1.0e-10_dp !< convergence tolerance in Z-vector equation logical ( c_bool ) :: debug_mode = . false . !< Debug print logical ( c_bool ) :: tda = . false . !< switch for Tamm-Dancoff approximation integer ( c_int64_t ) :: tlf = 2 !< truncated Leibniz formula (TLF) approximation algorithm, !< 0   - zeroth-order (scales as O(n&#94;2)) DO NOT WORK !< 1   - first-order (scales as O(n&#94;3)) !< 2   - second-order (scales as O(n&#94;3)) real ( c_double ) :: HFScale = 1.0_dp !< HF scale for global hybrids in response calculations real ( c_double ) :: cam_alpha = 0.0_dp !< alpha coefficient real ( c_double ) :: cam_beta = 0.0_dp !< beta coefficient real ( c_double ) :: cam_mu = 0.0_dp !< mu coefficient real ( c_double ) :: spc_coco = 0.0_dp !< Spin-pair coupling parameter MRSF (C=closed, O=open, V=virtual MOs) real ( c_double ) :: spc_ovov = 0.0_dp !< Spin-pair coupling parameter MRSF (C=closed, O=open, V=virtual MOs) real ( c_double ) :: spc_coov = 0.0_dp !< Spin-pair coupling parameter MRSF (C=closed, O=open, V=virtual MOs) type ( c_ptr ) :: ixcore !< orbital index responsible for excitation (ixcore=1 means that it computes integer ( c_int64_t ) :: ixcore_len = 0 !< length of ixcore integer ( c_int64_t ) :: z_solver = 0 !< z-vector solver: 0 (CG), 1 (GMRES legacy), 2 (MINRES), 3 (AUTO) integer ( c_int64_t ) :: gmres_dim = 50 !< The Restart dimension of GMRES logical ( c_bool ) :: umrsf = . false . !< UMRSF branch calculations switch in td_mrsf_energy module end type tddft_parameters type , public , bind ( c ) :: mpi_communicator integer ( c_int ) :: comm = MPI_COMM_NULL !< MPI communicator logical ( c_bool ) :: debug_mode = . false . logical ( c_bool ) :: usempi = . false . end type mpi_communicator type , public , bind ( c ) :: electron_shell integer ( c_int ) :: id = 0 integer ( c_int ) :: element_id = - 1 !    integer(c_int) :: num_expo = 0 integer ( c_int ) :: ang_mom = 0 integer ( c_int ) :: harmonic = 0 !< 1 = pure spherical-harmonic shell, 0 = Cartesian integer ( c_int ) :: ecp_nam = 0 type ( c_ptr ) :: num_expo type ( c_ptr ) :: expo type ( c_ptr ) :: coef type ( c_ptr ) :: ecp_am type ( c_ptr ) :: ecp_rex type ( c_ptr ) :: ecp_coord type ( c_ptr ) :: ecp_zn end type electron_shell type , public :: information type ( molecule ) :: mol_prop type ( energy_results ) :: mol_energy type ( dft_parameters ) :: dft type ( control_parameters ) :: control type ( atomic_structure ) :: atoms type ( functional_t ) :: functional type ( tddft_parameters ) :: tddft type ( container_t ) :: dat type ( basis_set ) :: basis type ( basis_set ) :: alt_basis character ( len = :), allocatable :: log_filename type ( mpi_communicator ) :: mpiinfo type ( electron_shell ) :: elshell contains generic :: set_atoms => set_atoms_arr , set_atoms_atm procedure , pass :: set_atoms_arr => info_set_atoms_arr procedure , pass :: set_atoms_atm => info_set_atoms_atm end type information contains function info_set_atoms_arr ( this , natoms , x , y , z , q , mass ) result ( ok ) class ( information ) :: this integer ( c_int64_t ) :: natoms real ( c_double ) :: x ( * ), y ( * ), z ( * ), q ( * ) real ( c_double ), optional :: mass ( * ) integer ( c_int ) :: ok integer :: i ok = this % atoms % init ( natoms ) if ( ok /= 0 ) return do i = 1 , natoms this % atoms % xyz ( 1 , i ) = x ( i ) this % atoms % xyz ( 2 , i ) = y ( i ) this % atoms % xyz ( 3 , i ) = z ( i ) this % atoms % zn ( i ) = q ( i ) if ( present ( mass )) this % atoms % mass ( i ) = mass ( i ) end do this % mol_prop % natom = natoms end function function info_set_atoms_atm ( this , atoms ) result ( ok ) class ( information ) :: this type ( atomic_structure ) :: atoms integer ( c_int ) :: ok ok = 1 this % atoms = atoms end function end module types","tags":"","url":"sourcefile/types.f90.html"},{"title":"tdhf_hessian.F90 – OpenQP Fortran API","text":"Source Code module tdhf_hessian_mod implicit none character ( len =* ), parameter :: module_name = \"tdhf_hessian_mod\" contains !############################################################################### subroutine tdhf_hessian_C ( c_handle ) bind ( C , name = \"tdhf_hessian\" ) use c_interop , only : oqp_handle_t , oqp_handle_get_info use types , only : information type ( oqp_handle_t ) :: c_handle type ( information ), pointer :: inf inf => oqp_handle_get_info ( c_handle ) call tdhf_hessian ( inf ) end subroutine tdhf_hessian_C !############################################################################### subroutine tdhf_hessian ( infos ) use types , only : information use messages , only : show_message , WITH_ABORT implicit none type ( information ), target , intent ( inout ) :: infos ! Analytic TDDFT Hessian kernel scaffold reached. The C ABI is present ! for build/link integration, but the scientific kernel is deliberately ! guarded so `[hess] type=analytical` cannot return placeholder zeros or ! fall back to the numerical Hessian. call show_message (& 'Analytic TDDFT Hessian kernel scaffold reached; implementation is not available yet.' , & WITH_ABORT ) end subroutine tdhf_hessian end module tdhf_hessian_mod","tags":"","url":"sourcefile/tdhf_hessian.f90.html"},{"title":"base64.F90 – OpenQP Fortran API","text":"Source Code module base64 use , intrinsic :: iso_c_binding , only : c_char , c_int64_t , c_long_long , c_ptr , c_loc , c_null_char use , intrinsic :: iso_fortran_env , only : int32 , int64 , real32 , real64 implicit none private public b64_encode , b64_decode character ( * ), parameter :: BASE64_TABLE = \"ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/\" interface integer ( c_long_long ) function base64_encode ( src , dst , nbytes ) bind ( c ) use , intrinsic :: iso_c_binding , only : c_ptr , c_long_long type ( c_ptr ), value :: src type ( c_ptr ), value :: dst integer ( c_long_long ), value :: nbytes end function integer ( c_long_long ) function base64_decode ( src , dst ) bind ( c ) use , intrinsic :: iso_c_binding , only : c_ptr , c_long_long type ( c_ptr ), value :: src type ( c_ptr ), value :: dst end function integer ( c_size_t ) function strlen ( str ) bind ( c ) use , intrinsic :: iso_c_binding , only : c_ptr , c_size_t type ( c_ptr ), value :: str end function end interface interface b64_encode module procedure b64_encode_int32 , b64_encode_int64 , b64_encode_real32 , b64_encode_real64 , b64_encode_char end interface interface b64_decode module procedure b64_decode_int32 , b64_decode_int64 , b64_decode_real32 , b64_decode_real64 , b64_decode_char end interface contains function c_to_f_string ( str ) result ( res ) character ( c_char ), target :: str ( * ) character (:), allocatable :: res integer :: slen , i slen = 0 do if ( str ( slen + 1 ) == c_null_char ) exit slen = slen + 1 end do if ( slen == 0 ) then res = '' else allocate ( character ( len = slen ) :: res ) do i = 1 , slen res ( i : i ) = str ( i ) end do end if end function function f_to_c_string ( str ) result ( res ) character ( * ) :: str character ( c_char ), allocatable :: res (:) integer :: slen , i slen = len ( str ) + 1 allocate ( res ( slen )) do i = 1 , slen - 1 res ( i ) = str ( i : i ) end do res ( slen ) = c_null_char end function subroutine string_fix_c_length ( string ) character ( * ), target :: string integer :: slen #ifdef __GFORTRAN__ logical , parameter :: need_fix = . true . #else logical , parameter :: need_fix = . false . #endif if ( need_fix ) then slen = len ( string ) if ( slen < strlen ( c_loc ( string ))) string ( slen + 1 : slen + 1 ) = c_null_char end if end subroutine function b64_encode_int32 ( src ) result ( res ) integer ( int32 ), target :: src (:) character (:), allocatable :: res integer :: slen , rlen integer ( c_long_long ) :: retlen character ( c_char ), target , allocatable :: cres (:) slen = ubound ( src , 1 ) rlen = ( slen * storage_size ( src ) / 8 + 2 ) / 3 * 4 allocate ( cres ( rlen + 1 )) retlen = base64_encode ( c_loc ( src ), c_loc ( cres ), & int ( slen * storage_size ( src ) / 8 , c_long_long )) cres ( rlen + 1 ) = c_null_char res = c_to_f_string ( cres ) end function function b64_encode_int64 ( src ) result ( res ) integer ( int64 ), target :: src (:) character (:), target , allocatable :: res integer :: slen , rlen integer ( c_long_long ) :: retlen character ( c_char ), target , allocatable :: cres (:) slen = ubound ( src , 1 ) rlen = ( slen * storage_size ( src ) / 8 + 2 ) / 3 * 4 allocate ( cres ( rlen + 1 )) retlen = base64_encode ( c_loc ( src ), c_loc ( cres ), & int ( slen * storage_size ( src ) / 8 , c_long_long )) cres ( rlen + 1 ) = c_null_char res = c_to_f_string ( cres ) end function function b64_encode_real32 ( src ) result ( res ) real ( real32 ), target :: src (:) character (:), target , allocatable :: res integer :: slen , rlen integer ( c_long_long ) :: retlen character ( c_char ), target , allocatable :: cres (:) slen = ubound ( src , 1 ) rlen = ( slen * storage_size ( src ) / 8 + 2 ) / 3 * 4 allocate ( cres ( rlen + 1 )) retlen = base64_encode ( c_loc ( src ), c_loc ( cres ), & int ( slen * storage_size ( src ) / 8 , c_long_long )) cres ( rlen + 1 ) = c_null_char res = c_to_f_string ( cres ) end function function b64_encode_real64 ( src ) result ( res ) real ( real64 ), target :: src (:) character (:), target , allocatable :: res integer :: slen , rlen integer ( c_long_long ) :: retlen character ( c_char ), target , allocatable :: cres (:) slen = ubound ( src , 1 ) rlen = ( slen * storage_size ( src ) / 8 + 2 ) / 3 * 4 allocate ( cres ( rlen + 1 )) retlen = base64_encode ( c_loc ( src ), c_loc ( cres ), & int ( slen * storage_size ( src ) / 8 , c_long_long )) cres ( rlen + 1 ) = c_null_char res = c_to_f_string ( cres ) end function function b64_encode_char ( src ) result ( res ) character ( * ), target :: src character (:), target , allocatable :: res character ( c_char ), target , allocatable :: csrc (:), cres (:) integer :: slen , rlen integer ( c_long_long ) :: retlen csrc = f_to_c_string ( src ) slen = len ( src ) rlen = ( slen * storage_size ( 'a' ) / 8 + 2 ) / 3 * 4 allocate ( cres ( rlen + 1 )) retlen = base64_encode ( c_loc ( csrc ), c_loc ( cres ), & int ( slen , c_long_long )) cres ( rlen + 1 ) = c_null_char res = c_to_f_string ( cres ) end function subroutine b64_decode_int32 ( src , res ) character ( * ), target :: src integer ( int32 ), target , allocatable , intent ( inout ) :: res (:) integer :: slen , rlen integer ( kind = c_int64_t ) :: nbytes character ( kind = c_char ), allocatable , target :: csrc (:) slen = len ( src ) csrc = f_to_c_string ( src ) rlen = (( slen + 3 ) / 4 ) * 3 / ( storage_size ( res ) / 8 ) if ( allocated ( res )) deallocate ( res ) allocate ( res ( rlen )) nbytes = base64_decode ( c_loc ( csrc ), c_loc ( res )) deallocate ( csrc ) end subroutine subroutine b64_decode_int64 ( src , res ) character ( * ), target :: src integer ( int64 ), target , allocatable , intent ( inout ) :: res (:) integer :: slen , rlen integer ( kind = c_int64_t ) :: nbytes character ( kind = c_char ), allocatable , target :: csrc (:) slen = len ( src ) csrc = f_to_c_string ( src ) rlen = (( slen + 3 ) / 4 ) * 3 / ( storage_size ( res ) / 8 ) if ( allocated ( res )) deallocate ( res ) allocate ( res ( rlen )) nbytes = base64_decode ( c_loc ( csrc ), c_loc ( res )) deallocate ( csrc ) end subroutine subroutine b64_decode_real32 ( src , res ) character ( * ), target :: src real ( real32 ), target , allocatable , intent ( inout ) :: res (:) integer :: slen , rlen integer ( kind = c_int64_t ) :: nbytes character ( kind = c_char ), allocatable , target :: csrc (:) slen = len ( src ) csrc = f_to_c_string ( src ) rlen = (( slen + 3 ) / 4 ) * 3 / ( storage_size ( res ) / 8 ) if ( allocated ( res )) deallocate ( res ) allocate ( res ( rlen )) nbytes = base64_decode ( c_loc ( csrc ), c_loc ( res )) deallocate ( csrc ) end subroutine subroutine b64_decode_real64 ( src , res ) character ( * ), target :: src real ( real64 ), target , allocatable , intent ( inout ) :: res (:) integer :: slen , rlen integer ( kind = c_int64_t ) :: nbytes character ( kind = c_char ), allocatable , target :: csrc (:) slen = len ( src ) csrc = f_to_c_string ( src ) rlen = (( slen + 3 ) / 4 ) * 3 / ( storage_size ( res ) / 8 ) if ( allocated ( res )) deallocate ( res ) allocate ( res ( rlen )) nbytes = base64_decode ( c_loc ( csrc ), c_loc ( res )) deallocate ( csrc ) end subroutine subroutine b64_decode_char ( src , res ) character ( * ), target :: src character (:), target , allocatable , intent ( inout ) :: res integer :: slen , rlen integer ( kind = c_int64_t ) :: nbytes integer :: npad character ( kind = c_char ), allocatable , target :: csrc (:), cres (:) slen = len ( src ) csrc = f_to_c_string ( src ) npad = scan ( src , BASE64_TABLE , back = . true .) if ( npad /= 0 ) npad = slen - npad rlen = ( slen + 3 ) / 4 * 3 / ( storage_size ( 'a' ) / 8 ) - npad if ( allocated ( res )) deallocate ( res ) allocate ( cres ( rlen + 1 )) cres ( rlen + 1 ) = c_null_char nbytes = base64_decode ( c_loc ( csrc ), c_loc ( cres )) res = c_to_f_string ( cres ) deallocate ( csrc , cres ) end subroutine end module base64","tags":"","url":"sourcefile/base64.f90.html"},{"title":"xyzorder.F90 – OpenQP Fortran API","text":"Source Code module xyz_order implicit none private integer , parameter , public :: & X__ = 1 , & Y__ = 2 , & Z__ = 3 , & XX_ = 1 , & YY_ = 2 , & ZZ_ = 3 , & XY_ = 4 , & XZ_ = 5 , & YZ_ = 6 , & XXX = 1 , & YYY = 2 , & ZZZ = 3 , & XXY = 4 , & XXZ = 5 , & YYX = 6 , & YYZ = 7 , & ZZX = 8 , & ZZY = 9 , & XYZ = 10 end module xyz_order","tags":"","url":"sourcefile/xyzorder.f90.html"},{"title":"dft_gridint_gxc.F90 – OpenQP Fortran API","text":"Source Code module mod_dft_gridint_gxc use precision , only : fp use mod_dft_gridint , only : xc_engine_t , xc_consumer_t use mod_dft_gridint , only : X__ , Y__ , Z__ use mod_dft_gridint , only : OQP_FUNTYP_LDA , OQP_FUNTYP_GGA , OQP_FUNTYP_MGGA use mod_dft_gridint_fxc , only : xc_consumer_tde_t use oqp_linalg implicit none !------------------------------------------------------------------------------- type , extends ( xc_consumer_tde_t ) :: xc_consumer_gxc_t contains procedure :: RUpdate => GxcRUpdate procedure :: UUpdate => GxcUUpdate end type !------------------------------------------------------------------------------- private public tddft_gxc !------------------------------------------------------------------------------- contains !------------------------------------------------------------------------------- !> @brief Compute XC 3rd derivative contractions needed for TD-DFT gradient, namely: !>  \\sum_{mns,kls'} (G_xc)_{mns,kls',pqs''} * (X+Y)_{mns} * (X+Y)_{kls'} !> @details spin-polarized version !> @param[inout] fa   Kohn-Sham matrices !> @author Vladimir Mironov subroutine GxcUUpdate ( dat , xce , mythread ) use mod_dft_gridint , only : xc_der2_contr , xc_der3_contr class ( xc_engine_t ) :: xce class ( xc_consumer_gxc_t ) :: dat integer :: mythread integer :: i , j , k real ( kind = fp ) :: c3 ( 3 ) real ( kind = fp ) :: f_s ( 3 ) real ( kind = fp ) :: g_r ( 2 ), g_s ( 3 ), g_t ( 2 ) real ( kind = fp ) :: rhoab ( 2 ), tauab ( 2 ), sigma ( 3 ), ssigma ( 3 ), dsaa , dsab , dsba , dsbb real ( kind = fp ), pointer :: focks (:,:,:,:) real ( kind = fp ), pointer :: tmp (:,:,:) call dat % resetOrbPointers ( xce , focks , tmp , myThread ) associate ( aoV => xce % aoV & , aoG1 => xce % aoG1 & , rrho => dat % rrho (:,:,:, mythread ) & , drrho => dat % drrho (:,:,:,:, mythread ) & , rtau => dat % rtau (:,:,:, mythread ) & , drho => xce % xclib % drho & , numAOs => xce % numAOs_p & ! number of pruned AOs , numPts => xce % numPts & , nMtx => dat % nMtx & ) do j = 1 , nMtx do i = 1 , numPts rhoab = rrho ( 1 : 2 , i , j ) sigma = 0 ssigma = 0 tauab = 0 if ( xce % funTyp /= OQP_FUNTYP_LDA ) then dsaa = dot_product ( drrho (:, 1 , i , j ), drho ( 1 : 3 , i )) dsab = dot_product ( drrho (:, 1 , i , j ), drho ( 4 : 6 , i )) dsbb = dot_product ( drrho (:, 2 , i , j ), drho ( 4 : 6 , i )) dsba = dot_product ( drrho (:, 2 , i , j ), drho ( 1 : 3 , i )) sigma = [ 2 * dsaa , 2 * dsbb , ( dsab + dsba )] dsaa = dot_product ( drrho (:, 1 , i , j ), drrho (:, 1 , i , j )) dsab = dot_product ( drrho (:, 1 , i , j ), drrho (:, 2 , i , j )) dsbb = dot_product ( drrho (:, 2 , i , j ), drrho (:, 2 , i , j )) dsba = dot_product ( drrho (:, 2 , i , j ), drrho (:, 1 , i , j )) sigma = [ 2 * dsaa , 2 * dsbb , ( dsab + dsba )] end if if ( xce % funTyp == OQP_FUNTYP_MGGA ) tauab = rtau ( 1 : 2 , i , j ) call xc_der3_contr ( xce , i , & rhoab , sigma , tauab , & ssigma , & f_s , & g_r , g_s , g_t ) ! LDA tmp (:, i , 1 ) = 0.5_fp * g_r ( 1 ) * aoV (:, i ) if ( xce % funTyp /= OQP_FUNTYP_LDA ) then ! GGA c3 = 2 * g_s ( 1 ) * drho ( 1 : 3 , i ) & + g_s ( 3 ) * drho ( 4 : 6 , i ) & + 2 * 2 * f_s ( 1 ) * drrho ( 1 : 3 , 1 , i , j ) & + 2 * f_s ( 3 ) * drrho ( 1 : 3 , 2 , i , j ) tmp (:, i , 1 ) = tmp (:, i , 1 ) & + c3 ( X__ ) * aoG1 (:, i , X__ ) & + c3 ( Y__ ) * aoG1 (:, i , Y__ ) & + c3 ( Z__ ) * aoG1 (:, i , Z__ ) end if if ( xce % funTyp == OQP_FUNTYP_MGGA ) then ! mGGA tmp (:, i , 2 : 4 ) = g_t ( 1 ) * aoG1 (:, i , X__ : Z__ ) end if end do call dsyr2k ( 'U' , 'N' , numAOs , numPts , 1.0_fp , & aoV , numAOs , & tmp (:,:, 1 ), numAOs , & 0.0_fp , focks (:,:, j , 1 ), numAOs ) if ( xce % funTyp == OQP_FUNTYP_MGGA ) then do k = 1 , 3 call dsyr2k ( 'U' , 'N' , numAOs , numPts , 0.25_fp , & aoG1 (:,:, k ), numAOs , & tmp (:,:, k + 1 ), numAOs , & 1.0_fp , focks (:,:, j , 1 ), numAOs ) end do end if do i = 1 , numPts rhoab = rrho ( 1 : 2 , i , j ) sigma = 0 ssigma = 0 tauab = 0 if ( xce % funTyp /= OQP_FUNTYP_LDA ) then dsaa = dot_product ( drrho (:, 1 , i , j ), drho ( 1 : 3 , i )) dsab = dot_product ( drrho (:, 1 , i , j ), drho ( 4 : 6 , i )) dsbb = dot_product ( drrho (:, 2 , i , j ), drho ( 4 : 6 , i )) dsba = dot_product ( drrho (:, 2 , i , j ), drho ( 1 : 3 , i )) sigma = [ 2 * dsaa , 2 * dsbb , ( dsab + dsba )] dsaa = dot_product ( drrho (:, 1 , i , j ), drrho (:, 1 , i , j )) dsab = dot_product ( drrho (:, 1 , i , j ), drrho (:, 2 , i , j )) dsbb = dot_product ( drrho (:, 2 , i , j ), drrho (:, 2 , i , j )) dsba = dot_product ( drrho (:, 2 , i , j ), drrho (:, 1 , i , j )) sigma = [ 2 * dsaa , 2 * dsbb , ( dsab + dsba )] end if if ( xce % funTyp == OQP_FUNTYP_MGGA ) tauab = rtau ( 1 : 2 , i , j ) call xc_der3_contr ( xce , i , & rhoab , sigma , tauab , & ssigma , & f_s , & g_r , g_s , g_t ) ! LDA tmp (:, i , 1 ) = 0.5_fp * g_r ( 2 ) * aoV (:, i ) if ( xce % funTyp /= OQP_FUNTYP_LDA ) then ! GGA c3 = 2 * g_s ( 2 ) * drho ( 4 : 6 , i ) & + g_s ( 3 ) * drho ( 1 : 3 , i ) & + 2 * 2 * f_s ( 2 ) * drrho ( 1 : 3 , 2 , i , j ) & + 2 * f_s ( 3 ) * drrho ( 1 : 3 , 1 , i , j ) tmp (:, i , 1 ) = tmp (:, i , 1 ) & + c3 ( X__ ) * aoG1 (:, i , X__ ) & + c3 ( Y__ ) * aoG1 (:, i , Y__ ) & + c3 ( Z__ ) * aoG1 (:, i , Z__ ) end if if ( xce % funTyp == OQP_FUNTYP_MGGA ) then ! mGGA tmp (:, i , 2 : 4 ) = g_t ( 2 ) * aoG1 (:, i , X__ : Z__ ) end if end do call dsyr2k ( 'U' , 'N' , numAOs , numPts , 1.0_fp , & aoV , numAOs , & tmp (:,:, 1 ), numAOs , & 0.0_fp , focks (:,:, j , 2 ), numAOs ) if ( xce % funTyp == OQP_FUNTYP_MGGA ) then do k = 1 , 3 call dsyr2k ( 'U' , 'N' , numAOs , numPts , 0.25_fp , & aoG1 (:,:, k ), numAOs , & tmp (:,:, k + 1 ), numAOs , & 1.0_fp , focks (:,:, j , 2 ), numAOs ) end do end if end do end associate end subroutine !------------------------------------------------------------------------------- !> @brief Compute XC 3rd derivative contractions needed for TD-DFT gradient, namely: !>  \\sum_{mns,kls'} (G_xc)_{mns,kls',pqs''} * (X+Y)_{mns} * (X+Y)_{kls'} !> @details not spin-polarized version !> @param[inout] fa   Kohn-Sham matrices !> @author Vladimir Mironov subroutine GxcRUpdate ( dat , xce , mythread ) use mod_dft_gridint , only : xc_der2_contr , xc_der3_contr class ( xc_engine_t ) :: xce class ( xc_consumer_gxc_t ) :: dat integer :: mythread integer :: i , j , k real ( kind = fp ) :: c3 ( 3 ) real ( kind = fp ) :: f_s ( 3 ) real ( kind = fp ) :: g_r ( 2 ), g_s ( 3 ), g_t ( 2 ) real ( kind = fp ) :: rhoab ( 2 ), tauab ( 2 ), sigma ( 3 ), ssigma ( 3 ) real ( kind = fp ), pointer :: focks (:,:,:,:) real ( kind = fp ), pointer :: tmp (:,:,:) call dat % resetOrbPointers ( xce , focks , tmp , myThread ) associate ( aoV => xce % aoV & , aoG1 => xce % aoG1 & , rrho => dat % rrho (:,:,:, mythread ) & , drrho => dat % drrho (:,:,:,:, mythread ) & , rtau => dat % rtau (:,:,:, mythread ) & , drho => xce % xclib % drho & , numAOs => xce % numAOs_p & ! number of pruned AOs , numPts => xce % numPts & , nMtx => dat % nMtx & ) do j = 1 , nMtx do i = 1 , numPts rhoab = rrho ( 1 , i , j ) sigma = 0 ssigma = 0 tauab = 0 if ( xce % funTyp /= OQP_FUNTYP_LDA ) then sigma = 2 * sum ( drrho ( 1 : 3 , 1 , i , j ) * drho ( 1 : 3 , i )) ssigma = 2 * sum ( drrho ( 1 : 3 , 1 , i , j ) * drrho ( 1 : 3 , 1 , i , j )) end if if ( xce % funTyp == OQP_FUNTYP_MGGA ) tauab = rtau ( 1 , i , j ) call xc_der3_contr ( xce , i , & rhoab , sigma , tauab , & ssigma , & f_s , & g_r , g_s , g_t ) ! LDA tmp (:, i , 1 ) = 0.5_fp * g_r ( 1 ) * aoV (:, i ) if ( xce % funTyp /= OQP_FUNTYP_LDA ) then ! GGA c3 = ( 2 * g_s ( 1 ) + g_s ( 3 )) * drho ( 1 : 3 , i ) & + 2 * ( 2 * f_s ( 1 ) + f_s ( 3 )) * drrho ( 1 : 3 , 1 , i , j ) tmp (:, i , 1 ) = tmp (:, i , 1 ) & + c3 ( X__ ) * aoG1 (:, i , X__ ) & + c3 ( Y__ ) * aoG1 (:, i , Y__ ) & + c3 ( Z__ ) * aoG1 (:, i , Z__ ) end if if ( xce % funTyp == OQP_FUNTYP_MGGA ) then ! mGGA tmp (:, i , 2 ) = g_t ( 1 ) * aoG1 (:, i , X__ ) tmp (:, i , 3 ) = g_t ( 1 ) * aoG1 (:, i , Y__ ) tmp (:, i , 4 ) = g_t ( 1 ) * aoG1 (:, i , Z__ ) end if end do call dsyr2k ( 'U' , 'N' , numAOs , numPts , 1.0_fp , & aoV , numAOs , & tmp (:,:, 1 ), numAOs , & 0.0_fp , focks (:,:, j , 1 ), numAOs ) if ( xce % funTyp == OQP_FUNTYP_MGGA ) then do k = 1 , 3 call dsyr2k ( 'U' , 'N' , numAOs , numPts , 0.25_fp , & aoG1 (:,:, k ), numAOs , & tmp (:,:, k + 1 ), numAOs , & 1.0_fp , focks (:,:, j , 1 ), numAOs ) end do end if end do end associate end subroutine !------------------------------------------------------------------------------- !> @brief Compute derivative XC contribution to the TD-DFT KS-like matrices !> @param[in]    basis     basis set !> @param[in]    isVecs    .true. if orbitals are provided instead of density matrix !> @param[in]    wf        density matrix/orbitals !> @param[inout] fx        fock-like matrices !> @param[inout] dx        densities !> @param[in]    nMtx      number of density/Fock-like matrices !> @param[in]    threshold tolerance !> @param[in]    infos     OQP metadata !> @author Vladimir Mironov subroutine tddft_gxc ( basis , molGrid , isVecs , wf , fx , dx , & nMtx , threshold , infos ) !$  use omp_lib, only: omp_get_num_threads, omp_get_thread_num use basis_tools , only : basis_set use mod_dft_gridint , only : xc_options_t , run_xc use types , only : information use mod_dft_molgrid , only : dft_grid_t use mathlib , only : triangular_to_full implicit none type ( information ), target , intent ( in ) :: infos type ( dft_grid_t ), target , intent ( in ) :: molGrid type ( basis_set ) :: basis logical , intent ( in ) :: isVecs integer , intent ( in ) :: nMtx real ( kind = fp ), intent ( in ) :: wf (:,:) real ( kind = fp ), intent ( inout ), target :: dx (:,:,:) real ( kind = fp ), intent ( inout ) :: fx (:,:,:) real ( kind = fp ), intent ( in ) :: threshold type ( xc_consumer_gxc_t ) :: dat type ( xc_options_t ) :: xc_opts integer :: i , j , nbf real ( kind = fp ), allocatable , target :: d2 (:,:) nbf = ubound ( wf , 1 ) ! Scale w.f. by B.F. norms allocate ( d2 ( nbf , nbf )) if ( isVecs ) then do i = 1 , nbf d2 (:, i ) = wf (:, i ) * basis % bfnrm (:) end do else do i = 1 , nbf d2 (:, i ) = wf (:, i ) & * basis % bfnrm ( i ) & * basis % bfnrm (:) end do end if ! Scale densities by B.F. norms do j = 1 , nMtx do i = 1 , nbf dx (:, i , j ) = dx (:, i , j ) & * basis % bfnrm ( i ) & * basis % bfnrm (:) end do end do xc_opts % isGGA = infos % functional % needGrd xc_opts % needTau = infos % functional % needTau xc_opts % functional => infos % functional xc_opts % hasBeta = . false . xc_opts % isWFVecs = isVecs xc_opts % numAOs = nbf xc_opts % maxPts = molGrid % maxSlicePts xc_opts % limPts = molGrid % maxNRadTimesNAng xc_opts % numAtoms = infos % mol_prop % natom xc_opts % maxAngMom = basis % mxam xc_opts % nDer = 0 xc_opts % nXCDer = 3 xc_opts % numOccAlpha = infos % mol_prop % nelec_A xc_opts % numOccBeta = infos % mol_prop % nelec_B xc_opts % wfAlpha => d2 xc_opts % dft_threshold = threshold xc_opts % molGrid => molGrid dat % da => dx dat % nMtx = nMtx call dat % pe % init ( infos % mpiinfo % comm , infos % mpiinfo % usempi ) call run_xc ( xc_opts , dat , basis ) deallocate ( d2 ) do j = 1 , nMtx call triangular_to_full ( dat % focks (:,:, j , 1 , 1 ), nbf , 'u' ) do i = 1 , nbf fx (:, i , j ) = fx (:, i , j ) & + dat % focks (:, i , j , 1 , 1 ) & * basis % bfnrm ( i ) & * basis % bfnrm (:) end do end do ! Scale densities back do j = 1 , nMtx do i = 1 , nbf dx (:, i , j ) = dx (:, i , j ) & / basis % bfnrm ( i ) & / basis % bfnrm (:) end do end do call dat % clean () end subroutine !------------------------------------------------------------------------------- end module mod_dft_gridint_gxc","tags":"","url":"sourcefile/dft_gridint_gxc.f90.html"},{"title":"eigen.F90 – OpenQP Fortran API","text":"Source Code module eigen use precision , only : dp use mathlib_types , only : blas_int use messages , only : show_message , WITH_ABORT use oqp_linalg implicit none private public :: diag_symm_packed public :: diag_symm_full public :: schmd real ( dp ), parameter :: zero = 0.0_dp , two = 2.0_dp contains !>  @brief Find eigenvalues and eigenvectors of symmetric matrix !>         in packed format !>  @param[in]     mode   algorithm of diagonalization (not used now) !>  @param[in]     n      matrix dimension !>  @param[in]     ldvect leading dimension of eigenvector matrix !>  @param[in]     nvect  required number of eigenvectors !>  @param[in,out] h      matrix to be diagonalized !>  @param[out]    eig    eigenvalues !>  @param[out]    vector eigenvectors !>  @param[out]    ierr   status subroutine diag_symm_packed ( mode , ldvect , nvect , n , h , eig , vector , ierr ) use messages , only : show_message , WITH_ABORT , WITHOUT_ABORT ! integer , intent ( in ) :: mode integer , intent ( in ) :: ldvect , nvect , n integer , optional , intent ( out ) :: ierr real ( dp ), intent ( inout ) :: h ( * ) real ( kind = dp ), intent ( out ) :: eig ( * ), vector ( * ) integer ( blas_int ), dimension (:), allocatable :: iwork , ifail integer ( blas_int ) :: ldvect_ , n_ , nvect_ , info , ione integer :: iok real ( dp ), dimension (:), allocatable :: work real ( dp ) :: abstol , dlamch logical :: fatal character ( 16 ) :: driver ldvect_ = int ( ldvect , kind = blas_int ) n_ = int ( n , kind = blas_int ) nvect_ = int ( nvect , kind = blas_int ) ione = 1 fatal = WITH_ABORT if ( present ( ierr )) fatal = WITHOUT_ABORT allocate ( work ( n * 8 ), iwork ( n * 5 ), ifail ( n ), stat = iok ) if ( iok /= 0 ) then if ( present ( ierr )) ierr = iok call show_message ( 'Cannot allocate memory' , fatal ) return end if if ( nvect == n . and . ldvect >= n ) then driver = 'DSPEV' call dspev ( 'V' , 'U' , n_ , h , eig , vector , ldvect_ , work , info ) else abstol = two * DLAMCH ( 'S' ) driver = 'DSPEVX' call dspevx ( 'V' , 'A' , 'U' , & ldvect_ , h , zero , zero , ione , ione , abstol , n_ , & eig , vector , nvect_ , work , iwork , ifail , info ) end if if ( present ( ierr )) ierr = info if ( info /= 0 ) then call show_message ( '(A,I0)' , & trim ( driver ) // ' FAILED! INFO: ' , int ( info ), fatal ) end if end subroutine diag_symm_packed !>  @brief Find eigenvalues and eigenvectors of symmetric matrix !>         in full format !>  @param[in]     mode   algorithm of diagonalization (not used now) !>  @param[in]     n      matrix dimension !>  @param[in,out] a      matrix to be diagonalized, overwritten by !>                        the eigenvectors on the exit !>  @param[in]     lda    leading dimension of the matrix !>  @param[out]    eig    eigenvalues !>  @param[out]    ierr   status subroutine diag_symm_full ( mode , n , a , lda , eival , ierr ) use messages , only : show_message , WITH_ABORT , WITHOUT_ABORT ! integer , intent ( in ) :: mode integer , intent ( in ) :: n , lda real ( dp ), intent ( inout ) :: a ( * ) real ( kind = dp ), intent ( out ) :: eival ( * ) integer , optional , intent ( out ) :: ierr integer ( blas_int ) :: lda_ , n_ , info , lwork , liwork integer :: iok real ( dp ), dimension (:), allocatable :: work integer ( blas_int ), dimension (:), allocatable :: iwork real ( dp ) :: rwork ( 1 ) integer ( blas_int ) :: irwork ( 1 ) logical :: fatal character ( 16 ) :: driver lda_ = int ( lda , kind = blas_int ) n_ = int ( n , kind = blas_int ) fatal = WITH_ABORT if ( present ( ierr )) fatal = WITHOUT_ABORT !   Divide-and-conquer driver: much faster than the QR-based DSYEV !   for large matrices (it does most of its work in blocked level-3 !   BLAS), at the cost of a larger workspace. Same accuracy class. driver = 'DSYEVD' call dsyevd ( 'V' , 'U' , n_ , a , lda_ , eival , rwork , - 1_blas_int , & irwork , - 1_blas_int , info ) lwork = int ( nint ( rwork ( 1 )), blas_int ) liwork = irwork ( 1 ) allocate ( work ( lwork ), iwork ( liwork ), stat = iok ) if ( iok /= 0 ) then if ( present ( ierr )) ierr = iok call show_message ( 'Cannot allocate memory' , fatal ) return end if call dsyevd ( 'V' , 'U' , n_ , a , lda_ , eival , work , lwork , iwork , liwork , info ) if ( present ( ierr )) ierr = info if ( info /= 0 ) then call show_message ( '(A,I0)' , & trim ( driver ) // ' FAILED! INFO: ' , int ( info ), fatal ) end if end subroutine diag_symm_full subroutine schmd ( v , m , n , ldv , x ) use , intrinsic :: iso_fortran_env , only : real64 use messages , only : show_message , WITH_ABORT implicit none integer , intent ( IN ) :: ldv , m , n real ( real64 ), intent ( INOUT ) :: v ( ldv , n ), x ( n ) real ( real64 ), allocatable :: work (:) integer :: lwork integer :: info real ( real64 ) :: wrksize ( 1 ) if ( M > N ) then call show_message ( \"SCHMD: M > N\" , WITH_ABORT ) end if if ( N > LDV ) then call show_message ( \"SCHMD: N > LDV\" , WITH_ABORT ) end if !   Householder QR-based version using LAPACK: !   query both routines so that dorgqr can also run blocked call dgeqrf ( n , m , v , ldv , x , wrksize , - 1 , info ) lwork = max ( int ( wrksize ( 1 )), n ) call dorgqr ( n , n , m , v , ldv , x , wrksize , - 1 , info ) lwork = max ( lwork , int ( wrksize ( 1 ))) allocate ( work ( lwork )) call dgeqrf ( n , m , v , ldv , x , work , lwork , info ) call dorgqr ( n , n , m , v , ldv , x , work , lwork , info ) end subroutine schmd end module eigen","tags":"","url":"sourcefile/eigen.f90.html"},{"title":"int2_pairs.F90 – OpenQP Fortran API","text":"Source Code module int2_pairs use precision , only : dp implicit none private public int2_cutoffs_t public int2_pair_storage real ( dp ), parameter :: pi4 = atan ( 1.0_dp ) !0.78539816339744831_dp real ( dp ), parameter :: pi = 4 * pi4 real ( dp ), parameter :: sqrtpito52 = sqrt ( 2.0d0 ) * pi ** 1.25d0 type int2_pair_storage real ( kind = dp ), allocatable :: & alpha_a (:), alpha_b (:), g (:), ginv (:), & k (:), p (:,:), pa (:,:), pb (:,:) real ( kind = dp ), allocatable :: & rab (:), uab (:) integer , allocatable :: ppid (:,:) contains procedure :: alloc => int2_prepare_pair_storage procedure :: compute => int2_prepare_shellpairs procedure :: clean => int2_clean_pair_storage end type type int2_cutoffs_t real ( dp ) :: integral_cutoff real ( dp ) :: pair_cutoff , quartet_cutoff , exponent_cutoff real ( dp ) :: pair_cutoff_squared real ( dp ) :: quartet_cutoff_squared contains procedure :: get => get_int2_accuracy procedure :: set => set_int2_accuracy end type int2_cutoffs_t contains subroutine int2_prepare_shellpairs ( ppairs , basis , cutoffs , noswap ) use basis_tools , only : basis_set implicit none class ( int2_pair_storage ), intent ( inout ) :: ppairs type ( basis_set ), intent ( in ) :: basis type ( int2_cutoffs_t ), intent ( in ) :: cutoffs logical , optional , intent ( in ) :: noswap integer :: i , j do i = 1 , basis % nshell do j = 1 , i call int2_prepare_pair ( ppairs , basis , cutoffs , i , j , noswap ) end do end do end subroutine ! Cleanup subroutine int2_clean_pair_storage ( ppairs ) implicit none class ( int2_pair_storage ), intent ( inout ) :: ppairs if ( allocated ( ppairs % alpha_a )) deallocate ( ppairs % alpha_a ) if ( allocated ( ppairs % alpha_b )) deallocate ( ppairs % alpha_b ) if ( allocated ( ppairs % g ) ) deallocate ( ppairs % g ) if ( allocated ( ppairs % ginv ) ) deallocate ( ppairs % ginv ) if ( allocated ( ppairs % k ) ) deallocate ( ppairs % k ) if ( allocated ( ppairs % p ) ) deallocate ( ppairs % p ) if ( allocated ( ppairs % pa ) ) deallocate ( ppairs % pa ) if ( allocated ( ppairs % pb ) ) deallocate ( ppairs % pb ) if ( allocated ( ppairs % rab ) ) deallocate ( ppairs % rab ) if ( allocated ( ppairs % uab ) ) deallocate ( ppairs % uab ) if ( allocated ( ppairs % ppid ) ) deallocate ( ppairs % ppid ) end subroutine ! Count the required storage size subroutine int2_prepare_pair_storage ( ppairs , basis , cutoffs ) use basis_tools , only : basis_set implicit none class ( int2_pair_storage ), intent ( inout ) :: ppairs type ( basis_set ), intent ( in ) :: basis type ( int2_cutoffs_t ), intent ( in ) :: cutoffs integer :: sha , shb , ksa , ksb , ncona , nconb real ( kind = dp ) :: a ( 3 ), b ( 3 ), ab2 integer :: p1 , p2 , p12 real ( kind = dp ) :: alpha1_ , alpha2_ , gammap_ , gpinv_ , e12 , klog real ( kind = dp ) :: logcut real ( kind = dp ), allocatable , target :: cclog (:) real ( kind = dp ), pointer :: cclogpa (:), cclogpb (:) integer :: nprim , nshell , nshell2 integer :: pair_id integer :: npptotal nshell = basis % nshell nshell2 = nshell * ( nshell + 1 ) / 2 nprim = basis % g_offset ( nshell ) + basis % ncontr ( nshell ) - 1 if (. not . allocated ( ppairs % ppid ). or . ubound ( ppairs % ppid , 2 ) < nshell2 ) then if ( allocated ( ppairs % ppid )) deallocate ( ppairs % ppid ) allocate ( ppairs % ppid ( 2 , nshell2 )) end if !   Allocate storage for screening allocate ( cclog ( nprim )) cclog = log ( abs ( basis % cc (: nprim )) ) logcut = log ( cutoffs % quartet_cutoff ) npptotal = 0 pair_id = 0 do sha = 1 , basis % nshell do shb = 1 , sha ksa = basis % g_offset ( sha ) ksb = basis % g_offset ( shb ) ncona = basis % ncontr ( sha ) nconb = basis % ncontr ( shb ) cclogpa => cclog ( ksa : ksa + ncona - 1 ) cclogpb => cclog ( ksb : ksb + nconb - 1 ) a = basis % shell_centers ( sha , 1 : 3 ) b = basis % shell_centers ( shb , 1 : 3 ) AB2 = SUM (( A - B ) * ( A - B )) p12 = 0 do p1 = 1 , ncona do p2 = 1 , nconb alpha1_ = basis % ex ( ksa - 1 + p1 ) alpha2_ = basis % ex ( ksb - 1 + p2 ) gammap_ = alpha1_ + alpha2_ e12 = alpha1_ * alpha2_ * AB2 if ( e12 > gammap_ * cutoffs % exponent_cutoff ) cycle gpinv_ = 1 / gammap_ e12 = e12 * gpinv_ klog = cclogpa ( p1 ) + cclogpb ( p2 ) - e12 if ( klog < logcut ) cycle p12 = p12 + 1 end do end do pair_id = pair_id + 1 ppairs % ppid ( 1 , pair_id ) = p12 ppairs % ppid ( 2 , pair_id ) = npptotal + 1 npptotal = npptotal + p12 end do end do deallocate ( cclog ) !   Allocate storage if ( allocated ( ppairs % alpha_a )) deallocate ( ppairs % alpha_a ) if ( allocated ( ppairs % alpha_b )) deallocate ( ppairs % alpha_b ) if ( allocated ( ppairs % g )) deallocate ( ppairs % g ) if ( allocated ( ppairs % ginv )) deallocate ( ppairs % ginv ) if ( allocated ( ppairs % k )) deallocate ( ppairs % k ) if ( allocated ( ppairs % p )) deallocate ( ppairs % p ) if ( allocated ( ppairs % pa )) deallocate ( ppairs % pa ) if ( allocated ( ppairs % pb )) deallocate ( ppairs % pb ) if ( allocated ( ppairs % rab )) deallocate ( ppairs % rab ) if ( allocated ( ppairs % uab )) deallocate ( ppairs % uab ) allocate ( ppairs % alpha_a ( npptotal ), source = 0.0d0 ) allocate ( ppairs % alpha_b ( npptotal ), source = 0.0d0 ) allocate ( ppairs % g ( npptotal ), source = 0.0d0 ) allocate ( ppairs % ginv ( npptotal ), source = 0.0d0 ) allocate ( ppairs % k ( npptotal ), source = 0.0d0 ) allocate ( ppairs % p ( 3 , npptotal ), source = 0.0d0 ) allocate ( ppairs % pa ( 3 , npptotal ), source = 0.0d0 ) allocate ( ppairs % pb ( 3 , npptotal ), source = 0.0d0 ) allocate ( ppairs % rab ( npptotal ), source = 0.0d0 ) allocate ( ppairs % uab ( npptotal ), source = 0.0d0 ) !    write(*,*) 'npptotal=', npptotal end subroutine subroutine int2_prepare_pair ( ppairs , basis , cutoffs , sh1 , sh2 , noswap ) use basis_tools , only : basis_set implicit none class ( int2_pair_storage ), intent ( inout ) :: ppairs type ( basis_set ), intent ( in ) :: basis type ( int2_cutoffs_t ), intent ( in ) :: cutoffs integer , intent ( in ) :: sh1 , sh2 logical , optional , intent ( in ) :: noswap integer :: ksa , ksb , ncona , nconb , anga , angb , sha , shb integer :: anga_ , angb_ real ( kind = dp ) :: a ( 3 ), b ( 3 ), ab2 integer :: p1 , p2 , p12 integer :: id1 , id2 , id12 real ( kind = dp ) :: alpha1_ , alpha2_ , gammap_ , gpinv_ , e12 , k1_ logical :: noswap_ anga_ = basis % am ( sh1 ) angb_ = basis % am ( sh2 ) noswap_ = . false . if ( present ( noswap )) noswap_ = noswap if (. not . noswap_ . and . anga_ > angb_ ) then sha = sh2 shb = sh1 anga = angb_ angb = anga_ else sha = sh1 shb = sh2 anga = anga_ angb = angb_ end if ksa = basis % g_offset ( sha ) ksb = basis % g_offset ( shb ) ncona = basis % ncontr ( sha ) nconb = basis % ncontr ( shb ) a = basis % shell_centers ( sha , 1 : 3 ) b = basis % shell_centers ( shb , 1 : 3 ) AB2 = SUM (( A - B ) * ( A - B )) id1 = max ( sha , shb ) id2 = min ( sha , shb ) id12 = id1 * ( id1 - 1 ) / 2 + id2 p12 = ppairs % ppid ( 2 , id12 ) if ( ppairs % ppid ( 1 , id12 ) > 0 ) then ppairs % rab ( p12 ) = sqrt ( AB2 ) ppairs % uab ( p12 ) = 1.0d0 / sqrt ( AB2 ) end if associate ( c1 => basis % cc ( ksa : ksa + ncona - 1 ) & , c2 => basis % cc ( ksb : ksb + nconb - 1 ) & ) DO p1 = 1 , ncona DO p2 = 1 , nconb alpha1_ = basis % ex ( ksa - 1 + p1 ) alpha2_ = basis % ex ( ksb - 1 + p2 ) gammap_ = alpha1_ + alpha2_ e12 = alpha1_ * alpha2_ * AB2 if ( e12 > gammap_ * cutoffs % exponent_cutoff ) cycle gpinv_ = 1 / gammap_ e12 = e12 * gpinv_ K1_ = c1 ( p1 ) * c2 ( p2 ) * exp ( - e12 ) if ( abs ( k1_ ) < cutoffs % quartet_cutoff ) cycle ppairs % alpha_a ( p12 ) = alpha1_ ppairs % alpha_b ( p12 ) = alpha2_ ppairs % g ( p12 ) = gammap_ ppairs % ginv ( p12 ) = gpinv_ ppairs % P (:, p12 ) = ( alpha1_ * A + alpha2_ * B ) * gpinv_ ppairs % PA (:, p12 ) = ppairs % P (:, p12 ) - A ppairs % PB (:, p12 ) = ppairs % P (:, p12 ) - B ppairs % K ( p12 ) = sqrtpito52 * k1_ p12 = p12 + 1 END DO END DO end associate end subroutine !> @brief Get screening parameters for rotated axis integral code: !> - prefactor for single bra/ket shell pair; !> - total prefactor; !> - value of exponential coefficient. subroutine get_int2_accuracy ( this , cutoff_integral_value , cutoff_prefactor_p , cutoff_prefactor_pq , cutoff_exp ) class ( int2_cutoffs_t ), intent ( in ) :: this real ( kind = dp ), intent ( out ) :: cutoff_integral_value , cutoff_prefactor_p , cutoff_prefactor_pq , cutoff_exp cutoff_integral_value = this % integral_cutoff cutoff_prefactor_p = this % pair_cutoff cutoff_prefactor_pq = this % quartet_cutoff cutoff_exp = this % exponent_cutoff end subroutine !> @brief Set screening parameters for rotated axis integral code: !> - prefactor for single bra/ket shell pair; !> - total prefactor; !> - value of exponential coefficient. subroutine set_int2_accuracy ( this , cutoff_integral_value , cutoff_prefactor_p , cutoff_prefactor_pq , cutoff_exp ) class ( int2_cutoffs_t ), intent ( inout ) :: this real ( kind = dp ), intent ( in ) :: cutoff_integral_value , cutoff_prefactor_p , cutoff_prefactor_pq , cutoff_exp this % integral_cutoff = cutoff_integral_value this % pair_cutoff = cutoff_prefactor_p this % pair_cutoff_squared = cutoff_prefactor_p ** 2 this % quartet_cutoff = cutoff_prefactor_pq this % quartet_cutoff_squared = cutoff_prefactor_pq ** 2 this % exponent_cutoff = cutoff_exp end subroutine end module","tags":"","url":"sourcefile/int2_pairs.f90.html"},{"title":"c_interop.F90 – OpenQP Fortran API","text":"Source Code module c_interop use types , only : information use messages , only : without_abort !  use types, only: oqp_handle_t use iso_c_binding , only : c_int , c_ptr , c_loc , c_f_pointer , c_associated , c_null_ptr , c_double , c_int32_t , c_int64_t , c_char implicit none private public oqp_handle_t public oqp_init public oqp_handle_refresh_ptr public oqp_handle_get_info interface oqp_handle_get_info module procedure oqp_handle_get_info_f module procedure oqp_handle_get_info_c end interface oqp_handle_get_info type , bind ( C ) :: oqp_handle_t type ( c_ptr ) :: inf type ( c_ptr ) :: xyz type ( c_ptr ) :: qn type ( c_ptr ) :: mass type ( c_ptr ) :: grad type ( c_ptr ) :: mol_prop type ( c_ptr ) :: mol_energy type ( c_ptr ) :: dft type ( c_ptr ) :: tddft type ( c_ptr ) :: control type ( c_ptr ) :: mpiinfo type ( c_ptr ) :: elshell end type ! Export buffers for oqp_get_basis. The public C API is fixed at int64_t, but ! basis_set%origin/am/ncontr are default Fortran integers, whose width follows ! the build (4 bytes in LP64 builds, e.g. native macOS Accelerate). Returning ! c_loc() of those internal arrays directly makes the Python side read pairs ! of 32-bit values as single 64-bit integers => corrupted basis metadata ! (e.g. centers [0,1] read back as [8589934592, -1]). Convert into these ! int64 buffers and export their addresses instead. Contents stay valid until ! the next oqp_get_basis call; callers (pyoqp get_basis) copy immediately. integer ( c_int64_t ), allocatable , target :: basis_am_i64 (:) integer ( c_int64_t ), allocatable , target :: basis_origin_i64 (:) integer ( c_int64_t ), allocatable , target :: basis_ncontr_i64 (:) contains !-------------------------------------------------------------------------------- function oqp_init () bind ( C , name = 'oqp_init' ) result ( res ) implicit none type ( c_ptr ) :: res type ( oqp_handle_t ), pointer :: c_handle type ( information ), pointer :: inf integer :: ok res = c_null_ptr allocate ( inf , stat = ok ) if ( ok /= 0 ) return allocate ( c_handle , stat = ok ) if ( ok /= 0 ) return c_handle % inf = c_loc ( inf ) call oqp_handle_refresh_ptr ( c_handle ) res = c_loc ( c_handle ) call inf % dat % new ( \"OQP\" ) end function oqp_init !-------------------------------------------------------------------------------- function oqp_clean ( c_handle ) bind ( C , name = 'oqp_clean' ) result ( ok ) implicit none integer ( c_int ) :: ok type ( c_ptr ), value :: c_handle type ( oqp_handle_t ), pointer :: f_handle type ( information ), pointer :: inf call c_f_pointer ( c_handle , f_handle ) call c_f_pointer ( f_handle % inf , inf ) call inf % dat % delete () deallocate ( inf , stat = ok ) if ( ok /= 0 ) return deallocate ( f_handle , stat = ok ) end function oqp_clean !-------------------------------------------------------------------------------- subroutine oqp_handle_refresh_ptr ( c_handle ) implicit none type ( oqp_handle_t ), intent ( inout ) :: c_handle type ( information ), pointer :: inf call c_f_pointer ( c_handle % inf , inf ) c_handle % mol_prop = c_loc ( inf % mol_prop ) c_handle % mol_energy = c_loc ( inf % mol_energy ) c_handle % dft = c_loc ( inf % dft ) c_handle % control = c_loc ( inf % control ) c_handle % tddft = c_loc ( inf % tddft ) c_handle % mpiinfo = c_loc ( inf % mpiinfo ) c_handle % elshell = c_loc ( inf % elshell ) if ( allocated ( inf % atoms % xyz )) then c_handle % xyz = c_loc ( inf % atoms % xyz ) c_handle % qn = c_loc ( inf % atoms % zn ) c_handle % mass = c_loc ( inf % atoms % mass ) end if if ( allocated ( inf % atoms % grad )) then c_handle % grad = c_loc ( inf % atoms % grad ) end if end subroutine oqp_handle_refresh_ptr !-------------------------------------------------------------------------------- function oqp_handle_get_info_f ( f_handle ) result ( res ) implicit none type ( oqp_handle_t ), target :: f_handle type ( information ), pointer :: res call c_f_pointer ( f_handle % inf , res ) end function oqp_handle_get_info_f !-------------------------------------------------------------------------------- function oqp_handle_get_info_c ( c_handle ) result ( res ) implicit none type ( c_ptr ) :: c_handle type ( information ), pointer :: res type ( oqp_handle_t ), pointer :: f_handle call c_f_pointer ( c_handle , f_handle ) call c_f_pointer ( f_handle % inf , res ) end function oqp_handle_get_info_c !-------------------------------------------------------------------------------- function oqp_set_atoms ( c_handle , natoms , x , y , z , q , mass ) bind ( C , name = 'oqp_set_atoms' ) result ( ok ) implicit none type ( oqp_handle_t ) :: c_handle integer ( c_int64_t ), value :: natoms real ( c_double ) :: x ( * ), y ( * ), z ( * ), q ( * ) real ( c_double ), optional :: mass ( * ) integer ( c_int ) :: ok type ( information ), pointer :: inf ok = 10 if (. not . c_associated ( c_handle % inf )) return call c_f_pointer ( c_handle % inf , inf ) ok = inf % set_atoms_arr ( natoms , x , y , z , q , mass ) if ( ok /= 0 ) return call oqp_handle_refresh_ptr ( c_handle ) end function oqp_set_atoms !-------------------------------------------------------------------------------- function oqp_get_atoms ( c_handle , xyz ) result ( ok ) type ( oqp_handle_t ) :: c_handle integer ( c_int ) :: ok real ( c_double ) :: xyz ( 3 , * ) integer :: nat type ( information ), pointer :: inf ok = 10 if (. not . c_associated ( c_handle % inf )) return call c_f_pointer ( c_handle % inf , inf ) ok = 1 nat = ubound ( inf % atoms % xyz , 2 ) xyz (:, 1 : nat ) = inf % atoms % xyz end function !-------------------------------------------------------------------------------- function oqp_get_natom ( c_handle ) result ( n ) bind ( C , name = 'oqp_get_natom' ) type ( oqp_handle_t ) :: c_handle integer ( c_int64_t ) :: n type ( information ), pointer :: inf n = - 1 if (. not . c_associated ( c_handle % inf )) return call c_f_pointer ( c_handle % inf , inf ) n = ubound ( inf % atoms % xyz , 2 ) end function !-------------------------------------------------------------------------------- function oqp_get_nbf ( c_handle ) result ( n ) bind ( C , name = 'oqp_get_nbf' ) type ( oqp_handle_t ) :: c_handle integer ( c_int64_t ) :: n type ( information ), pointer :: inf n = - 1 if (. not . c_associated ( c_handle % inf )) return call c_f_pointer ( c_handle % inf , inf ) n = inf % basis % nbf end function !-------------------------------------------------------------------------------- function oqp_get_basis ( c_handle , nsh , nprim , nbf , am , at , cdeg , ex , cc ) result ( ret ) bind ( C , name = 'oqp_get_basis' ) use basis_tools , only : basis_set type ( oqp_handle_t ) :: c_handle integer ( c_int64_t ) :: nsh , nprim , nbf integer ( c_int64_t ) :: ret type ( c_ptr ), intent ( out ) :: am , at , cdeg , ex , cc type ( information ), pointer :: inf type ( basis_set ), pointer :: bas ret = - 1 if (. not . c_associated ( c_handle % inf )) return call c_f_pointer ( c_handle % inf , inf ) bas => inf % basis nbf = bas % nbf nprim = bas % nprim nsh = bas % nshell if ( nbf <= 0 ) return #define ADDRESSOF(a,b) if(allocated(a))then;b=c_loc(a);else;return;endif ADDRESSOF ( bas % ex , ex ) ADDRESSOF ( bas % cc , cc ) #undef ADDRESSOF ! Integer arrays: do NOT export c_loc() of the internal default-integer ! arrays -- their width follows the build (4 bytes in LP64 builds) while ! the C API promises int64_t. Convert into the module-level int64 export ! buffers and hand out those addresses (see declarations above). if (. not . allocated ( bas % am )) return if (. not . allocated ( bas % origin )) return if (. not . allocated ( bas % ncontr )) return basis_am_i64 = int ( bas % am , c_int64_t ) basis_origin_i64 = int ( bas % origin , c_int64_t ) basis_ncontr_i64 = int ( bas % ncontr , c_int64_t ) am = c_loc ( basis_am_i64 ) at = c_loc ( basis_origin_i64 ) cdeg = c_loc ( basis_ncontr_i64 ) ret = 0 end function !-------------------------------------------------------------------------------- !> @brief Get calculation results from OQP handle !> @param[in]    c_handle[in]  OQP handle !> @param[in]    code[in]      Request string !> @param[in]    v[out]        Pointer to data !> @return       positive value:  success, returns size of the data !>               negative values: -1 - handle not initialized; !>                                -2 - data not available !>                                -3 - unknown request code function oqp_get ( c_handle , code , type_id , ndims , dims , v ) result ( n ) bind ( C , name = 'oqp_get' ) use strings , only : c_f_char use oqp_tagarray_driver , only : tagarray_get_cptr use tagarray_defines type ( oqp_handle_t ) :: c_handle integer ( c_int64_t ) :: n character ( kind = c_char ) :: code ( * ) type ( c_ptr ), intent ( out ) :: v integer ( c_int32_t ) :: type_id integer ( c_int32_t ) :: ndims integer ( c_int64_t ) :: dims ( TA_MAX_DIMENSIONS_LENGTH ) type ( information ), pointer :: inf character (:), allocatable :: code_str n = - 1 if (. not . c_associated ( c_handle % inf )) return call c_f_pointer ( c_handle % inf , inf ) code_str = trim ( adjustl ( c_f_char ( code ))) n = tagarray_get_cptr ( inf % dat , code_str , v , type_id , ndims , dims ) if (. not . c_associated ( v )) n = - 2 end function !-------------------------------------------------------------------------------- !> @brief Allocate storage in OQP handle !> @param[in]    c_handle[in]  OQP handle !> @param[in]    tag[in]       Tag to store data at !> @param[in]    v[out]        Pointer to the data !> @return       positive value:  success, returns size of the data !>               negative values: -1 - handle not initialized; !>                                -2 - data not available function oqp_alloc ( c_handle , tag , type_id , ndims , dims , v ) result ( n ) bind ( C , name = 'oqp_alloc' ) use strings , only : c_f_char use oqp_tagarray_driver , only : tagarray_get_cptr use tagarray_defines type ( oqp_handle_t ) :: c_handle integer ( c_int64_t ) :: n character ( kind = c_char ) :: tag ( * ) type ( c_ptr ), intent ( out ) :: v integer ( c_int32_t ) :: type_id integer ( c_int32_t ) :: ndims integer ( c_int64_t ) :: dims ( TA_MAX_DIMENSIONS_LENGTH ) type ( information ), pointer :: inf character (:), allocatable :: tag_str integer ( c_int64_t ) :: data_size integer ( c_int32_t ) :: status_ n = - 1 if (. not . c_associated ( c_handle % inf )) return call c_f_pointer ( c_handle % inf , inf ) tag_str = trim ( adjustl ( c_f_char ( tag ))) ! 1. allocate the memory in container (override, if it already exists) status_ = inf % dat % create ( tag_str , type_id , dims (: ndims ), override = . true .) ! 2. Get the pointer to the freshly allocated data n = tagarray_get_cptr ( inf % dat , tag_str , v , type_id , ndims , dims , data_size ) if (. not . c_associated ( v )) n = - 2 end function !-------------------------------------------------------------------------------- !> @brief Clean an entry in OQP handle !> @param[in]    c_handle[in]  OQP handle !> @param[in]    tag[in]       Data tag !> @return       positive value:  success, returns size of the data !>               negative values: -1 - handle not initialized; !>                                -2 - tag not found !>                                -3 - error removing data function oqp_del ( c_handle , tag ) result ( n ) bind ( C , name = 'oqp_del' ) use strings , only : c_f_char use oqp_tagarray_driver , only : data_has_tags , TA_OK use tagarray_defines type ( oqp_handle_t ) :: c_handle integer ( c_int64_t ) :: n character ( kind = c_char ) :: tag ( * ) integer ( c_int32_t ) :: stat type ( information ), pointer :: inf character (:), allocatable :: tag_str n = - 1 if (. not . c_associated ( c_handle % inf )) return call c_f_pointer ( c_handle % inf , inf ) tag_str = trim ( adjustl ( c_f_char ( tag ))) n = - 2 call data_has_tags ( inf % dat , [ tag_str ], 'c_interop' , 'oqp_del' , WITHOUT_ABORT , status = stat ) if ( stat /= TA_OK ) return n = - 3 call inf % dat % erase ([ tag_str ]) n = 0 end function !-------------------------------------------------------------------------------- end module c_interop","tags":"","url":"sourcefile/c_interop.f90.html"},{"title":"mod_1e_primitives.F90 – OpenQP Fortran API","text":"Source Code ! Protecting macro for compilers which does not support OpenMP 4.0 !#define OMPSIMD (_OPENMP >= 201307) !> @brief Helper functions and data blocks needed !> to compute one-electron integrals and their derivatives ! !> @author   Vladimir Mironov ! !> @todo !> - Unify interfaces !> - Cleanup redundant subroutines ! !     REVISION HISTORY: !> @date _Sep, 2018_ Initial release ! MODULE mod_1e_primitives USE , INTRINSIC :: ISO_FORTRAN_ENV , ONLY : REAL64 USE mod_gauss_hermite , ONLY : doQuadGaussHermite , mulQuadGaussHermite USE mod_shell_tools , ONLY : shell_t , shpair_t use rys , only : rys_root_t use xyz_order use constants , only : PI , CART_X , CART_Y , CART_Z , MAX_ANG => BAS_MXANG IMPLICIT NONE INTEGER :: iii !integer, parameter :: MAX_ANG = 6 integer , parameter :: MAX_ANG_PAD = 7 integer , parameter :: MAX_NROOTS = ( 2 * MAX_ANG + 1 ) / 2 + 1 integer , parameter , public :: MAX_EL_MOM = 3 character , parameter :: MAX_EL_MOM_S = '3' REAL ( REAL64 ), PARAMETER :: TWOPI = pi * 2.0_real64 PRIVATE PUBLIC comp_coulomb_int1_prim PUBLIC comp_kin_ovl_int1_prim PUBLIC comp_lz_int1_prim PUBLIC comp_amom_int1_prim PUBLIC comp_giao_overlap_deriv_prim PUBLIC comp_giao_h10_core_prim PUBLIC comp_nmr_dia_int1_prim PUBLIC comp_pso_int1_prim PUBLIC comp_giao_a01gp_prim public comp_mult_int1_prim public comp_allmult_int1_prim PUBLIC comp_coulomb_dampch_int1_prim PUBLIC comp_ewaldlr_int1_prim PUBLIC comp_coulpot_prim PUBLIC comp_coulomb_der1 PUBLIC comp_coulomb_helfeyder1 PUBLIC comp_kinetic_der1 PUBLIC comp_overlap_der1 PUBLIC comp_overlap_der1_block PUBLIC comp_kinetic_der1_block PUBLIC comp_coulomb_der1_block PUBLIC comp_coulomb_helfeyder1_block PUBLIC comp_kinetic_der2 PUBLIC comp_overlap_der2 PUBLIC der_kinovl_xyz PUBLIC der2_kinovl_xyz PUBLIC der_coul_xyz PUBLIC der2_coul_xyz PUBLIC comp_coulomb_der2_braC PUBLIC comp_coulomb_der2_blocks PUBLIC comp_ewaldlr_der1 PUBLIC comp_ewaldlr_helfeyder1 PUBLIC update_triang_matrix PUBLIC update_rectangular_matrix PUBLIC density_ordered PUBLIC density_unordered PUBLIC comp_pvp_int1_prim PUBLIC comp_soc_int1_prim public comp_soc_int2_prim public QGaussRys2e CONTAINS !-------------------------------------------------------------------------------- !       ONE-ELECTRON INTEGRALS CALCULATION (PRIMITIVE GAUSSIANS) !-------------------------------------------------------------------------------- !> @brief Compute primitive block of overlap and kinetic energy 1e integrals !> @param[in]       cp          shell pair data !> @param[in]       id          current pair of primitives !> @param[in]       dokinetic   if `.FALSE.` compute only overlap integrals !> @param[inout]    sblk        block of 1e overlap integrals !> @param[inout]    tblk        block of 1e kinetic energy integrals ! !> @author   Vladimir Mironov ! !     REVISION HISTORY: !> @date _Sep, 2018_ Initial release ! SUBROUTINE comp_kin_ovl_int1_prim ( cp , id , dokinetic , sblk , tblk ) !dir$ attributes inline :: comp_kin_ovl_int1_prim TYPE ( shpair_t ), INTENT ( IN ) :: cp INTEGER , INTENT ( IN ) :: id LOGICAL , INTENT ( IN ) :: dokinetic REAL ( REAL64 ), CONTIGUOUS , INTENT ( INOUT ) :: sblk (:), tblk (:) INTEGER :: i , j , nx , ny , nz , mx , my , mz , jmax , ij REAL ( REAL64 ) :: ovl , kinx , kiny , kinz , kin real ( real64 ) :: xyzovl ( 0 : max_ang + 2 , 0 : max_ang , 3 ) real ( real64 ) :: xyzkin ( 0 : max_ang_pad , 0 : max_ang , 3 ) !dir$ assume_aligned sblk : 64 !dir$ assume_aligned tblk : 64 !dir$ assume_aligned xyzkin : 64 !dir$ assume_aligned xyzovl : 64 jmax = cp % jang IF ( dokinetic ) jmax = cp % jang + 2 ASSOCIATE ( pp => cp % p ( id )) CALL overlap_xyz ( cp % ri , cp % rj , pp % r , pp % aa1 , cp % iang , jmax , xyzovl ) IF ( dokinetic ) CALL kinetic_xyz_j ( xyzkin , xyzovl , cp % iang , cp % jang , pp % aj ) ij = 0 jmax = cp % jnao DO i = 1 , cp % inao nx = CART_X ( i , cp % iang ) ny = CART_Y ( i , cp % iang ) nz = CART_Z ( i , cp % iang ) IF ( cp % iandj ) jmax = i DO j = 1 , jmax mx = CART_X ( j , cp % jang ) my = CART_Y ( j , cp % jang ) mz = CART_Z ( j , cp % jang ) ij = ij + 1 ovl = xyzovl ( mx , nx , 1 ) * xyzovl ( my , ny , 2 ) * xyzovl ( mz , nz , 3 ) sblk ( ij ) = sblk ( ij ) + pp % expfac * ovl IF ( dokinetic ) THEN kinx = xyzkin ( mx , nx , 1 ) * xyzovl ( my , ny , 2 ) * xyzovl ( mz , nz , 3 ) kiny = xyzovl ( mx , nx , 1 ) * xyzkin ( my , ny , 2 ) * xyzovl ( mz , nz , 3 ) kinz = xyzovl ( mx , nx , 1 ) * xyzovl ( my , ny , 2 ) * xyzkin ( mz , nz , 3 ) kin = kinx + kiny + kinz tblk ( ij ) = tblk ( ij ) + pp % expfac * kin END IF END DO END DO END ASSOCIATE END SUBROUTINE !> @brief Compute primitive block of 1e Coulomb atraction integrals !> @param[in]       cp          shell pair data !> @param[in]       id          current pair of primitives !> @param[in]       c           coordinates of the charged particle !> @param[in]       znuc        particle charge !> @param[inout]    vblk        block of 1e Coulomb integrals ! !> @author   Vladimir Mironov ! !     REVISION HISTORY: !> @date _Sep, 2018_ Initial release ! SUBROUTINE comp_coulomb_int1_prim ( cp , id , c , znuc , vblk ) !dir$ attributes inline :: comp_coulomb_int1_prim TYPE ( shpair_t ), INTENT ( IN ) :: cp INTEGER , INTENT ( IN ) :: id REAL ( REAL64 ), INTENT ( IN ) :: c ( 3 ), znuc REAL ( REAL64 ), CONTIGUOUS , INTENT ( INOUT ) :: vblk (:) REAL ( REAL64 ) :: xx type ( rys_root_t ) :: ryscomp INTEGER :: i , j , ij , jmax , nx , ny , nz , mx , my , mz REAL ( REAL64 ) :: dum , dij real ( real64 ) :: xyzin ( 0 : 2 * max_ang + 1 , 0 : max_ang + 1 , 3 , max_nroots ) !dir$ assume_aligned xyzin : 64 !dir$ assume_aligned vblk : 64 ASSOCIATE ( pp => cp % p ( id ), & iang => cp % iang , jang => cp % jang , & inao => cp % inao , jnao => cp % jnao ) xx = pp % aa * sum (( pp % r - c ) ** 2 ) ryscomp % nroots = cp % nroots ryscomp % x = xx CALL QGaussRys ( ryscomp , cp , id , c , znuc , xyzin ) dij = pp % expfac * TWOPI * pp % aa1 ij = 0 jmax = jnao DO i = 1 , inao nx = CART_X ( i , iang ) ny = CART_Y ( i , iang ) nz = CART_Z ( i , iang ) IF ( cp % iandj ) jmax = i DO j = 1 , jmax mx = CART_X ( j , jang ) my = CART_Y ( j , jang ) mz = CART_Z ( j , jang ) ij = ij + 1 dum = dij * sum ( xyzin ( mx , nx , 1 , 1 : cp % nroots ) & * xyzin ( my , ny , 2 , 1 : cp % nroots ) & * xyzin ( mz , nz , 3 , 1 : cp % nroots ) ) vblk ( ij ) = vblk ( ij ) + dum END DO END DO END ASSOCIATE END SUBROUTINE !> @brief Compute primitive block of 1e Coulomb atraction integrals for !>  Ewald summation, long-range part !> @details 1e integrals using modified Coulomb potential: !>  \\f$ \\frac{Erf(\\omega&#94;{1/2}|r-r_C|)}{|r-r_C|} \\f$ !> @param[in]       cp          shell pair data !> @param[in]       id          current pair of primitives !> @param[in]       c           coordinates of the charged particle !> @param[in]       znuc        particle charge !> @param[in]       omega       Ewald splitting parameter !> @param[inout]    vblk        block of 1e Coulomb integrals ! !> @author   Vladimir Mironov ! !     REVISION HISTORY: !> @date _Sep, 2018_ Initial release ! SUBROUTINE comp_ewaldlr_int1_prim ( cp , id , c , znuc , omega , vblk ) !dir$ attributes inline :: comp_ewaldlr_int1_prim TYPE ( shpair_t ), INTENT ( IN ) :: cp INTEGER , INTENT ( IN ) :: id REAL ( REAL64 ), INTENT ( IN ) :: c ( 3 ), znuc REAL ( REAL64 ), INTENT ( IN ) :: omega REAL ( REAL64 ), CONTIGUOUS , INTENT ( INOUT ) :: vblk (:) REAL ( REAL64 ) :: xx type ( rys_root_t ) :: ryscomp INTEGER :: i , j , ij , jmax , nx , ny , nz , mx , my , mz REAL ( REAL64 ) :: dum , dij , xfac real ( real64 ) :: xyzin ( 0 : 2 * max_ang + 1 , 0 : max_ang + 1 , 3 , max_nroots ) !dir$ assume_aligned xyzin : 64 !dir$ assume_aligned vblk : 64 ASSOCIATE ( pp => cp % p ( id ), & iang => cp % iang , jang => cp % jang , & inao => cp % inao , jnao => cp % jnao ) IF ( omega <= 0.0d0 ) RETURN xfac = omega * omega / ( pp % aa + omega * omega ) xx = pp % aa * sum (( pp % r - c ) ** 2 ) * xfac ryscomp % nroots = cp % nroots ryscomp % x = xx CALL QGaussRysEw ( ryscomp , cp , id , c , znuc , xfac , xyzin ) dij = pp % expfac * TWOPI * pp % aa1 * sqrt ( xfac ) ij = 0 jmax = jnao DO i = 1 , inao nx = CART_X ( i , iang ) ny = CART_Y ( i , iang ) nz = CART_Z ( i , iang ) IF ( cp % iandj ) jmax = i DO j = 1 , jmax mx = CART_X ( j , jang ) my = CART_Y ( j , jang ) mz = CART_Z ( j , jang ) ij = ij + 1 dum = dij * sum ( xyzin ( mx , nx , 1 , 1 : cp % nroots ) & * xyzin ( my , ny , 2 , 1 : cp % nroots ) & * xyzin ( mz , nz , 3 , 1 : cp % nroots ) ) vblk ( ij ) = vblk ( ij ) + dum END DO END DO END ASSOCIATE END SUBROUTINE !> @brief Subtract damping function term from ESP block !> @details Compute one-electron Coulomb integrals with the damping function: !>  \\f$ |r-r_C|&#94;{-1} (1 - \\beta e&#94;{-\\alpha(r-r_C)&#94;2}) \\f$ !>  Only the part \\f$ - |r-r_C|&#94;{-1} \\beta e&#94;{-\\alpha(r-r_C)&#94;2}) \\f$ is computed here; !>  the other part is regular Coulomb potential computed elsewhere !> @param[in]       cp          shell pair data !> @param[in]       id          current pair of primitives !> @param[in]       alpha       dumping exponent !> @param[in]       beta        dumping function scaling factor !> @param[in]       c           coordinates of the charged particle !> @param[in]       znuc        particle charge !> @param[inout]    vblk        block of 1e Coulomb integrals ! !> @author   Vladimir Mironov ! !     REVISION HISTORY: !> @date _Sep, 2018_ Initial release ! SUBROUTINE comp_coulomb_dampch_int1_prim ( cp , id , alpha , beta , c , znuc , vblk ) !dir$ attributes forceinline :: comp_coulomb_dampch_int1_prim TYPE ( shpair_t ), INTENT ( IN ) :: cp INTEGER , INTENT ( IN ) :: id REAL ( REAL64 ), INTENT ( IN ) :: alpha , beta , c ( 3 ), znuc REAL ( REAL64 ), CONTIGUOUS , INTENT ( INOUT ) :: vblk (:) REAL ( REAL64 ) :: xx type ( rys_root_t ) :: ryscomp REAL ( REAL64 ) :: dumgij , pcsq , prei , dum , dum1 INTEGER :: i , j , ij , nx , ny , nz , mx , my , mz , jmax real ( real64 ) :: xyzin ( 0 : 2 * max_ang + 1 , 0 : max_ang + 1 , 3 , max_nroots ) !dir$ assume_aligned xyzin : 64 !dir$ assume_aligned vblk : 64 ASSOCIATE ( pp => cp % p ( id ), & iang => cp % iang , jang => cp % jang , & inao => cp % inao , jnao => cp % jnao ) pcsq = pp % aa * sum (( pp % r - c ) ** 2 ) xx = pp % aa * pcsq / ( pp % aa + alpha ) !   scale DIJ with 1/(aa+alpha) factor dumgij = TWOPI / ( pp % aa + alpha ) prei = exp ( - ( pcsq - xx )) dum1 = dumgij * pp % expfac * prei * beta ryscomp % nroots = cp % nroots ryscomp % x = xx CALL QGaussRys_damp ( ryscomp , cp , id , c , znuc , alpha , xyzin ) ij = 0 jmax = jnao DO i = 1 , inao nx = CART_X ( i , iang ) ny = CART_Y ( i , iang ) nz = CART_Z ( i , iang ) IF ( cp % iandj ) jmax = i DO j = 1 , jmax mx = CART_X ( j , jang ) my = CART_Y ( j , jang ) mz = CART_Z ( j , jang ) ij = ij + 1 dum = sum ( xyzin ( mx , nx , 1 , 1 : cp % nroots )& * xyzin ( my , ny , 2 , 1 : cp % nroots )& * xyzin ( mz , nz , 3 , 1 : cp % nroots ) ) vblk ( ij ) = vblk ( ij ) - dum1 * dum END DO END DO END ASSOCIATE END SUBROUTINE !> @brief Compute sum of 1e Coulomb integrals over primitive shell pair !> @param[in]       cp          shell pair data !> @param[in]       id          current pair of primitives !> @param[in]       c           coordinates of the charged particle !> @param[in]       den         normalized density matrix block !> @param[inout]    vsum        sum of Coulomb integrals over pair of primitives ! !> @author   Vladimir Mironov ! !     REVISION HISTORY: !> @date _Oct, 2018_ Initial release ! SUBROUTINE comp_coulpot_prim ( cp , id , c , den , vsum ) !dir$ attributes inline :: comp_coulpot_prim TYPE ( shpair_t ), INTENT ( IN ) :: cp INTEGER , INTENT ( IN ) :: id REAL ( REAL64 ), INTENT ( IN ) :: c ( 3 ) REAL ( REAL64 ), INTENT ( IN ) :: den (:) REAL ( REAL64 ), INTENT ( INOUT ) :: vsum REAL ( REAL64 ) :: xx type ( rys_root_t ) :: ryscomp REAL ( REAL64 ) :: tmp INTEGER :: i , j , ij , jmax , nx , ny , nz , mx , my , mz real ( real64 ) :: xyzin ( 0 : 2 * max_ang + 1 , 0 : max_ang + 1 , 3 , max_nroots ) !dir$ assume_aligned xyzin : 64 ASSOCIATE ( pp => cp % p ( id ), & iang => cp % iang , jang => cp % jang , & inao => cp % inao , jnao => cp % jnao ) xx = pp % aa * sum (( pp % r - c ) ** 2 ) ryscomp % nroots = cp % nroots ryscomp % x = xx CALL QGaussRys ( ryscomp , cp , id , c , - 1.0d0 , xyzin ) tmp = 0.0 ij = 0 jmax = jnao DO i = 1 , inao nx = CART_X ( i , iang ) ny = CART_Y ( i , iang ) nz = CART_Z ( i , iang ) IF ( cp % iandj ) jmax = i DO j = 1 , jmax mx = CART_X ( j , jang ) my = CART_Y ( j , jang ) mz = CART_Z ( j , jang ) ij = ij + 1 tmp = tmp + den ( ij ) * sum ( xyzin ( mx , nx , 1 , 1 : cp % nroots )& * xyzin ( my , ny , 2 , 1 : cp % nroots )& * xyzin ( mz , nz , 3 , 1 : cp % nroots ) ) END DO END DO vsum = vsum + tmp * pp % expfac * TWOPI * pp % aa1 END ASSOCIATE END SUBROUTINE !> @brief Compute primitive block of 1e Coulomb ESP integrals in FMO method !> @param[in]       cp          shell pair data !> @param[in]       id          current pair of primitives !> @param[inout]    zblk        block of 1e Lz-integrals ! !> @author   Vladimir Mironov ! !     REVISION HISTORY: !> @date _Sep, 2018_ Initial release ! SUBROUTINE comp_lz_int1_prim ( cp , id , zblk ) !dir$ attributes inline :: int1_lz_prim TYPE ( shpair_t ), INTENT ( IN ) :: cp INTEGER , INTENT ( IN ) :: id REAL ( REAL64 ), CONTIGUOUS , INTENT ( INOUT ) :: zblk (:) INTEGER :: i , j , ij , nx , ny , nz , mx , my , mz , jmax REAL ( REAL64 ) :: dum2 real ( real64 ) :: xyzovl ( 0 : max_ang + 2 , 0 : max_ang , 3 ) real ( real64 ) :: xyzlz ( 0 : max_ang_pad , 0 : max_ang , 2 ) !dir$ assume_aligned zblk : 64 !dir$ assume_aligned xyzovl : 64 !dir$ assume_aligned xyzlz : 64 ASSOCIATE ( pp => cp % p ( id ), & iang => cp % iang , jang => cp % jang , & inao => cp % inao , jnao => cp % jnao ) CALL overlap_xyz ( cp % ri , cp % rj , pp % r , pp % aa1 , iang , jang + 1 , xyzovl ) ! j-1 xyzlz ( 0 , 0 : iang , 1 : 2 ) = 0.0 DO j = 1 , jang xyzlz ( j , 0 : iang , 1 : 2 ) = j * xyzovl ( j - 1 , 0 : iang , 1 : 2 ) END DO ij = 0 jmax = jnao DO i = 1 , inao nx = CART_X ( i , iang ) ny = CART_Y ( i , iang ) nz = CART_Z ( i , iang ) IF ( cp % iandj ) jmax = i DO j = 1 , jmax mx = CART_X ( j , jang ) my = CART_Y ( j , jang ) mz = CART_Z ( j , jang ) ij = ij + 1 dum2 = xyzovl ( mx + 1 , nx , 1 ) * xyzlz ( my , ny , 2 ) - xyzlz ( mx , nx , 1 ) * xyzovl ( my + 1 , ny , 2 ) zblk ( ij ) = zblk ( ij ) + pp % expfac * dum2 * xyzovl ( mz , nz , 3 ) END DO END DO END ASSOCIATE END SUBROUTINE !> @brief Compute primitive block of angular momentum integrals about a !>        gauge origin `o`, all three components. !> @details Computes the real, antisymmetric matrix elements of the orbital !>  angular momentum operator measured about the point `o`: !>    \\f$ A_a = \\epsilon_{abc} (r-o)_b \\partial_c \\f$, a,b,c = x,y,z !>  i.e. \\f$ L = -i\\,(r-o)\\times\\nabla = -i\\,A \\f$, so the physical angular !>  momentum operator is \\f$ -i \\f$ times the block returned here. !>  Each component factorizes into a product of 1D factors: a moment-about-`o` !>  factor on one axis, a ket-derivative factor on another, and a plain overlap !>  on the third. The ket derivative uses the Gaussian rule !>    \\f$ \\partial \\phi_\\nu = 2\\alpha_\\nu \\phi_{\\nu+1} - n_\\nu \\phi_{\\nu-1} \\f$. !> @param[in]       cp          shell pair data !> @param[in]       id          current pair of primitives !> @param[in]       o           gauge origin !> @param[inout]    blk         block of 1e angular momentum integrals (:,1:3) ! !> @author   Generated for NMR shielding (CGO) ! SUBROUTINE comp_amom_int1_prim ( cp , id , o , blk ) !dir$ attributes inline :: comp_amom_int1_prim type ( shpair_t ), intent ( in ) :: cp integer , intent ( in ) :: id real ( real64 ), contiguous , intent ( in ) :: o (:) real ( real64 ), contiguous , intent ( inout ) :: blk (:,:) integer , parameter :: X__ = 1 , Y__ = 2 , Z__ = 3 INTEGER :: i , j , nx , ny , nz , mx , my , mz , ij , jmax REAL ( REAL64 ) :: aj REAL ( REAL64 ) :: sx0 , sy0 , sz0 , mx1 , my1 , mz1 , dx , dy , dz real ( real64 ) :: xyzmom ( 3 , 0 : 1 , 0 : max_ang + 1 , 0 : max_ang ) ASSOCIATE ( pp => cp % p ( id )) aj = pp % aj ! moments about `o` (mom 0 = overlap, mom 1 = (q-o) moment), ! ket angular momentum extended by 1 to allow the ket derivative. CALL multipole_xyz ( cp % ri , cp % rj , pp % r , pp % aa1 , cp % iang , cp % jang + 1 , o , 1 , xyzmom ) ij = 0 jmax = cp % jnao DO i = 1 , cp % inao nx = CART_X ( i , cp % iang ) ny = CART_Y ( i , cp % iang ) nz = CART_Z ( i , cp % iang ) IF ( cp % iandj ) jmax = i DO j = 1 , jmax mx = CART_X ( j , cp % jang ) my = CART_Y ( j , cp % jang ) mz = CART_Z ( j , cp % jang ) ij = ij + 1 ! plain overlaps sx0 = xyzmom ( X__ , 0 , mx , nx ) sy0 = xyzmom ( Y__ , 0 , my , ny ) sz0 = xyzmom ( Z__ , 0 , mz , nz ) ! (q-o) moments mx1 = xyzmom ( X__ , 1 , mx , nx ) my1 = xyzmom ( Y__ , 1 , my , ny ) mz1 = xyzmom ( Z__ , 1 , mz , nz ) ! ket derivatives: 2*aj*S(ket+1) - n_ket*S(ket-1) dx = 2 * aj * xyzmom ( X__ , 0 , mx + 1 , nx ) - mx * xyzmom ( X__ , 0 , max ( mx - 1 , 0 ), nx ) dy = 2 * aj * xyzmom ( Y__ , 0 , my + 1 , ny ) - my * xyzmom ( Y__ , 0 , max ( my - 1 , 0 ), ny ) dz = 2 * aj * xyzmom ( Z__ , 0 , mz + 1 , nz ) - mz * xyzmom ( Z__ , 0 , max ( mz - 1 , 0 ), nz ) ! A_x = (y-o_y) d_z - (z-o_z) d_y blk ( ij , X__ ) = blk ( ij , X__ ) + pp % expfac * sx0 * ( my1 * dz - mz1 * dy ) ! A_y = (z-o_z) d_x - (x-o_x) d_z blk ( ij , Y__ ) = blk ( ij , Y__ ) + pp % expfac * sy0 * ( mz1 * dx - mx1 * dz ) ! A_z = (x-o_x) d_y - (y-o_y) d_x blk ( ij , Z__ ) = blk ( ij , Z__ ) + pp % expfac * sz0 * ( mx1 * dy - my1 * dx ) END DO END DO END ASSOCIATE END SUBROUTINE !> @brief Primitive GIAO/London overlap magnetic derivative block. !> @details Accumulates the real coefficient of the imaginary first magnetic !>  derivative of the AO overlap matrix, omitting the common factor i.  For a !>  bra function centered at R_mu and ket function centered at R_nu, !>    S10_a(mu,nu) = 0.5 * [(R_mu - R_nu) x <mu|r|nu>]_a. !>  This is the first native GIAO one-electron building block; it is not wired !>  into the NMR shielding dispatch until h10/two-electron/CPHF terms pass the !>  benchmark matrix. SUBROUTINE comp_giao_overlap_deriv_prim ( cp , id , blk ) !dir$ attributes inline :: comp_giao_overlap_deriv_prim type ( shpair_t ), intent ( in ) :: cp integer , intent ( in ) :: id real ( real64 ), contiguous , intent ( inout ) :: blk (:,:) integer , parameter :: X__ = 1 , Y__ = 2 , Z__ = 3 INTEGER :: i , j , nx , ny , nz , mx , my , mz , ij , jmax REAL ( REAL64 ) :: sx0 , sy0 , sz0 , mx1 , my1 , mz1 , mu_x , mu_y , mu_z REAL ( REAL64 ) :: dr ( 3 ), zero ( 3 ) real ( real64 ) :: xyzmom ( 3 , 0 : 1 , 0 : max_ang , 0 : max_ang ) zero = 0.0_real64 dr = cp % ri (: 3 ) - cp % rj (: 3 ) ASSOCIATE ( pp => cp % p ( id )) CALL multipole_xyz ( cp % ri , cp % rj , pp % r , pp % aa1 , cp % iang , cp % jang , zero , 1 , xyzmom ) ij = 0 jmax = cp % jnao DO i = 1 , cp % inao nx = CART_X ( i , cp % iang ) ny = CART_Y ( i , cp % iang ) nz = CART_Z ( i , cp % iang ) IF ( cp % iandj ) jmax = i DO j = 1 , jmax mx = CART_X ( j , cp % jang ) my = CART_Y ( j , cp % jang ) mz = CART_Z ( j , cp % jang ) ij = ij + 1 sx0 = xyzmom ( X__ , 0 , mx , nx ) sy0 = xyzmom ( Y__ , 0 , my , ny ) sz0 = xyzmom ( Z__ , 0 , mz , nz ) mx1 = xyzmom ( X__ , 1 , mx , nx ) my1 = xyzmom ( Y__ , 1 , my , ny ) mz1 = xyzmom ( Z__ , 1 , mz , nz ) mu_x = mx1 * sy0 * sz0 mu_y = sx0 * my1 * sz0 mu_z = sx0 * sy0 * mz1 blk ( ij , X__ ) = blk ( ij , X__ ) + 0.5_real64 * pp % expfac * ( dr ( Y__ ) * mu_z - dr ( Z__ ) * mu_y ) blk ( ij , Y__ ) = blk ( ij , Y__ ) + 0.5_real64 * pp % expfac * ( dr ( Z__ ) * mu_x - dr ( X__ ) * mu_z ) blk ( ij , Z__ ) = blk ( ij , Z__ ) + 0.5_real64 * pp % expfac * ( dr ( X__ ) * mu_y - dr ( Y__ ) * mu_x ) END DO END DO END ASSOCIATE END SUBROUTINE !> @brief Primitive GIAO/London first-order core-Hamiltonian magnetic derivative. !> @details Accumulates the real coefficient of the imaginary RHF GIAO h10 one- !>  electron operator, omitting the common factor i.  The convention follows the !>  libcint RHF NMR core-orbital convention !>  h10_core = - int1e_ignuc(asym) - int1e_igkin.  The assembled !>  int1_giao_h10_core routine adds the separate -0.5*int1e_giao_irjxp !>  one-electron GIAO term.  This is still not a shielding, does not include the !>  GIAO two-electron Fock derivative, and must not ungate nmr_gauge=giao by !>  itself. SUBROUTINE comp_giao_h10_core_prim ( cp , id , coord , zq , nat , blk ) !dir$ attributes inline :: comp_giao_h10_core_prim type ( shpair_t ), intent ( in ) :: cp integer , intent ( in ) :: id real ( real64 ), contiguous , intent ( in ) :: coord (:,:), zq (:) integer , intent ( in ) :: nat real ( real64 ), contiguous , intent ( inout ) :: blk (:,:) integer , parameter :: X__ = 1 , Y__ = 2 , Z__ = 3 integer , parameter :: NRT = MAX_NROOTS type ( rys_root_t ) :: ryscomp integer :: i , j , ic , nx , ny , nz , mx , my , mz , ij , jmax real ( real64 ) :: xx , dij , kin0 , nuc0 , kin_mom ( 3 ), nuc_mom ( 3 ), mom ( 3 ), cvec ( 3 ) real ( real64 ) :: ovl_x0 , ovl_y0 , ovl_z0 , ovl_x1 , ovl_y1 , ovl_z1 real ( real64 ) :: rys_x0 , rys_y0 , rys_z0 , rys_x1 , rys_y1 , rys_z1 real ( real64 ) :: xyzovl ( 0 : max_ang + 2 , 0 : max_ang + 1 , 3 ) real ( real64 ) :: xyzkin ( 0 : max_ang_pad , 0 : max_ang + 1 , 3 ) real ( real64 ) :: xyzin ( 0 : 2 * max_ang + 1 , 0 : max_ang + 1 , 3 , NRT ) !dir$ assume_aligned blk : 64 !dir$ assume_aligned xyzkin : 64 !dir$ assume_aligned xyzovl : 64 !dir$ assume_aligned xyzin : 64 cvec = cp % ri (: 3 ) - cp % rj (: 3 ) associate ( pp => cp % p ( id )) call overlap_xyz ( cp % ri , cp % rj , pp % r , pp % aa1 , cp % iang + 1 , cp % jang + 2 , xyzovl ) call kinetic_xyz_j ( xyzkin , xyzovl , cp % iang + 1 , cp % jang , pp % aj ) ij = 0 jmax = cp % jnao do i = 1 , cp % inao nx = CART_X ( i , cp % iang ) ny = CART_Y ( i , cp % iang ) nz = CART_Z ( i , cp % iang ) if ( cp % iandj ) jmax = i do j = 1 , jmax mx = CART_X ( j , cp % jang ) my = CART_Y ( j , cp % jang ) mz = CART_Z ( j , cp % jang ) ij = ij + 1 ovl_x0 = xyzovl ( mx , nx , X__ ) ovl_y0 = xyzovl ( my , ny , Y__ ) ovl_z0 = xyzovl ( mz , nz , Z__ ) ovl_x1 = xyzovl ( mx , nx + 1 , X__ ) ovl_y1 = xyzovl ( my , ny + 1 , Y__ ) ovl_z1 = xyzovl ( mz , nz + 1 , Z__ ) kin0 = xyzkin ( mx , nx , X__ ) * ovl_y0 * ovl_z0 & + ovl_x0 * xyzkin ( my , ny , Y__ ) * ovl_z0 & + ovl_x0 * ovl_y0 * xyzkin ( mz , nz , Z__ ) kin_mom ( X__ ) = xyzkin ( mx , nx + 1 , X__ ) * ovl_y0 * ovl_z0 & + ovl_x1 * xyzkin ( my , ny , Y__ ) * ovl_z0 & + ovl_x1 * ovl_y0 * xyzkin ( mz , nz , Z__ ) & + cp % ri ( X__ ) * kin0 kin_mom ( Y__ ) = xyzkin ( mx , nx , X__ ) * ovl_y1 * ovl_z0 & + ovl_x0 * xyzkin ( my , ny + 1 , Y__ ) * ovl_z0 & + ovl_x0 * ovl_y1 * xyzkin ( mz , nz , Z__ ) & + cp % ri ( Y__ ) * kin0 kin_mom ( Z__ ) = xyzkin ( mx , nx , X__ ) * ovl_y0 * ovl_z1 & + ovl_x0 * xyzkin ( my , ny , Y__ ) * ovl_z1 & + ovl_x0 * ovl_y0 * xyzkin ( mz , nz + 1 , Z__ ) & + cp % ri ( Z__ ) * kin0 nuc_mom = 0.0_real64 nuc0 = 0.0_real64 do ic = 1 , nat xx = pp % aa * sum (( pp % r (: 3 ) - coord (:, ic )) ** 2 ) ryscomp % nroots = cp % nroots ryscomp % x = xx call QGaussRys ( ryscomp , cp , id , coord (:, ic ), - zq ( ic ), xyzin , 1 ) dij = pp % expfac * TWOPI * pp % aa1 nuc0 = nuc0 + dij * sum ( xyzin ( mx , nx , X__ , 1 : cp % nroots ) & * xyzin ( my , ny , Y__ , 1 : cp % nroots ) & * xyzin ( mz , nz , Z__ , 1 : cp % nroots )) nuc_mom ( X__ ) = nuc_mom ( X__ ) + dij * sum ( xyzin ( mx , nx + 1 , X__ , 1 : cp % nroots ) & * xyzin ( my , ny , Y__ , 1 : cp % nroots ) & * xyzin ( mz , nz , Z__ , 1 : cp % nroots )) nuc_mom ( Y__ ) = nuc_mom ( Y__ ) + dij * sum ( xyzin ( mx , nx , X__ , 1 : cp % nroots ) & * xyzin ( my , ny + 1 , Y__ , 1 : cp % nroots ) & * xyzin ( mz , nz , Z__ , 1 : cp % nroots )) nuc_mom ( Z__ ) = nuc_mom ( Z__ ) + dij * sum ( xyzin ( mx , nx , X__ , 1 : cp % nroots ) & * xyzin ( my , ny , Y__ , 1 : cp % nroots ) & * xyzin ( mz , nz + 1 , Z__ , 1 : cp % nroots )) end do nuc_mom (:) = nuc_mom (:) + cp % ri (:) * nuc0 mom = pp % expfac * kin_mom + nuc_mom blk ( ij , X__ ) = blk ( ij , X__ ) + 0.5_real64 * ( cvec ( Y__ ) * mom ( Z__ ) - cvec ( Z__ ) * mom ( Y__ )) blk ( ij , Y__ ) = blk ( ij , Y__ ) + 0.5_real64 * ( cvec ( Z__ ) * mom ( X__ ) - cvec ( X__ ) * mom ( Z__ )) blk ( ij , Z__ ) = blk ( ij , Z__ ) + 0.5_real64 * ( cvec ( X__ ) * mom ( Y__ ) - cvec ( Y__ ) * mom ( X__ )) end do end do end associate END SUBROUTINE !> @brief Density-contracted NMR diamagnetic shielding integrals for one nucleus. !> @details Accumulates the nine components !>    g_ab = sum_{mu,nu} D_{mu,nu} <mu| (r-o)_a (r-c)_b / |r-c|&#94;3 |nu> !>  for a given nucleus at `c` and gauge origin `o`, summing over the primitive !>  pairs of the contracted shell pair. The diamagnetic shielding tensor is then !>    sigma&#94;dia_{ts}(N) = (alpha&#94;2/2) [ delta_ts * (g_xx+g_yy+g_zz) - g_{s,t} ]. !>  The field factor (r-c) and the gauge-moment factor (r-o) are both inserted by !>  Cartesian index raising on the Rys nuclear-attraction kernel (the same !>  mechanism as der_helfey_xyz), reusing one extra bra order for the field and a !>  second for the (r-o) moment on the diagonal components. !> @param[in]       cp     shell pair data !> @param[in]       c      nucleus coordinates !> @param[in]       o      gauge origin !> @param[in]       den    density matrix block (i=bra, j=ket) !> @param[inout]    gdia   3x3 accumulator for the contracted integrals ! !> @author   Generated for NMR shielding (CGO) ! SUBROUTINE comp_nmr_dia_int1_prim ( cp , c , o , den , gdia ) TYPE ( shpair_t ), INTENT ( IN ) :: cp REAL ( REAL64 ), INTENT ( IN ) :: c ( 3 ), o ( 3 ) REAL ( REAL64 ), INTENT ( IN ) :: den (:,:) REAL ( REAL64 ), INTENT ( INOUT ) :: gdia ( 3 , 3 ) integer , parameter :: NRT = MAX_NROOTS + 3 type ( rys_root_t ) :: ryscomp REAL ( REAL64 ) :: xx , ww , tt , bb , dd ( 3 ), rji ( 3 ), ric ( 3 ), rio ( 3 ), fac INTEGER :: id , k , nr , ni , nj , a , b , m , kd ( 3 ) INTEGER :: i , j , ix , iy , iz , jx , jy , jz REAL ( REAL64 ) :: prod , accum ! Rys kernel: (ket, bra, coord, root); bra extended by 2 real ( real64 ) :: xyzin ( 0 : 2 * max_ang + 3 , 0 : max_ang + 2 , 3 , NRT ) ! field factor (r-c): bra extended by 1 real ( real64 ) :: fld ( 0 : max_ang , 0 : max_ang + 1 , 3 , NRT ) ! per-coord factors by kind: 0=plain,1=field,2=moment,3=moment*field real ( real64 ) :: facK ( 0 : max_ang , 0 : max_ang , 3 , 0 : 3 , NRT ) !dir$ assume_aligned xyzin : 64 ric = cp % ri (: 3 ) - c (: 3 ) rio = cp % ri (: 3 ) - o (: 3 ) rji = cp % rj (: 3 ) - cp % ri (: 3 ) DO id = 1 , cp % numpairs ASSOCIATE ( pp => cp % p ( id ), & iang => cp % iang , jang => cp % jang , & inao => cp % inao , jnao => cp % jnao ) nr = cp % nroots + 1 xx = pp % aa * sum (( pp % r - c ) ** 2 ) ryscomp % nroots = nr ryscomp % x = xx call ryscomp % evaluate () DO k = 1 , nr ww = ryscomp % w ( k ) * ryscomp % u ( k ) tt = ryscomp % u ( k ) / ( 1.0d0 + ryscomp % u ( k )) bb = 0.5d0 * ( 1.0d0 - tt ) / pp % aa dd = ( pp % r - cp % rj ) - tt * ( pp % r - c ) xyzin ( 0 , 0 , 1 , k ) = 1.0d0 xyzin ( 0 , 0 , 2 , k ) = 1.0d0 xyzin ( 0 , 0 , 3 , k ) = ww xyzin ( 1 , 0 , 1 , k ) = dd ( 1 ) xyzin ( 1 , 0 , 2 , k ) = dd ( 2 ) xyzin ( 1 , 0 , 3 , k ) = dd ( 3 ) * ww ! VRR (Lj+1,0) DO nj = 2 , ( iang + jang ) + 2 xyzin ( nj , 0 ,:, k ) = dd * xyzin ( nj - 1 , 0 ,:, k ) + ( nj - 1 ) * bb * xyzin ( nj - 2 , 0 ,:, k ) END DO ! HRR (Lj,Li+1), bra up to iang+2 nj = ( iang + jang ) + 2 DO ni = 1 , iang + 2 nj = nj - 1 xyzin ( 0 : nj , ni , 1 , k ) = xyzin ( 1 : nj + 1 , ni - 1 , 1 , k ) + rji ( 1 ) * xyzin ( 0 : nj , ni - 1 , 1 , k ) xyzin ( 0 : nj , ni , 2 , k ) = xyzin ( 1 : nj + 1 , ni - 1 , 2 , k ) + rji ( 2 ) * xyzin ( 0 : nj , ni - 1 , 2 , k ) xyzin ( 0 : nj , ni , 3 , k ) = xyzin ( 1 : nj + 1 , ni - 1 , 3 , k ) + rji ( 3 ) * xyzin ( 0 : nj , ni - 1 , 3 , k ) END DO ! field factor (r-c)_coord, bra 0:iang+1 DO m = 1 , 3 fld ( 0 : jang , 0 : iang + 1 , m , k ) = xyzin ( 0 : jang , 1 : iang + 2 , m , k ) & + ric ( m ) * xyzin ( 0 : jang , 0 : iang + 1 , m , k ) END DO ! per-coord factors, bra 0:iang DO m = 1 , 3 ! kind 0: plain facK ( 0 : jang , 0 : iang , m , 0 , k ) = xyzin ( 0 : jang , 0 : iang , m , k ) ! kind 1: field facK ( 0 : jang , 0 : iang , m , 1 , k ) = fld ( 0 : jang , 0 : iang , m , k ) ! kind 2: (r-o) moment of plain facK ( 0 : jang , 0 : iang , m , 2 , k ) = xyzin ( 0 : jang , 1 : iang + 1 , m , k ) & + rio ( m ) * xyzin ( 0 : jang , 0 : iang , m , k ) ! kind 3: (r-o) moment of field  = field with extra (r-o) raise facK ( 0 : jang , 0 : iang , m , 3 , k ) = fld ( 0 : jang , 1 : iang + 1 , m , k ) & + rio ( m ) * fld ( 0 : jang , 0 : iang , m , k ) END DO END DO fac = pp % expfac * TWOPI * 2.0d0 DO a = 1 , 3 DO b = 1 , 3 ! kind per coordinate for this (a,b) DO m = 1 , 3 if ( m == a . and . m == b ) then kd ( m ) = 3 else if ( m == a ) then kd ( m ) = 2 else if ( m == b ) then kd ( m ) = 1 else kd ( m ) = 0 end if END DO accum = 0.0d0 DO i = 1 , inao ix = CART_X ( i , iang ); iy = CART_Y ( i , iang ); iz = CART_Z ( i , iang ) DO j = 1 , jnao jx = CART_X ( j , jang ); jy = CART_Y ( j , jang ); jz = CART_Z ( j , jang ) prod = sum ( facK ( jx , ix , 1 , kd ( 1 ), 1 : nr ) & * facK ( jy , iy , 2 , kd ( 2 ), 1 : nr ) & * facK ( jz , iz , 3 , kd ( 3 ), 1 : nr ) ) accum = accum + den ( i , j ) * prod END DO END DO gdia ( a , b ) = gdia ( a , b ) + fac * accum END DO END DO END ASSOCIATE END DO END SUBROUTINE !> @brief Compute primitive block of PSO (paramagnetic spin-orbit) integrals !>        for one nucleus, all three components. !> @details Real antisymmetric matrix elements of the operator !>    A_a = [(r-c) x grad]_a / |r-c|&#94;3     (so the physical PSO operator is -i*A). !>  The field factor (r-c)/|r-c|&#94;3 is inserted by a der_helfey-style raise on the !>  Rys nuclear kernel (validated in the diamagnetic term); the grad factor is the !>  ket derivative 2*aj*S(ket+1) - n_ket*S(ket-1) (as in the angular momentum term). !>  Loops over the primitive pairs of the shell pair internally. !> @param[in]       cp     shell pair data !> @param[in]       c      nucleus coordinates !> @param[inout]    blk    block of PSO integrals (:,1:3) ! !> @author   Generated for NMR shielding (CGO) ! SUBROUTINE comp_pso_int1_prim ( cp , c , blk ) TYPE ( shpair_t ), INTENT ( IN ) :: cp REAL ( REAL64 ), INTENT ( IN ) :: c ( 3 ) REAL ( REAL64 ), CONTIGUOUS , INTENT ( INOUT ) :: blk (:,:) integer , parameter :: X__ = 1 , Y__ = 2 , Z__ = 3 integer , parameter :: NRT = MAX_NROOTS + 3 type ( rys_root_t ) :: ryscomp REAL ( REAL64 ) :: xx , ww , tt , bb , dd ( 3 ), rji ( 3 ), ric ( 3 ), fac , aj INTEGER :: id , k , nr , ni , nj , m INTEGER :: i , j , ix , iy , iz , jx , jy , jz , ij , jmax REAL ( REAL64 ) :: px , py , pz real ( real64 ) :: xyzin ( 0 : 2 * max_ang + 3 , 0 : max_ang + 2 , 3 , NRT ) real ( real64 ) :: fld ( 0 : max_ang , 0 : max_ang , 3 , NRT ) ! (ket,bra,coord,root) real ( real64 ) :: dkt ( 0 : max_ang , 0 : max_ang , 3 , NRT ) ! ket derivative !dir$ assume_aligned xyzin : 64 ric = cp % ri (: 3 ) - c (: 3 ) rji = cp % rj (: 3 ) - cp % ri (: 3 ) DO id = 1 , cp % numpairs ASSOCIATE ( pp => cp % p ( id ), & iang => cp % iang , jang => cp % jang , & inao => cp % inao , jnao => cp % jnao ) aj = pp % aj nr = cp % nroots + 1 xx = pp % aa * sum (( pp % r - c ) ** 2 ) ryscomp % nroots = nr ryscomp % x = xx call ryscomp % evaluate () DO k = 1 , nr ww = ryscomp % w ( k ) * ryscomp % u ( k ) tt = ryscomp % u ( k ) / ( 1.0d0 + ryscomp % u ( k )) bb = 0.5d0 * ( 1.0d0 - tt ) / pp % aa dd = ( pp % r - cp % rj ) - tt * ( pp % r - c ) xyzin ( 0 , 0 , 1 , k ) = 1.0d0 xyzin ( 0 , 0 , 2 , k ) = 1.0d0 xyzin ( 0 , 0 , 3 , k ) = ww xyzin ( 1 , 0 , 1 , k ) = dd ( 1 ) xyzin ( 1 , 0 , 2 , k ) = dd ( 2 ) xyzin ( 1 , 0 , 3 , k ) = dd ( 3 ) * ww DO nj = 2 , ( iang + jang ) + 2 xyzin ( nj , 0 ,:, k ) = dd * xyzin ( nj - 1 , 0 ,:, k ) + ( nj - 1 ) * bb * xyzin ( nj - 2 , 0 ,:, k ) END DO nj = ( iang + jang ) + 2 DO ni = 1 , iang + 1 nj = nj - 1 xyzin ( 0 : nj , ni , 1 , k ) = xyzin ( 1 : nj + 1 , ni - 1 , 1 , k ) + rji ( 1 ) * xyzin ( 0 : nj , ni - 1 , 1 , k ) xyzin ( 0 : nj , ni , 2 , k ) = xyzin ( 1 : nj + 1 , ni - 1 , 2 , k ) + rji ( 2 ) * xyzin ( 0 : nj , ni - 1 , 2 , k ) xyzin ( 0 : nj , ni , 3 , k ) = xyzin ( 1 : nj + 1 , ni - 1 , 3 , k ) + rji ( 3 ) * xyzin ( 0 : nj , ni - 1 , 3 , k ) END DO ! field factor (r-c)_coord, bra 0:iang DO m = 1 , 3 fld ( 0 : jang , 0 : iang , m , k ) = xyzin ( 0 : jang , 1 : iang + 1 , m , k ) & + ric ( m ) * xyzin ( 0 : jang , 0 : iang , m , k ) END DO ! ket derivative (2*aj*S(ket+1) - n_ket*S(ket-1)), ket 0:jang, bra 0:iang dkt ( 0 , 0 : iang , 1 : 3 , k ) = 2.0d0 * aj * xyzin ( 1 , 0 : iang , 1 : 3 , k ) DO nj = 1 , jang dkt ( nj , 0 : iang , 1 : 3 , k ) = 2.0d0 * aj * xyzin ( nj + 1 , 0 : iang , 1 : 3 , k ) & - nj * xyzin ( nj - 1 , 0 : iang , 1 : 3 , k ) END DO END DO ! The raw field+ket-derivative product carries a small spurious symmetric ! component for off-center nuclei. The full (non-packed) block is emitted ! here so the caller (pso_integrals) can antisymmetrise A=(M-M&#94;T)/2, which ! is exact for the anti-Hermitian PSO operator and removes that error. ! Hence NO iandj triangular packing below. fac = pp % expfac * TWOPI * 2.0d0 ij = 0 jmax = jnao DO i = 1 , inao ix = CART_X ( i , iang ); iy = CART_Y ( i , iang ); iz = CART_Z ( i , iang ) DO j = 1 , jmax jx = CART_X ( j , jang ); jy = CART_Y ( j , jang ); jz = CART_Z ( j , jang ) ij = ij + 1 ! PSO_x = P_x (fld_y dz - dy fld_z); etc (P=plain xyzin) px = sum ( xyzin ( jx , ix , 1 , 1 : nr ) * & ( fld ( jy , iy , 2 , 1 : nr ) * dkt ( jz , iz , 3 , 1 : nr ) & - dkt ( jy , iy , 2 , 1 : nr ) * fld ( jz , iz , 3 , 1 : nr ) ) ) py = sum ( xyzin ( jy , iy , 2 , 1 : nr ) * & ( fld ( jz , iz , 3 , 1 : nr ) * dkt ( jx , ix , 1 , 1 : nr ) & - dkt ( jz , iz , 3 , 1 : nr ) * fld ( jx , ix , 1 , 1 : nr ) ) ) pz = sum ( xyzin ( jz , iz , 3 , 1 : nr ) * & ( fld ( jx , ix , 1 , 1 : nr ) * dkt ( jy , iy , 2 , 1 : nr ) & - dkt ( jx , ix , 1 , 1 : nr ) * fld ( jy , iy , 2 , 1 : nr ) ) ) blk ( ij , X__ ) = blk ( ij , X__ ) + fac * px blk ( ij , Y__ ) = blk ( ij , Y__ ) + fac * py blk ( ij , Z__ ) = blk ( ij , Z__ ) + fac * pz END DO END DO END ASSOCIATE END DO END SUBROUTINE !> @brief Primitive GIAO a01gp gauge-correction integrals (9 components). !> @details a01gp = (g | nabla-rinv cross p |): the GIAO/London first-order !>  derivative of the PSO operator at nucleus c.  Returns !>    blk(ij,(a-1)*3+col) = (cvec x M&#94;{(col)})_a , !>  with cvec = R_bra - R_ket and M&#94;{(col)}_b = <mu|(r-R_bra)_b PSO_col|nu> !>  (the bra-position-weighted PSO, built by raising the bra angular momentum by !>  one in coordinate b, no center shift).  Full (both-triangle) block, no !>  packing.  The overall sign/scale is calibrated by the caller against the !>  libcint int1e_a01gp oracle. SUBROUTINE comp_giao_a01gp_prim ( cp , c , cvec , blk ) TYPE ( shpair_t ), INTENT ( IN ) :: cp REAL ( REAL64 ), INTENT ( IN ) :: c ( 3 ), cvec ( 3 ) REAL ( REAL64 ), CONTIGUOUS , INTENT ( INOUT ) :: blk (:,:) integer , parameter :: X__ = 1 , Y__ = 2 , Z__ = 3 integer , parameter :: NRT = MAX_NROOTS + 3 type ( rys_root_t ) :: ryscomp REAL ( REAL64 ) :: xx , ww , tt , bb , dd ( 3 ), rji ( 3 ), ric ( 3 ), fac , aj INTEGER :: id , k , nr , ni , nj , m , a , col INTEGER :: i , j , ix , iy , iz , jx , jy , jz , ij , jmax REAL ( REAL64 ) :: mm ( 3 , 3 ), pbase ( 3 ) ! M&#94;{(col)}_b : (b, col); base PSO real ( real64 ) :: xyzin ( 0 : 2 * max_ang + 3 , 0 : max_ang + 2 , 3 , NRT ) real ( real64 ) :: fld ( 0 : max_ang , 0 : max_ang + 1 , 3 , NRT ) ! (ket,bra,coord,root) real ( real64 ) :: dkt ( 0 : max_ang , 0 : max_ang + 1 , 3 , NRT ) ! ket derivative !dir$ assume_aligned xyzin : 64 ric = cp % ri (: 3 ) - c (: 3 ) rji = cp % rj (: 3 ) - cp % ri (: 3 ) DO id = 1 , cp % numpairs ASSOCIATE ( pp => cp % p ( id ), & iang => cp % iang , jang => cp % jang , & inao => cp % inao , jnao => cp % jnao ) aj = pp % aj ! One more Rys root than the PSO term: the extra bra-position raise ! (r-R_bra) increases the polynomial order by one. nr = cp % nroots + 2 xx = pp % aa * sum (( pp % r - c ) ** 2 ) ryscomp % nroots = nr ryscomp % x = xx call ryscomp % evaluate () DO k = 1 , nr ww = ryscomp % w ( k ) * ryscomp % u ( k ) tt = ryscomp % u ( k ) / ( 1.0d0 + ryscomp % u ( k )) bb = 0.5d0 * ( 1.0d0 - tt ) / pp % aa dd = ( pp % r - cp % rj ) - tt * ( pp % r - c ) xyzin ( 0 , 0 , 1 , k ) = 1.0d0 xyzin ( 0 , 0 , 2 , k ) = 1.0d0 xyzin ( 0 , 0 , 3 , k ) = ww xyzin ( 1 , 0 , 1 , k ) = dd ( 1 ) xyzin ( 1 , 0 , 2 , k ) = dd ( 2 ) xyzin ( 1 , 0 , 3 , k ) = dd ( 3 ) * ww DO nj = 2 , ( iang + jang ) + 3 xyzin ( nj , 0 ,:, k ) = dd * xyzin ( nj - 1 , 0 ,:, k ) + ( nj - 1 ) * bb * xyzin ( nj - 2 , 0 ,:, k ) END DO nj = ( iang + jang ) + 3 DO ni = 1 , iang + 2 nj = nj - 1 xyzin ( 0 : nj , ni , 1 , k ) = xyzin ( 1 : nj + 1 , ni - 1 , 1 , k ) + rji ( 1 ) * xyzin ( 0 : nj , ni - 1 , 1 , k ) xyzin ( 0 : nj , ni , 2 , k ) = xyzin ( 1 : nj + 1 , ni - 1 , 2 , k ) + rji ( 2 ) * xyzin ( 0 : nj , ni - 1 , 2 , k ) xyzin ( 0 : nj , ni , 3 , k ) = xyzin ( 1 : nj + 1 , ni - 1 , 3 , k ) + rji ( 3 ) * xyzin ( 0 : nj , ni - 1 , 3 , k ) END DO ! field factor (r-c)_coord, bra 0:iang+1 DO m = 1 , 3 fld ( 0 : jang , 0 : iang + 1 , m , k ) = xyzin ( 0 : jang , 1 : iang + 2 , m , k ) & + ric ( m ) * xyzin ( 0 : jang , 0 : iang + 1 , m , k ) END DO ! ket derivative, bra 0:iang+1 dkt ( 0 , 0 : iang + 1 , 1 : 3 , k ) = 2.0d0 * aj * xyzin ( 1 , 0 : iang + 1 , 1 : 3 , k ) DO nj = 1 , jang dkt ( nj , 0 : iang + 1 , 1 : 3 , k ) = 2.0d0 * aj * xyzin ( nj + 1 , 0 : iang + 1 , 1 : 3 , k ) & - nj * xyzin ( nj - 1 , 0 : iang + 1 , 1 : 3 , k ) END DO END DO fac = pp % expfac * TWOPI * 2.0d0 ij = 0 jmax = jnao DO i = 1 , inao ix = CART_X ( i , iang ); iy = CART_Y ( i , iang ); iz = CART_Z ( i , iang ) DO j = 1 , jmax jx = CART_X ( j , jang ); jy = CART_Y ( j , jang ); jz = CART_Z ( j , jang ) ij = ij + 1 ! M&#94;{(col)}_b : bra-position-weighted PSO (raise bra coord b by one). ! col=1 (PSO_x): mm ( 1 , 1 ) = sum ( xyzin ( jx , ix + 1 , 1 , 1 : nr ) * & ( fld ( jy , iy , 2 , 1 : nr ) * dkt ( jz , iz , 3 , 1 : nr ) - dkt ( jy , iy , 2 , 1 : nr ) * fld ( jz , iz , 3 , 1 : nr ) ) ) mm ( 2 , 1 ) = sum ( xyzin ( jx , ix , 1 , 1 : nr ) * & ( fld ( jy , iy + 1 , 2 , 1 : nr ) * dkt ( jz , iz , 3 , 1 : nr ) - dkt ( jy , iy + 1 , 2 , 1 : nr ) * fld ( jz , iz , 3 , 1 : nr ) ) ) mm ( 3 , 1 ) = sum ( xyzin ( jx , ix , 1 , 1 : nr ) * & ( fld ( jy , iy , 2 , 1 : nr ) * dkt ( jz , iz + 1 , 3 , 1 : nr ) - dkt ( jy , iy , 2 , 1 : nr ) * fld ( jz , iz + 1 , 3 , 1 : nr ) ) ) ! col=2 (PSO_y): mm ( 1 , 2 ) = sum ( xyzin ( jy , iy , 2 , 1 : nr ) * & ( fld ( jz , iz , 3 , 1 : nr ) * dkt ( jx , ix + 1 , 1 , 1 : nr ) - dkt ( jz , iz , 3 , 1 : nr ) * fld ( jx , ix + 1 , 1 , 1 : nr ) ) ) mm ( 2 , 2 ) = sum ( xyzin ( jy , iy + 1 , 2 , 1 : nr ) * & ( fld ( jz , iz , 3 , 1 : nr ) * dkt ( jx , ix , 1 , 1 : nr ) - dkt ( jz , iz , 3 , 1 : nr ) * fld ( jx , ix , 1 , 1 : nr ) ) ) mm ( 3 , 2 ) = sum ( xyzin ( jy , iy , 2 , 1 : nr ) * & ( fld ( jz , iz + 1 , 3 , 1 : nr ) * dkt ( jx , ix , 1 , 1 : nr ) - dkt ( jz , iz + 1 , 3 , 1 : nr ) * fld ( jx , ix , 1 , 1 : nr ) ) ) ! col=3 (PSO_z): mm ( 1 , 3 ) = sum ( xyzin ( jz , iz , 3 , 1 : nr ) * & ( fld ( jx , ix + 1 , 1 , 1 : nr ) * dkt ( jy , iy , 2 , 1 : nr ) - dkt ( jx , ix + 1 , 1 , 1 : nr ) * fld ( jy , iy , 2 , 1 : nr ) ) ) mm ( 2 , 3 ) = sum ( xyzin ( jz , iz , 3 , 1 : nr ) * & ( fld ( jx , ix , 1 , 1 : nr ) * dkt ( jy , iy + 1 , 2 , 1 : nr ) - dkt ( jx , ix , 1 , 1 : nr ) * fld ( jy , iy + 1 , 2 , 1 : nr ) ) ) mm ( 3 , 3 ) = sum ( xyzin ( jz , iz + 1 , 3 , 1 : nr ) * & ( fld ( jx , ix , 1 , 1 : nr ) * dkt ( jy , iy , 2 , 1 : nr ) - dkt ( jx , ix , 1 , 1 : nr ) * fld ( jy , iy , 2 , 1 : nr ) ) ) ! Base (un-raised) PSO components, to complete R0I = (r-R_bra) + R_bra, ! i.e. the position is referenced to the molecular origin (libcint ! convention), not the bra center.  M&#94;{(col)}_b += R_bra,b * PSO_col. pbase ( 1 ) = sum ( xyzin ( jx , ix , 1 , 1 : nr ) * & ( fld ( jy , iy , 2 , 1 : nr ) * dkt ( jz , iz , 3 , 1 : nr ) - dkt ( jy , iy , 2 , 1 : nr ) * fld ( jz , iz , 3 , 1 : nr ) ) ) pbase ( 2 ) = sum ( xyzin ( jy , iy , 2 , 1 : nr ) * & ( fld ( jz , iz , 3 , 1 : nr ) * dkt ( jx , ix , 1 , 1 : nr ) - dkt ( jz , iz , 3 , 1 : nr ) * fld ( jx , ix , 1 , 1 : nr ) ) ) pbase ( 3 ) = sum ( xyzin ( jz , iz , 3 , 1 : nr ) * & ( fld ( jx , ix , 1 , 1 : nr ) * dkt ( jy , iy , 2 , 1 : nr ) - dkt ( jx , ix , 1 , 1 : nr ) * fld ( jy , iy , 2 , 1 : nr ) ) ) do col = 1 , 3 mm ( 1 , col ) = mm ( 1 , col ) + cp % ri ( 1 ) * pbase ( col ) mm ( 2 , col ) = mm ( 2 , col ) + cp % ri ( 2 ) * pbase ( col ) mm ( 3 , col ) = mm ( 3 , col ) + cp % ri ( 3 ) * pbase ( col ) end do DO col = 1 , 3 blk ( ij ,( 1 - 1 ) * 3 + col ) = blk ( ij ,( 1 - 1 ) * 3 + col ) + & fac * ( cvec ( Y__ ) * mm ( Z__ , col ) - cvec ( Z__ ) * mm ( Y__ , col ) ) blk ( ij ,( 2 - 1 ) * 3 + col ) = blk ( ij ,( 2 - 1 ) * 3 + col ) + & fac * ( cvec ( Z__ ) * mm ( X__ , col ) - cvec ( X__ ) * mm ( Z__ , col ) ) blk ( ij ,( 3 - 1 ) * 3 + col ) = blk ( ij ,( 3 - 1 ) * 3 + col ) + & fac * ( cvec ( X__ ) * mm ( Y__ , col ) - cvec ( Y__ ) * mm ( X__ , col ) ) END DO END DO END DO END ASSOCIATE END DO END SUBROUTINE !> @brief Compute primitive block of multipole integrals of order `MOM` !> @param[in]       cp          shell pair data !> @param[in]       id          current pair of primitives !> @param[in]       r           point in space to compute integrals !> @param[in]       mom         multiplole moment order (1-dipole, 2-quadrupole, 3-octopole) !> @param[inout]    blk         block of 1e multipole moment integrals ! !> @author   Vladimir Mironov ! !     REVISION HISTORY: !> @date _Sep, 2018_ Initial release ! SUBROUTINE comp_mult_int1_prim ( cp , id , r , mom , blk ) !dir$ attributes inline :: comp_kin_ovl_int1_prim type ( shpair_t ), intent ( in ) :: cp integer , intent ( in ) :: id real ( real64 ), contiguous , intent ( in ) :: r (:) integer , intent ( in ) :: mom real ( real64 ), contiguous , intent ( inout ) :: blk (:,:) INTEGER :: i , j , nx , ny , nz , mx , my , mz , ij , jmax REAL ( REAL64 ) :: tmp ( 10 ) real ( real64 ) :: xyzmom ( 3 , 0 : 3 , 0 : max_ang , 0 : max_ang ) !dir$ assume_aligned sblk : 64 !dir$ assume_aligned tblk : 64 !dir$ assume_aligned xyzkin : 64 !dir$ assume_aligned xyzovl : 64 ASSOCIATE ( pp => cp % p ( id )) CALL multipole_xyz ( cp % ri , cp % rj , pp % r , pp % aa1 , cp % iang , cp % jang , r , mom , xyzmom ) ij = 0 jmax = cp % jnao DO i = 1 , cp % inao nx = CART_X ( i , cp % iang ) ny = CART_Y ( i , cp % iang ) nz = CART_Z ( i , cp % iang ) IF ( cp % iandj ) jmax = i DO j = 1 , jmax mx = CART_X ( j , cp % jang ) my = CART_Y ( j , cp % jang ) mz = CART_Z ( j , cp % jang ) ij = ij + 1 select case ( mom ) case ( 1 ) tmp ( X__ ) = xyzmom ( X__ , 1 , mx , nx ) * xyzmom ( Y__ , 0 , my , ny ) * xyzmom ( Z__ , 0 , mz , nz ) tmp ( Y__ ) = xyzmom ( X__ , 0 , mx , nx ) * xyzmom ( Y__ , 1 , my , ny ) * xyzmom ( Z__ , 0 , mz , nz ) tmp ( Z__ ) = xyzmom ( X__ , 0 , mx , nx ) * xyzmom ( Y__ , 0 , my , ny ) * xyzmom ( Z__ , 1 , mz , nz ) blk ( ij , X__ : Z__ ) = blk ( ij , X__ : Z__ ) + pp % expfac * tmp ( X__ : Z__ ) case ( 2 ) tmp ( XX_ ) = xyzmom ( X__ , 2 , mx , nx ) * xyzmom ( Y__ , 0 , my , ny ) * xyzmom ( Z__ , 0 , mz , nz ) tmp ( YY_ ) = xyzmom ( X__ , 0 , mx , nx ) * xyzmom ( Y__ , 2 , my , ny ) * xyzmom ( Z__ , 0 , mz , nz ) tmp ( ZZ_ ) = xyzmom ( X__ , 0 , mx , nx ) * xyzmom ( Y__ , 0 , my , ny ) * xyzmom ( Z__ , 2 , mz , nz ) tmp ( XY_ ) = xyzmom ( X__ , 1 , mx , nx ) * xyzmom ( Y__ , 1 , my , ny ) * xyzmom ( Z__ , 0 , mz , nz ) tmp ( XZ_ ) = xyzmom ( X__ , 1 , mx , nx ) * xyzmom ( Y__ , 0 , my , ny ) * xyzmom ( Z__ , 1 , mz , nz ) tmp ( YZ_ ) = xyzmom ( X__ , 0 , mx , nx ) * xyzmom ( Y__ , 1 , my , ny ) * xyzmom ( Z__ , 1 , mz , nz ) blk ( ij , XX_ : YZ_ ) = blk ( ij , XX_ : YZ_ ) + pp % expfac * tmp ( XX_ : YZ_ ) case ( 3 ) tmp ( XXX ) = xyzmom ( X__ , 3 , mx , nx ) * xyzmom ( Y__ , 0 , my , ny ) * xyzmom ( Z__ , 0 , mz , nz ) tmp ( YYY ) = xyzmom ( X__ , 0 , mx , nx ) * xyzmom ( Y__ , 3 , my , ny ) * xyzmom ( Z__ , 0 , mz , nz ) tmp ( ZZZ ) = xyzmom ( X__ , 0 , mx , nx ) * xyzmom ( Y__ , 0 , my , ny ) * xyzmom ( Z__ , 3 , mz , nz ) tmp ( XXY ) = xyzmom ( X__ , 2 , mx , nx ) * xyzmom ( Y__ , 1 , my , ny ) * xyzmom ( Z__ , 0 , mz , nz ) tmp ( XXZ ) = xyzmom ( X__ , 2 , mx , nx ) * xyzmom ( Y__ , 0 , my , ny ) * xyzmom ( Z__ , 1 , mz , nz ) tmp ( YYX ) = xyzmom ( X__ , 1 , mx , nx ) * xyzmom ( Y__ , 2 , my , ny ) * xyzmom ( Z__ , 0 , mz , nz ) tmp ( YYZ ) = xyzmom ( X__ , 0 , mx , nx ) * xyzmom ( Y__ , 2 , my , ny ) * xyzmom ( Z__ , 1 , mz , nz ) tmp ( ZZX ) = xyzmom ( X__ , 1 , mx , nx ) * xyzmom ( Y__ , 0 , my , ny ) * xyzmom ( Z__ , 2 , mz , nz ) tmp ( ZZY ) = xyzmom ( X__ , 0 , mx , nx ) * xyzmom ( Y__ , 1 , my , ny ) * xyzmom ( Z__ , 2 , mz , nz ) tmp ( XYZ ) = xyzmom ( X__ , 1 , mx , nx ) * xyzmom ( Y__ , 1 , my , ny ) * xyzmom ( Z__ , 1 , mz , nz ) blk ( ij , XXX : XYZ ) = blk ( ij , XXX : XYZ ) + pp % expfac * tmp ( XXX : XYZ ) case default error stop \"Max. order of multipole integrals is \" // MAX_EL_MOM_S end select END DO END DO END ASSOCIATE END SUBROUTINE !> @brief Compute primitive block of multipole !>        integrals up to an order `MXMOM` !> @param[in]       cp          shell pair data !> @param[in]       id          current pair of primitives !> @param[in]       r           point in space to compute integrals !> @param[in]       mxmom       multiplole moment order (1-dipole, 2-quadrupole, 3-octopole) !> @param[inout]    blk         block of 1e multipole moment integrals ! !> @author   Vladimir Mironov ! !     REVISION HISTORY: !> @date _Sep, 2018_ Initial release ! SUBROUTINE comp_allmult_int1_prim ( cp , id , r , mxmom , blk ) !dir$ attributes inline :: comp_kin_ovl_int1_prim type ( shpair_t ), intent ( in ) :: cp integer , intent ( in ) :: id real ( real64 ), contiguous , intent ( in ) :: r (:) integer , intent ( in ) :: mxmom real ( real64 ), contiguous , intent ( inout ) :: blk (:,:) integer , parameter :: & X__ = 1 , Y__ = 2 , Z__ = 3 integer , parameter :: & XX_ = 4 , YY_ = 5 , ZZ_ = 6 , & XY_ = 7 , YZ_ = 8 , XZ_ = 9 integer , parameter :: & XXX = 10 , YYY = 11 , ZZZ = 12 , & XXY = 13 , XXZ = 14 , & YYX = 15 , YYZ = 16 , & ZZX = 17 , ZZY = 18 , & XYZ = 19 integer , parameter :: BLKDIMS ( 3 ) = [ 3 , 3 + 6 , 3 + 6 + 10 ] INTEGER :: i , j , nx , ny , nz , mx , my , mz , ij , jmax , blkdim REAL ( REAL64 ) :: tmp ( 19 ) real ( real64 ) :: xyzmom ( 3 , 0 : 3 , 0 : max_ang , 0 : max_ang ) !dir$ assume_aligned sblk : 64 !dir$ assume_aligned tblk : 64 !dir$ assume_aligned xyzkin : 64 !dir$ assume_aligned xyzovl : 64 blkdim = blkdims ( mxmom ) ASSOCIATE ( pp => cp % p ( id )) CALL multipole_xyz ( cp % ri , cp % rj , pp % r , pp % aa1 , cp % iang , cp % jang , r , mxmom , xyzmom ) ij = 0 jmax = cp % jnao DO i = 1 , cp % inao nx = CART_X ( i , cp % iang ) ny = CART_Y ( i , cp % iang ) nz = CART_Z ( i , cp % iang ) IF ( cp % iandj ) jmax = i DO j = 1 , jmax mx = CART_X ( j , cp % jang ) my = CART_Y ( j , cp % jang ) mz = CART_Z ( j , cp % jang ) ij = ij + 1 tmp ( X__ ) = xyzmom ( X__ , 1 , mx , nx ) * xyzmom ( Y__ , 0 , my , ny ) * xyzmom ( Z__ , 0 , mz , nz ) tmp ( Y__ ) = xyzmom ( X__ , 0 , mx , nx ) * xyzmom ( Y__ , 1 , my , ny ) * xyzmom ( Z__ , 0 , mz , nz ) tmp ( Z__ ) = xyzmom ( X__ , 0 , mx , nx ) * xyzmom ( Y__ , 0 , my , ny ) * xyzmom ( Z__ , 1 , mz , nz ) if ( mxmom > 1 ) then tmp ( XX_ ) = xyzmom ( X__ , 2 , mx , nx ) * xyzmom ( Y__ , 0 , my , ny ) * xyzmom ( Z__ , 0 , mz , nz ) tmp ( YY_ ) = xyzmom ( X__ , 0 , mx , nx ) * xyzmom ( Y__ , 2 , my , ny ) * xyzmom ( Z__ , 0 , mz , nz ) tmp ( ZZ_ ) = xyzmom ( X__ , 0 , mx , nx ) * xyzmom ( Y__ , 0 , my , ny ) * xyzmom ( Z__ , 2 , mz , nz ) tmp ( XY_ ) = xyzmom ( X__ , 1 , mx , nx ) * xyzmom ( Y__ , 1 , my , ny ) * xyzmom ( Z__ , 0 , mz , nz ) tmp ( YZ_ ) = xyzmom ( X__ , 0 , mx , nx ) * xyzmom ( Y__ , 1 , my , ny ) * xyzmom ( Z__ , 1 , mz , nz ) tmp ( XZ_ ) = xyzmom ( X__ , 1 , mx , nx ) * xyzmom ( Y__ , 0 , my , ny ) * xyzmom ( Z__ , 1 , mz , nz ) end if if ( mxmom > 2 ) then tmp ( XXX ) = xyzmom ( X__ , 3 , mx , nx ) * xyzmom ( Y__ , 0 , my , ny ) * xyzmom ( Z__ , 0 , mz , nz ) tmp ( YYY ) = xyzmom ( X__ , 0 , mx , nx ) * xyzmom ( Y__ , 3 , my , ny ) * xyzmom ( Z__ , 0 , mz , nz ) tmp ( ZZZ ) = xyzmom ( X__ , 0 , mx , nx ) * xyzmom ( Y__ , 0 , my , ny ) * xyzmom ( Z__ , 3 , mz , nz ) tmp ( XXY ) = xyzmom ( X__ , 2 , mx , nx ) * xyzmom ( Y__ , 1 , my , ny ) * xyzmom ( Z__ , 0 , mz , nz ) tmp ( XXZ ) = xyzmom ( X__ , 2 , mx , nx ) * xyzmom ( Y__ , 0 , my , ny ) * xyzmom ( Z__ , 1 , mz , nz ) tmp ( YYX ) = xyzmom ( X__ , 1 , mx , nx ) * xyzmom ( Y__ , 2 , my , ny ) * xyzmom ( Z__ , 0 , mz , nz ) tmp ( YYZ ) = xyzmom ( X__ , 0 , mx , nx ) * xyzmom ( Y__ , 2 , my , ny ) * xyzmom ( Z__ , 1 , mz , nz ) tmp ( ZZX ) = xyzmom ( X__ , 1 , mx , nx ) * xyzmom ( Y__ , 0 , my , ny ) * xyzmom ( Z__ , 2 , mz , nz ) tmp ( ZZY ) = xyzmom ( X__ , 0 , mx , nx ) * xyzmom ( Y__ , 1 , my , ny ) * xyzmom ( Z__ , 2 , mz , nz ) tmp ( XYZ ) = xyzmom ( X__ , 1 , mx , nx ) * xyzmom ( Y__ , 1 , my , ny ) * xyzmom ( Z__ , 1 , mz , nz ) end if blk ( ij , 1 : blkdim ) = blk ( ij , 1 : blkdim ) + pp % expfac * tmp ( 1 : blkdim ) END DO END DO END ASSOCIATE END SUBROUTINE !-------------------------------------------------------------------------------- !       ONE-ELECTRON DERIVATIVES CALCULATION (PRIMITIVE GAUSSIANS) !-------------------------------------------------------------------------------- !> @brief Compute 1e overlap contribution to the gradient !> @param[in]       cp          shell pair data !> @param[in]       dij         density matrix block !> @param[inout]    de          dimension(3), contribution to gradient ! !> @author   Vladimir Mironov ! !     REVISION HISTORY: !> @date _Sep, 2018_ Initial release ! SUBROUTINE comp_overlap_der1 ( cp , dij , de ) !dir$ attributes inline :: comp_overlap_der1 TYPE ( shpair_t ), INTENT ( IN ) :: cp REAL ( REAL64 ), INTENT ( IN ) :: dij (:,:) REAL ( REAL64 ), CONTIGUOUS , INTENT ( INOUT ) :: de (:) REAL ( REAL64 ) :: der ( 3 ), de_loc ( 3 ) INTEGER :: i , j , k , ix , iy , iz , jx , jy , jz real ( real64 ) :: ovl_int ( 0 : max_ang , 0 : max_ang + 3 , 3 ) real ( real64 ) :: ovl_der ( 0 : max_ang , 0 : max_ang , 3 ) DO k = 1 , cp % numpairs ASSOCIATE ( pp => cp % p ( k ), & iang => cp % iang , jang => cp % jang , & inao => cp % inao , jnao => cp % jnao ) ! compute overlap [i+1|j] CALL overlap_xyz ( cp % ri , cp % rj , pp % r , pp % aa1 , iang + 1 , jang , ovl_int ) ! compute 1D overlap derivatives [i|j] CALL der_kinovl_xyz ( ovl_der , ovl_int , iang , jang , pp % ai ) ! assemble overlap contribution to the gradient de_loc = 0.0 DO i = 1 , inao ix = CART_X ( i , iang ) iy = CART_Y ( i , iang ) iz = CART_Z ( i , iang ) DO j = 1 , jnao jx = CART_X ( j , jang ) jy = CART_Y ( j , jang ) jz = CART_Z ( j , jang ) der ( 1 ) = ovl_der ( jx , ix , 1 ) * ovl_int ( jy , iy , 2 ) * ovl_int ( jz , iz , 3 ) der ( 2 ) = ovl_int ( jx , ix , 1 ) * ovl_der ( jy , iy , 2 ) * ovl_int ( jz , iz , 3 ) der ( 3 ) = ovl_int ( jx , ix , 1 ) * ovl_int ( jy , iy , 2 ) * ovl_der ( jz , iz , 3 ) de_loc = de_loc + der * dij ( i , j ) END DO END DO ! add scaled contribution to gradient de = de + de_loc * pp % expfac END ASSOCIATE END DO END SUBROUTINE !> @brief Bra-center first derivative of the overlap integral, returned as an !>   (inao, jnao, 3) block (NOT contracted with a density). Used to assemble the !>   AO derivative-overlap matrix dS/dR for the CPHF right-hand side. !> @param[in]    cp     shell pair data !> @param[inout] dblk   (inao, jnao, 3) accumulated bra-center derivatives SUBROUTINE comp_overlap_der1_block ( cp , dblk ) TYPE ( shpair_t ), INTENT ( IN ) :: cp REAL ( REAL64 ), CONTIGUOUS , INTENT ( INOUT ) :: dblk (:,:,:) INTEGER :: i , j , k , ix , iy , iz , jx , jy , jz real ( real64 ) :: ovl_int ( 0 : max_ang , 0 : max_ang + 3 , 3 ) real ( real64 ) :: ovl_der ( 0 : max_ang , 0 : max_ang , 3 ) DO k = 1 , cp % numpairs ASSOCIATE ( pp => cp % p ( k ), & iang => cp % iang , jang => cp % jang , & inao => cp % inao , jnao => cp % jnao ) CALL overlap_xyz ( cp % ri , cp % rj , pp % r , pp % aa1 , iang + 1 , jang , ovl_int ) CALL der_kinovl_xyz ( ovl_der , ovl_int , iang , jang , pp % ai ) DO i = 1 , inao ix = CART_X ( i , iang ); iy = CART_Y ( i , iang ); iz = CART_Z ( i , iang ) DO j = 1 , jnao jx = CART_X ( j , jang ); jy = CART_Y ( j , jang ); jz = CART_Z ( j , jang ) dblk ( i , j , 1 ) = dblk ( i , j , 1 ) + ovl_der ( jx , ix , 1 ) * ovl_int ( jy , iy , 2 ) * ovl_int ( jz , iz , 3 ) * pp % expfac dblk ( i , j , 2 ) = dblk ( i , j , 2 ) + ovl_int ( jx , ix , 1 ) * ovl_der ( jy , iy , 2 ) * ovl_int ( jz , iz , 3 ) * pp % expfac dblk ( i , j , 3 ) = dblk ( i , j , 3 ) + ovl_int ( jx , ix , 1 ) * ovl_int ( jy , iy , 2 ) * ovl_der ( jz , iz , 3 ) * pp % expfac END DO END DO END ASSOCIATE END DO END SUBROUTINE !> @brief Compute 1e kinetic contribution to the gradient !> @param[in]       cp          shell pair data !> @param[in]       dij         density matrix block !> @param[inout]    de          dimension(3), contribution to gradient ! !> @author   Vladimir Mironov ! !     REVISION HISTORY: !> @date _Sep, 2018_ Initial release ! SUBROUTINE comp_kinetic_der1 ( cp , dij , de ) !dir$ attributes inline :: comp_kinetic_der1 TYPE ( shpair_t ), INTENT ( IN ) :: cp REAL ( REAL64 ), INTENT ( IN ) :: dij (:,:) REAL ( REAL64 ), CONTIGUOUS , INTENT ( INOUT ) :: de (:) REAL ( REAL64 ) :: der ( 3 ), de_loc ( 3 ) INTEGER :: i , j , k , ix , iy , iz , jx , jy , jz real ( real64 ) :: ovl_int ( 0 : max_ang , 0 : max_ang + 3 , 3 ) real ( real64 ) :: ovl_der ( 0 : max_ang , 0 : max_ang , 3 ) real ( real64 ) :: kin_int ( 0 : max_ang , 0 : max_ang + 1 , 3 ) real ( real64 ) :: kin_der ( 0 : max_ang , 0 : max_ang , 3 ) DO k = 1 , cp % numpairs ASSOCIATE ( pp => cp % p ( k ), & iang => cp % iang , jang => cp % jang , & inao => cp % inao , jnao => cp % jnao ) ! compute overlap [i+3|j] CALL overlap_xyz ( cp % ri , cp % rj , pp % r , pp % aa1 , iang + 3 , jang , ovl_int ) ! compute 1D kinetic [i+1|j] CALL kinetic_xyz_i ( kin_int , ovl_int , iang + 1 , jang , pp % ai ) ! compute 1D overlap derivatives [i|j] CALL der_kinovl_xyz ( ovl_der , ovl_int , iang , jang , pp % ai ) ! compute 1D kinetic derivatives [i|j] CALL der_kinovl_xyz ( kin_der , kin_int , iang , jang , pp % ai ) ! assemble 3D K.E. derivatives from 1D integrals and derivatives de_loc = 0.0 DO i = 1 , inao ix = CART_X ( i , iang ) iy = CART_Y ( i , iang ) iz = CART_Z ( i , iang ) DO j = 1 , jnao jx = CART_X ( j , jang ) jy = CART_Y ( j , jang ) jz = CART_Z ( j , jang ) der ( 1 ) = kin_der ( jx , ix , 1 ) * ovl_int ( jy , iy , 2 ) * ovl_int ( jz , iz , 3 ) + & ovl_der ( jx , ix , 1 ) * kin_int ( jy , iy , 2 ) * ovl_int ( jz , iz , 3 ) + & ovl_der ( jx , ix , 1 ) * ovl_int ( jy , iy , 2 ) * kin_int ( jz , iz , 3 ) der ( 2 ) = kin_int ( jx , ix , 1 ) * ovl_der ( jy , iy , 2 ) * ovl_int ( jz , iz , 3 ) + & ovl_int ( jx , ix , 1 ) * kin_der ( jy , iy , 2 ) * ovl_int ( jz , iz , 3 ) + & ovl_int ( jx , ix , 1 ) * ovl_der ( jy , iy , 2 ) * kin_int ( jz , iz , 3 ) der ( 3 ) = kin_int ( jx , ix , 1 ) * ovl_int ( jy , iy , 2 ) * ovl_der ( jz , iz , 3 ) + & ovl_int ( jx , ix , 1 ) * kin_int ( jy , iy , 2 ) * ovl_der ( jz , iz , 3 ) + & ovl_int ( jx , ix , 1 ) * ovl_int ( jy , iy , 2 ) * kin_der ( jz , iz , 3 ) de_loc = de_loc + der * dij ( i , j ) END DO END DO ! add scaled contribution to gradient de = de + de_loc * pp % expfac END ASSOCIATE END DO END SUBROUTINE !> @brief Bra-center first derivative of the kinetic-energy integral, returned as !>   an (inao, jnao, 3) block (not contracted), for the dT/dR matrix used in the !>   CPHF right-hand side. Mirrors comp_kinetic_der1. SUBROUTINE comp_kinetic_der1_block ( cp , dblk ) TYPE ( shpair_t ), INTENT ( IN ) :: cp REAL ( REAL64 ), CONTIGUOUS , INTENT ( INOUT ) :: dblk (:,:,:) INTEGER :: i , j , k , ix , iy , iz , jx , jy , jz real ( real64 ) :: ovl_int ( 0 : max_ang , 0 : max_ang + 3 , 3 ) real ( real64 ) :: ovl_der ( 0 : max_ang , 0 : max_ang , 3 ) real ( real64 ) :: kin_int ( 0 : max_ang , 0 : max_ang + 1 , 3 ) real ( real64 ) :: kin_der ( 0 : max_ang , 0 : max_ang , 3 ) DO k = 1 , cp % numpairs ASSOCIATE ( pp => cp % p ( k ), & iang => cp % iang , jang => cp % jang , & inao => cp % inao , jnao => cp % jnao ) CALL overlap_xyz ( cp % ri , cp % rj , pp % r , pp % aa1 , iang + 3 , jang , ovl_int ) CALL kinetic_xyz_i ( kin_int , ovl_int , iang + 1 , jang , pp % ai ) CALL der_kinovl_xyz ( ovl_der , ovl_int , iang , jang , pp % ai ) CALL der_kinovl_xyz ( kin_der , kin_int , iang , jang , pp % ai ) DO i = 1 , inao ix = CART_X ( i , iang ); iy = CART_Y ( i , iang ); iz = CART_Z ( i , iang ) DO j = 1 , jnao jx = CART_X ( j , jang ); jy = CART_Y ( j , jang ); jz = CART_Z ( j , jang ) dblk ( i , j , 1 ) = dblk ( i , j , 1 ) + ( & kin_der ( jx , ix , 1 ) * ovl_int ( jy , iy , 2 ) * ovl_int ( jz , iz , 3 ) + & ovl_der ( jx , ix , 1 ) * kin_int ( jy , iy , 2 ) * ovl_int ( jz , iz , 3 ) + & ovl_der ( jx , ix , 1 ) * ovl_int ( jy , iy , 2 ) * kin_int ( jz , iz , 3 ) ) * pp % expfac dblk ( i , j , 2 ) = dblk ( i , j , 2 ) + ( & kin_int ( jx , ix , 1 ) * ovl_der ( jy , iy , 2 ) * ovl_int ( jz , iz , 3 ) + & ovl_int ( jx , ix , 1 ) * kin_der ( jy , iy , 2 ) * ovl_int ( jz , iz , 3 ) + & ovl_int ( jx , ix , 1 ) * ovl_der ( jy , iy , 2 ) * kin_int ( jz , iz , 3 ) ) * pp % expfac dblk ( i , j , 3 ) = dblk ( i , j , 3 ) + ( & kin_int ( jx , ix , 1 ) * ovl_int ( jy , iy , 2 ) * ovl_der ( jz , iz , 3 ) + & ovl_int ( jx , ix , 1 ) * kin_int ( jy , iy , 2 ) * ovl_der ( jz , iz , 3 ) + & ovl_int ( jx , ix , 1 ) * ovl_int ( jy , iy , 2 ) * kin_der ( jz , iz , 3 ) ) * pp % expfac END DO END DO END ASSOCIATE END DO END SUBROUTINE !> @brief Bra-center second derivative of the 1e overlap contribution. !> @details Accumulates the symmetric 3x3 block of second derivatives of !>  sum_ij dij*S_ij with respect to the bra (center i) Cartesian coordinates, !>  i.e. d2/dA_a dA_b. The full Hessian's other blocks (A-B, B-B) follow from !>  translational invariance of the two-center integral. !> @param[in]    cp    shell pair data !> @param[in]    dij   density (or energy-weighted density) matrix block !> @param[inout] de2   dimension(3,3), accumulated bra-center 2nd derivatives SUBROUTINE comp_overlap_der2 ( cp , dij , de2 ) !dir$ attributes inline :: comp_overlap_der2 TYPE ( shpair_t ), INTENT ( IN ) :: cp REAL ( REAL64 ), INTENT ( IN ) :: dij (:,:) REAL ( REAL64 ), CONTIGUOUS , INTENT ( INOUT ) :: de2 (:,:) REAL ( REAL64 ) :: de_loc ( 3 , 3 ), w REAL ( REAL64 ) :: sx , sy , sz , dx , dy , dz , d2x , d2y , d2z INTEGER :: i , j , k , ix , iy , iz , jx , jy , jz real ( real64 ) :: ovl_int ( 0 : max_ang , 0 : max_ang + 4 , 3 ) real ( real64 ) :: ovl_der ( 0 : max_ang , 0 : max_ang , 3 ) real ( real64 ) :: ovl_der2 ( 0 : max_ang , 0 : max_ang , 3 ) DO k = 1 , cp % numpairs ASSOCIATE ( pp => cp % p ( k ), & iang => cp % iang , jang => cp % jang , & inao => cp % inao , jnao => cp % jnao ) ! compute overlap [i+2|j] CALL overlap_xyz ( cp % ri , cp % rj , pp % r , pp % aa1 , iang + 2 , jang , ovl_int ) ! compute 1D overlap 1st and 2nd derivatives [i|j] CALL der_kinovl_xyz ( ovl_der , ovl_int , iang , jang , pp % ai ) CALL der2_kinovl_xyz ( ovl_der2 , ovl_int , iang , jang , pp % ai ) de_loc = 0.0 DO i = 1 , inao ix = CART_X ( i , iang ) iy = CART_Y ( i , iang ) iz = CART_Z ( i , iang ) DO j = 1 , jnao jx = CART_X ( j , jang ) jy = CART_Y ( j , jang ) jz = CART_Z ( j , jang ) sx = ovl_int ( jx , ix , 1 ); sy = ovl_int ( jy , iy , 2 ); sz = ovl_int ( jz , iz , 3 ) dx = ovl_der ( jx , ix , 1 ); dy = ovl_der ( jy , iy , 2 ); dz = ovl_der ( jz , iz , 3 ) d2x = ovl_der2 ( jx , ix , 1 ); d2y = ovl_der2 ( jy , iy , 2 ); d2z = ovl_der2 ( jz , iz , 3 ) w = dij ( i , j ) de_loc ( 1 , 1 ) = de_loc ( 1 , 1 ) + w * d2x * sy * sz de_loc ( 2 , 2 ) = de_loc ( 2 , 2 ) + w * sx * d2y * sz de_loc ( 3 , 3 ) = de_loc ( 3 , 3 ) + w * sx * sy * d2z de_loc ( 2 , 1 ) = de_loc ( 2 , 1 ) + w * dx * dy * sz de_loc ( 3 , 1 ) = de_loc ( 3 , 1 ) + w * dx * sy * dz de_loc ( 3 , 2 ) = de_loc ( 3 , 2 ) + w * sx * dy * dz END DO END DO de2 ( 1 , 1 ) = de2 ( 1 , 1 ) + de_loc ( 1 , 1 ) * pp % expfac de2 ( 2 , 2 ) = de2 ( 2 , 2 ) + de_loc ( 2 , 2 ) * pp % expfac de2 ( 3 , 3 ) = de2 ( 3 , 3 ) + de_loc ( 3 , 3 ) * pp % expfac de2 ( 2 , 1 ) = de2 ( 2 , 1 ) + de_loc ( 2 , 1 ) * pp % expfac de2 ( 1 , 2 ) = de2 ( 1 , 2 ) + de_loc ( 2 , 1 ) * pp % expfac de2 ( 3 , 1 ) = de2 ( 3 , 1 ) + de_loc ( 3 , 1 ) * pp % expfac de2 ( 1 , 3 ) = de2 ( 1 , 3 ) + de_loc ( 3 , 1 ) * pp % expfac de2 ( 3 , 2 ) = de2 ( 3 , 2 ) + de_loc ( 3 , 2 ) * pp % expfac de2 ( 2 , 3 ) = de2 ( 2 , 3 ) + de_loc ( 3 , 2 ) * pp % expfac END ASSOCIATE END DO END SUBROUTINE !> @brief Bra-center second derivative of the 1e kinetic-energy contribution. !> @details Accumulates the symmetric 3x3 block d2/dA_a dA_b of !>  sum_ij dij*T_ij. As with comp_kinetic_der1, the kinetic operator factorizes !>  across the three Cartesian directions as T = Tx*Sy*Sz + Sx*Ty*Sz + Sx*Sy*Tz. !> @param[in]    cp    shell pair data !> @param[in]    dij   density (or energy-weighted density) matrix block !> @param[inout] de2   dimension(3,3), accumulated bra-center 2nd derivatives SUBROUTINE comp_kinetic_der2 ( cp , dij , de2 ) !dir$ attributes inline :: comp_kinetic_der2 TYPE ( shpair_t ), INTENT ( IN ) :: cp REAL ( REAL64 ), INTENT ( IN ) :: dij (:,:) REAL ( REAL64 ), CONTIGUOUS , INTENT ( INOUT ) :: de2 (:,:) REAL ( REAL64 ) :: de_loc ( 3 , 3 ), w REAL ( REAL64 ) :: sx , sy , sz , dsx , dsy , dsz , d2sx , d2sy , d2sz REAL ( REAL64 ) :: tx , ty , tz , dtx , dty , dtz , d2tx , d2ty , d2tz INTEGER :: i , j , k , ix , iy , iz , jx , jy , jz real ( real64 ) :: ovl_int ( 0 : max_ang , 0 : max_ang + 4 , 3 ) real ( real64 ) :: ovl_der ( 0 : max_ang , 0 : max_ang , 3 ) real ( real64 ) :: ovl_der2 ( 0 : max_ang , 0 : max_ang , 3 ) real ( real64 ) :: kin_int ( 0 : max_ang , 0 : max_ang + 2 , 3 ) real ( real64 ) :: kin_der ( 0 : max_ang , 0 : max_ang , 3 ) real ( real64 ) :: kin_der2 ( 0 : max_ang , 0 : max_ang , 3 ) DO k = 1 , cp % numpairs ASSOCIATE ( pp => cp % p ( k ), & iang => cp % iang , jang => cp % jang , & inao => cp % inao , jnao => cp % jnao ) ! compute overlap [i+4|j] CALL overlap_xyz ( cp % ri , cp % rj , pp % r , pp % aa1 , iang + 4 , jang , ovl_int ) ! compute 1D kinetic [i+2|j] CALL kinetic_xyz_i ( kin_int , ovl_int , iang + 2 , jang , pp % ai ) ! 1st and 2nd bra-center derivatives of 1D overlap and kinetic CALL der_kinovl_xyz ( ovl_der , ovl_int , iang , jang , pp % ai ) CALL der2_kinovl_xyz ( ovl_der2 , ovl_int , iang , jang , pp % ai ) CALL der_kinovl_xyz ( kin_der , kin_int , iang , jang , pp % ai ) CALL der2_kinovl_xyz ( kin_der2 , kin_int , iang , jang , pp % ai ) de_loc = 0.0 DO i = 1 , inao ix = CART_X ( i , iang ) iy = CART_Y ( i , iang ) iz = CART_Z ( i , iang ) DO j = 1 , jnao jx = CART_X ( j , jang ) jy = CART_Y ( j , jang ) jz = CART_Z ( j , jang ) sx = ovl_int ( jx , ix , 1 ); sy = ovl_int ( jy , iy , 2 ); sz = ovl_int ( jz , iz , 3 ) dsx = ovl_der ( jx , ix , 1 ); dsy = ovl_der ( jy , iy , 2 ); dsz = ovl_der ( jz , iz , 3 ) d2sx = ovl_der2 ( jx , ix , 1 ); d2sy = ovl_der2 ( jy , iy , 2 ); d2sz = ovl_der2 ( jz , iz , 3 ) tx = kin_int ( jx , ix , 1 ); ty = kin_int ( jy , iy , 2 ); tz = kin_int ( jz , iz , 3 ) dtx = kin_der ( jx , ix , 1 ); dty = kin_der ( jy , iy , 2 ); dtz = kin_der ( jz , iz , 3 ) d2tx = kin_der2 ( jx , ix , 1 ); d2ty = kin_der2 ( jy , iy , 2 ); d2tz = kin_der2 ( jz , iz , 3 ) w = dij ( i , j ) ! diagonal: d2/dA_a&#94;2 of (Tx Sy Sz + Sx Ty Sz + Sx Sy Tz) de_loc ( 1 , 1 ) = de_loc ( 1 , 1 ) + w * ( d2tx * sy * sz + d2sx * ty * sz + d2sx * sy * tz ) de_loc ( 2 , 2 ) = de_loc ( 2 , 2 ) + w * ( tx * d2sy * sz + sx * d2ty * sz + sx * d2sy * tz ) de_loc ( 3 , 3 ) = de_loc ( 3 , 3 ) + w * ( tx * sy * d2sz + sx * ty * d2sz + sx * sy * d2tz ) ! off-diagonal: d2/dA_a dA_b de_loc ( 2 , 1 ) = de_loc ( 2 , 1 ) + w * ( dtx * dsy * sz + dsx * dty * sz + dsx * dsy * tz ) de_loc ( 3 , 1 ) = de_loc ( 3 , 1 ) + w * ( dtx * sy * dsz + dsx * ty * dsz + dsx * sy * dtz ) de_loc ( 3 , 2 ) = de_loc ( 3 , 2 ) + w * ( tx * dsy * dsz + sx * dty * dsz + sx * dsy * dtz ) END DO END DO de2 ( 1 , 1 ) = de2 ( 1 , 1 ) + de_loc ( 1 , 1 ) * pp % expfac de2 ( 2 , 2 ) = de2 ( 2 , 2 ) + de_loc ( 2 , 2 ) * pp % expfac de2 ( 3 , 3 ) = de2 ( 3 , 3 ) + de_loc ( 3 , 3 ) * pp % expfac de2 ( 2 , 1 ) = de2 ( 2 , 1 ) + de_loc ( 2 , 1 ) * pp % expfac de2 ( 1 , 2 ) = de2 ( 1 , 2 ) + de_loc ( 2 , 1 ) * pp % expfac de2 ( 3 , 1 ) = de2 ( 3 , 1 ) + de_loc ( 3 , 1 ) * pp % expfac de2 ( 1 , 3 ) = de2 ( 1 , 3 ) + de_loc ( 3 , 1 ) * pp % expfac de2 ( 3 , 2 ) = de2 ( 3 , 2 ) + de_loc ( 3 , 2 ) * pp % expfac de2 ( 2 , 3 ) = de2 ( 2 , 3 ) + de_loc ( 3 , 2 ) * pp % expfac END ASSOCIATE END DO END SUBROUTINE !> @brief Compute 1e Coulomb contribution to the gradient (v.r.t. shifts of !>  shell's centers) !> @param[in]       nroots      roots for GaussRys !> @param[in]       cp          shell pair data !> @param[in]       c           coordinates of the charged particle !> @param[in]       znuc        particle charge !> @param[in]       dij         density matrix block !> @param[inout]    dernuc      dimension(3), contribution to gradient ! !> @author   Vladimir Mironov ! !     REVISION HISTORY: !> @date _Sep, 2018_ Initial release ! SUBROUTINE comp_coulomb_der1 ( cp , c , znuc , dij , dernuc ) !dir$ attributes inline :: comp_coulomb_der1 TYPE ( shpair_t ), INTENT ( IN ) :: cp REAL ( REAL64 ), INTENT ( IN ) :: c ( 3 ), znuc REAL ( REAL64 ), INTENT ( IN ) :: dij (:,:) REAL ( REAL64 ), INTENT ( OUT ) :: dernuc ( 3 ) REAL ( REAL64 ) :: xx type ( rys_root_t ) :: ryscomp REAL ( REAL64 ) :: der ( 3 ), fac , detmp ( 3 ) INTEGER :: id , i , j , ix , iy , iz , jx , jy , jz real ( real64 ) :: xyzin ( 0 : 2 * max_ang + 1 , 0 : max_ang + 1 , 3 , max_nroots ) real ( real64 ) :: dxyzc ( 0 : max_ang_pad , 0 : max_ang , 3 , max_nroots ) !dir$ assume_aligned xyzin : 64 !dir$ assume_aligned dxyzc : 64 dernuc = 0.0 DO id = 1 , cp % numpairs ASSOCIATE ( pp => cp % p ( id ), & iang => cp % iang , jang => cp % jang , & inao => cp % inao , jnao => cp % jnao ) xx = pp % aa * sum (( pp % r - c ) ** 2 ) ryscomp % nroots = cp % nroots ryscomp % x = xx CALL QGaussRys ( ryscomp , cp , id , c , znuc , xyzin , 1 ) CALL der_coul_xyz ( dxyzc , xyzin , iang , jang , pp % ai , cp % nroots ) fac = pp % expfac * TWOPI * pp % aa1 detmp = 0.0 DO i = 1 , inao ix = CART_X ( i , iang ) iy = CART_Y ( i , iang ) iz = CART_Z ( i , iang ) DO j = 1 , jnao jx = CART_X ( j , jang ) jy = CART_Y ( j , jang ) jz = CART_Z ( j , jang ) der ( 1 ) = sum ( dxyzc ( jx , ix , 1 , 1 : cp % nroots )& * xyzin ( jy , iy , 2 , 1 : cp % nroots )& * xyzin ( jz , iz , 3 , 1 : cp % nroots ) ) der ( 2 ) = sum ( xyzin ( jx , ix , 1 , 1 : cp % nroots )& * dxyzc ( jy , iy , 2 , 1 : cp % nroots )& * xyzin ( jz , iz , 3 , 1 : cp % nroots ) ) der ( 3 ) = sum ( xyzin ( jx , ix , 1 , 1 : cp % nroots )& * xyzin ( jy , iy , 2 , 1 : cp % nroots )& * dxyzc ( jz , iz , 3 , 1 : cp % nroots ) ) detmp = detmp + der * dij ( i , j ) END DO END DO dernuc = dernuc + detmp * fac END ASSOCIATE END DO END SUBROUTINE !> @brief Compute 1e Hellmann-Feynman contribution to the gradient !> @param[in]       nroots      roots for GaussRys !> @param[in]       cp          shell pair data !> @param[in]       c           coordinates of the charged particle !> @param[in]       znuc        particle charge !> @param[in]       dij         density matrix block !> @param[inout]    derhf       dimension(3), contribution to gradient ! !> @author   Vladimir Mironov ! !     REVISION HISTORY: !> @date _Sep, 2018_ Initial release ! SUBROUTINE comp_coulomb_helfeyder1 ( cp , c , znuc , dij , derhf ) !dir$ attributes inline :: comp_coulomb_helfeyder1 TYPE ( shpair_t ), INTENT ( IN ) :: cp REAL ( REAL64 ), INTENT ( IN ) :: c ( 3 ), znuc REAL ( REAL64 ), INTENT ( IN ) :: dij (:,:) REAL ( REAL64 ), CONTIGUOUS , INTENT ( OUT ) :: derhf (:) REAL ( REAL64 ) :: xx type ( rys_root_t ) :: ryscomp REAL ( REAL64 ) :: ric ( 3 ) REAL ( REAL64 ) :: der ( 3 ), fac INTEGER :: id , i , j , ix , iy , iz , jx , jy , jz real ( real64 ) :: xyzin ( 0 : 2 * max_ang + 1 , 0 : max_ang + 1 , 3 , max_nroots ) real ( real64 ) :: dxyzc ( 0 : max_ang_pad , 0 : max_ang , 3 , max_nroots ) !dir$ assume_aligned xyzin : 64 !dir$ assume_aligned dxyzc : 64 derhf = 0.0 ric = cp % ri (: 3 ) - c (: 3 ) DO id = 1 , cp % numpairs ASSOCIATE ( pp => cp % p ( id ), & iang => cp % iang , jang => cp % jang , & inao => cp % inao , jnao => cp % jnao ) xx = pp % aa * sum (( pp % r - c ) ** 2 ) fac = pp % expfac * TWOPI * 2 ryscomp % nroots = cp % nroots ryscomp % x = xx CALL DQGaussRys ( ryscomp , cp , id , c , znuc , xyzin ) CALL der_helfey_xyz ( dxyzc , xyzin , iang , jang , ric , cp % nroots ) DO i = 1 , inao ix = CART_X ( i , iang ) iy = CART_Y ( i , iang ) iz = CART_Z ( i , iang ) DO j = 1 , jnao jx = CART_X ( j , jang ) jy = CART_Y ( j , jang ) jz = CART_Z ( j , jang ) der ( 1 ) = sum ( dxyzc ( jx , ix , 1 , 1 : cp % nroots )& * xyzin ( jy , iy , 2 , 1 : cp % nroots )& * xyzin ( jz , iz , 3 , 1 : cp % nroots )) der ( 2 ) = sum ( xyzin ( jx , ix , 1 , 1 : cp % nroots )& * dxyzc ( jy , iy , 2 , 1 : cp % nroots )& * xyzin ( jz , iz , 3 , 1 : cp % nroots )) der ( 3 ) = sum ( xyzin ( jx , ix , 1 , 1 : cp % nroots )& * xyzin ( jy , iy , 2 , 1 : cp % nroots )& * dxyzc ( jz , iz , 3 , 1 : cp % nroots )) derhf = derhf + der * dij ( i , j ) * fac END DO END DO END ASSOCIATE END DO END SUBROUTINE !> @brief Bra-center first derivative of the nuclear-attraction integral for one !>   charge, returned as an (inao, jnao, 3) block (not contracted). Mirrors !>   comp_coulomb_der1; used to assemble the dV/dR matrix for the CPHF RHS. SUBROUTINE comp_coulomb_der1_block ( cp , c , znuc , dblk ) TYPE ( shpair_t ), INTENT ( IN ) :: cp REAL ( REAL64 ), INTENT ( IN ) :: c ( 3 ), znuc REAL ( REAL64 ), CONTIGUOUS , INTENT ( INOUT ) :: dblk (:,:,:) REAL ( REAL64 ) :: xx , fac , der ( 3 ) type ( rys_root_t ) :: ryscomp INTEGER :: id , i , j , ix , iy , iz , jx , jy , jz real ( real64 ) :: xyzin ( 0 : 2 * max_ang + 1 , 0 : max_ang + 1 , 3 , max_nroots ) real ( real64 ) :: dxyzc ( 0 : max_ang_pad , 0 : max_ang , 3 , max_nroots ) DO id = 1 , cp % numpairs ASSOCIATE ( pp => cp % p ( id ), iang => cp % iang , jang => cp % jang , & inao => cp % inao , jnao => cp % jnao ) xx = pp % aa * sum (( pp % r - c ) ** 2 ) ryscomp % nroots = cp % nroots ryscomp % x = xx CALL QGaussRys ( ryscomp , cp , id , c , znuc , xyzin , 1 ) CALL der_coul_xyz ( dxyzc , xyzin , iang , jang , pp % ai , cp % nroots ) fac = pp % expfac * TWOPI * pp % aa1 DO i = 1 , inao ix = CART_X ( i , iang ); iy = CART_Y ( i , iang ); iz = CART_Z ( i , iang ) DO j = 1 , jnao jx = CART_X ( j , jang ); jy = CART_Y ( j , jang ); jz = CART_Z ( j , jang ) der ( 1 ) = sum ( dxyzc ( jx , ix , 1 , 1 : cp % nroots ) * xyzin ( jy , iy , 2 , 1 : cp % nroots ) * xyzin ( jz , iz , 3 , 1 : cp % nroots )) der ( 2 ) = sum ( xyzin ( jx , ix , 1 , 1 : cp % nroots ) * dxyzc ( jy , iy , 2 , 1 : cp % nroots ) * xyzin ( jz , iz , 3 , 1 : cp % nroots )) der ( 3 ) = sum ( xyzin ( jx , ix , 1 , 1 : cp % nroots ) * xyzin ( jy , iy , 2 , 1 : cp % nroots ) * dxyzc ( jz , iz , 3 , 1 : cp % nroots )) dblk ( i , j , 1 ) = dblk ( i , j , 1 ) + der ( 1 ) * fac dblk ( i , j , 2 ) = dblk ( i , j , 2 ) + der ( 2 ) * fac dblk ( i , j , 3 ) = dblk ( i , j , 3 ) + der ( 3 ) * fac END DO END DO END ASSOCIATE END DO END SUBROUTINE !> @brief Charge-center (Hellmann-Feynman) first derivative of the !>   nuclear-attraction integral for one charge, returned as an (inao, jnao, 3) !>   block (not contracted). Mirrors comp_coulomb_helfeyder1. SUBROUTINE comp_coulomb_helfeyder1_block ( cp , c , znuc , dblk ) TYPE ( shpair_t ), INTENT ( IN ) :: cp REAL ( REAL64 ), INTENT ( IN ) :: c ( 3 ), znuc REAL ( REAL64 ), CONTIGUOUS , INTENT ( INOUT ) :: dblk (:,:,:) REAL ( REAL64 ) :: xx , fac , der ( 3 ), ric ( 3 ) type ( rys_root_t ) :: ryscomp INTEGER :: id , i , j , ix , iy , iz , jx , jy , jz real ( real64 ) :: xyzin ( 0 : 2 * max_ang + 1 , 0 : max_ang + 1 , 3 , max_nroots ) real ( real64 ) :: dxyzc ( 0 : max_ang_pad , 0 : max_ang , 3 , max_nroots ) ric = cp % ri (: 3 ) - c (: 3 ) DO id = 1 , cp % numpairs ASSOCIATE ( pp => cp % p ( id ), iang => cp % iang , jang => cp % jang , & inao => cp % inao , jnao => cp % jnao ) xx = pp % aa * sum (( pp % r - c ) ** 2 ) fac = pp % expfac * TWOPI * 2 ryscomp % nroots = cp % nroots ryscomp % x = xx CALL DQGaussRys ( ryscomp , cp , id , c , znuc , xyzin ) CALL der_helfey_xyz ( dxyzc , xyzin , iang , jang , ric , cp % nroots ) DO i = 1 , inao ix = CART_X ( i , iang ); iy = CART_Y ( i , iang ); iz = CART_Z ( i , iang ) DO j = 1 , jnao jx = CART_X ( j , jang ); jy = CART_Y ( j , jang ); jz = CART_Z ( j , jang ) der ( 1 ) = sum ( dxyzc ( jx , ix , 1 , 1 : cp % nroots ) * xyzin ( jy , iy , 2 , 1 : cp % nroots ) * xyzin ( jz , iz , 3 , 1 : cp % nroots )) der ( 2 ) = sum ( xyzin ( jx , ix , 1 , 1 : cp % nroots ) * dxyzc ( jy , iy , 2 , 1 : cp % nroots ) * xyzin ( jz , iz , 3 , 1 : cp % nroots )) der ( 3 ) = sum ( xyzin ( jx , ix , 1 , 1 : cp % nroots ) * xyzin ( jy , iy , 2 , 1 : cp % nroots ) * dxyzc ( jz , iz , 3 , 1 : cp % nroots )) dblk ( i , j , 1 ) = dblk ( i , j , 1 ) + der ( 1 ) * fac dblk ( i , j , 2 ) = dblk ( i , j , 2 ) + der ( 2 ) * fac dblk ( i , j , 3 ) = dblk ( i , j , 3 ) + der ( 3 ) * fac END DO END DO END ASSOCIATE END DO END SUBROUTINE !> @brief Uncontracted per-AO basis-center second-derivative blocks of the !>   nuclear-attraction integral for one charge center c (Gate 2 shared kernel). !> @details For a shell pair (bra X on atom A, ket Y on atom B) and charge centre !>   c this returns, for every cartesian AO pair (i in bra, j in ket): !>     pAA(a,b,i,j) = d2/dA_a dA_b <i| znuc/|r-c| |j>   (bra-bra, symmetric in a,b) !>     pAB(a,b,i,j) = d2/dA_a dB_b <i| znuc/|r-c| |j>   (bra-ket mixed, NOT symmetric) !> !>   The production basis-basis second derivative uses angular-momentum (AM) shift !>   identities and therefore does NOT differentiate the Rys roots/weights: the !>   bra second derivative is der2_coul_xyz (the bra raise/lower recursion applied !>   twice), the ket first derivative and the mixed bra-ket second derivative are !>   the analogous explicit index recurrences. The roots/weights are merely !>   recomputed for the shifted integral class at the corrected second-derivative !>   count nroots_der2 = floor((Li+Lj+2)/2)+1 (set here; NOT inherited from !>   cp%nroots). The validated rys_deriv.F90 layer is not used on this path. !> !>   Blocks are returned in the unnormalized cartesian convention (apply the !>   bfnrm shell normalization at contraction time, exactly as comp_coulomb_der1 !>   does for the gradient). Only s/p/d/f shells (nroots_der2 <= 5, i.e. the !>   closed-form rys_rt1..rys_rt5 regime) are supported; larger shells abort. SUBROUTINE comp_coulomb_der2_blocks ( cp , c , znuc , pAA , pAB ) TYPE ( shpair_t ), INTENT ( IN ) :: cp REAL ( REAL64 ), INTENT ( IN ) :: c ( 3 ), znuc REAL ( REAL64 ), INTENT ( OUT ) :: pAA (:,:,:,:), pAB (:,:,:,:) ! (3,3,inao,jnao) INTEGER :: id , i , j , nr , ix , iy , iz , jx , jy , jz INTEGER :: nroots_der2 REAL ( REAL64 ) :: xx , fac , aj type ( rys_root_t ) :: ryscomp real ( real64 ) :: xyzin ( 0 : 2 * max_ang + 2 , 0 : max_ang + 2 , 3 , max_nroots ) real ( real64 ) :: gDA ( 0 : max_ang + 2 , 0 : max_ang + 2 , 3 , max_nroots ) real ( real64 ) :: gDAA ( 0 : max_ang + 2 , 0 : max_ang + 2 , 3 , max_nroots ) real ( real64 ) :: dket ( 3 , max_nroots ) ! per-root ket (B-center) 1D first derivatives real ( real64 ) :: d2ab ( 3 , max_nroots ) ! per-root mixed bra-ket 1D second derivatives nroots_der2 = ( cp % iang + cp % jang + 2 ) / 2 + 1 if ( nroots_der2 > 5 ) & error stop 'comp_coulomb_der2_blocks: shell L>=4 not supported (nroots_der2>5)' pAA = 0.0_real64 pAB = 0.0_real64 DO id = 1 , cp % numpairs ASSOCIATE ( pp => cp % p ( id ), & iang => cp % iang , jang => cp % jang , & inao => cp % inao , jnao => cp % jnao ) xx = pp % aa * sum (( pp % r - c ) ** 2 ) ryscomp % nroots = nroots_der2 ryscomp % x = xx CALL QGaussRys ( ryscomp , cp , id , c , znuc , xyzin , 2 ) ! Bra first and second derivatives at the correct quadrature order CALL der_coul_xyz ( gDA , xyzin , iang , jang , pp % ai , nroots_der2 ) CALL der2_coul_xyz ( gDAA , xyzin , iang , jang , pp % ai , nroots_der2 ) fac = pp % expfac * TWOPI * pp % aa1 aj = pp % aj nr = nroots_der2 DO i = 1 , inao ix = CART_X ( i , iang ); iy = CART_Y ( i , iang ); iz = CART_Z ( i , iang ) DO j = 1 , jnao jx = CART_X ( j , jang ); jy = CART_Y ( j , jang ); jz = CART_Z ( j , jang ) ! Ket (B-center) first derivative per root: d/dB_q = 2*aj*[j+1,...] - j*[j-1,...] dket ( 1 , 1 : nr ) = 2 * aj * xyzin ( jx + 1 , ix , 1 , 1 : nr ) if ( jx > 0 ) dket ( 1 , 1 : nr ) = dket ( 1 , 1 : nr ) - jx * xyzin ( jx - 1 , ix , 1 , 1 : nr ) dket ( 2 , 1 : nr ) = 2 * aj * xyzin ( jy + 1 , iy , 2 , 1 : nr ) if ( jy > 0 ) dket ( 2 , 1 : nr ) = dket ( 2 , 1 : nr ) - jy * xyzin ( jy - 1 , iy , 2 , 1 : nr ) dket ( 3 , 1 : nr ) = 2 * aj * xyzin ( jz + 1 , iz , 3 , 1 : nr ) if ( jz > 0 ) dket ( 3 , 1 : nr ) = dket ( 3 , 1 : nr ) - jz * xyzin ( jz - 1 , iz , 3 , 1 : nr ) ! Mixed bra-ket second derivative per root: ! d2/dA_q dB_q = 2*ai*(2*aj*f(j+1,i+1)-j*f(j-1,i+1)) - i*(2*aj*f(j+1,i-1)-j*f(j-1,i-1)) d2ab ( 1 , 1 : nr ) = 2 * pp % ai * 2 * aj * xyzin ( jx + 1 , ix + 1 , 1 , 1 : nr ) if ( jx > 0 ) d2ab ( 1 , 1 : nr ) = d2ab ( 1 , 1 : nr ) - 2 * pp % ai * jx * xyzin ( jx - 1 , ix + 1 , 1 , 1 : nr ) if ( ix > 0 ) d2ab ( 1 , 1 : nr ) = d2ab ( 1 , 1 : nr ) - ix * 2 * aj * xyzin ( jx + 1 , ix - 1 , 1 , 1 : nr ) if ( ix > 0 . and . jx > 0 ) d2ab ( 1 , 1 : nr ) = d2ab ( 1 , 1 : nr ) + ix * jx * xyzin ( jx - 1 , ix - 1 , 1 , 1 : nr ) d2ab ( 2 , 1 : nr ) = 2 * pp % ai * 2 * aj * xyzin ( jy + 1 , iy + 1 , 2 , 1 : nr ) if ( jy > 0 ) d2ab ( 2 , 1 : nr ) = d2ab ( 2 , 1 : nr ) - 2 * pp % ai * jy * xyzin ( jy - 1 , iy + 1 , 2 , 1 : nr ) if ( iy > 0 ) d2ab ( 2 , 1 : nr ) = d2ab ( 2 , 1 : nr ) - iy * 2 * aj * xyzin ( jy + 1 , iy - 1 , 2 , 1 : nr ) if ( iy > 0 . and . jy > 0 ) d2ab ( 2 , 1 : nr ) = d2ab ( 2 , 1 : nr ) + iy * jy * xyzin ( jy - 1 , iy - 1 , 2 , 1 : nr ) d2ab ( 3 , 1 : nr ) = 2 * pp % ai * 2 * aj * xyzin ( jz + 1 , iz + 1 , 3 , 1 : nr ) if ( jz > 0 ) d2ab ( 3 , 1 : nr ) = d2ab ( 3 , 1 : nr ) - 2 * pp % ai * jz * xyzin ( jz - 1 , iz + 1 , 3 , 1 : nr ) if ( iz > 0 ) d2ab ( 3 , 1 : nr ) = d2ab ( 3 , 1 : nr ) - iz * 2 * aj * xyzin ( jz + 1 , iz - 1 , 3 , 1 : nr ) if ( iz > 0 . and . jz > 0 ) d2ab ( 3 , 1 : nr ) = d2ab ( 3 , 1 : nr ) + iz * jz * xyzin ( jz - 1 , iz - 1 , 3 , 1 : nr ) ! p_AA = d2/dA&#94;2 (symmetric; fill then mirror a<->b) pAA ( 1 , 1 , i , j ) = pAA ( 1 , 1 , i , j ) + fac * sum ( gDAA ( jx , ix , 1 , 1 : nr ) * xyzin ( jy , iy , 2 , 1 : nr ) * xyzin ( jz , iz , 3 , 1 : nr )) pAA ( 2 , 2 , i , j ) = pAA ( 2 , 2 , i , j ) + fac * sum ( xyzin ( jx , ix , 1 , 1 : nr ) * gDAA ( jy , iy , 2 , 1 : nr ) * xyzin ( jz , iz , 3 , 1 : nr )) pAA ( 3 , 3 , i , j ) = pAA ( 3 , 3 , i , j ) + fac * sum ( xyzin ( jx , ix , 1 , 1 : nr ) * xyzin ( jy , iy , 2 , 1 : nr ) * gDAA ( jz , iz , 3 , 1 : nr )) pAA ( 2 , 1 , i , j ) = pAA ( 2 , 1 , i , j ) + fac * sum ( gDA ( jx , ix , 1 , 1 : nr ) * gDA ( jy , iy , 2 , 1 : nr ) * xyzin ( jz , iz , 3 , 1 : nr )) pAA ( 3 , 1 , i , j ) = pAA ( 3 , 1 , i , j ) + fac * sum ( gDA ( jx , ix , 1 , 1 : nr ) * xyzin ( jy , iy , 2 , 1 : nr ) * gDA ( jz , iz , 3 , 1 : nr )) pAA ( 3 , 2 , i , j ) = pAA ( 3 , 2 , i , j ) + fac * sum ( xyzin ( jx , ix , 1 , 1 : nr ) * gDA ( jy , iy , 2 , 1 : nr ) * gDA ( jz , iz , 3 , 1 : nr )) pAA ( 1 , 2 , i , j ) = pAA ( 2 , 1 , i , j ) pAA ( 1 , 3 , i , j ) = pAA ( 3 , 1 , i , j ) pAA ( 2 , 3 , i , j ) = pAA ( 3 , 2 , i , j ) ! p_AB = d2/dA_a dB_b (NOT symmetric; pAB(a,b) = d2/dA_a dB_b) pAB ( 1 , 1 , i , j ) = pAB ( 1 , 1 , i , j ) + fac * sum ( d2ab ( 1 , 1 : nr ) * xyzin ( jy , iy , 2 , 1 : nr ) * xyzin ( jz , iz , 3 , 1 : nr )) pAB ( 2 , 2 , i , j ) = pAB ( 2 , 2 , i , j ) + fac * sum ( xyzin ( jx , ix , 1 , 1 : nr ) * d2ab ( 2 , 1 : nr ) * xyzin ( jz , iz , 3 , 1 : nr )) pAB ( 3 , 3 , i , j ) = pAB ( 3 , 3 , i , j ) + fac * sum ( xyzin ( jx , ix , 1 , 1 : nr ) * xyzin ( jy , iy , 2 , 1 : nr ) * d2ab ( 3 , 1 : nr )) pAB ( 1 , 2 , i , j ) = pAB ( 1 , 2 , i , j ) + fac * sum ( gDA ( jx , ix , 1 , 1 : nr ) * dket ( 2 , 1 : nr ) * xyzin ( jz , iz , 3 , 1 : nr )) pAB ( 2 , 1 , i , j ) = pAB ( 2 , 1 , i , j ) + fac * sum ( dket ( 1 , 1 : nr ) * gDA ( jy , iy , 2 , 1 : nr ) * xyzin ( jz , iz , 3 , 1 : nr )) pAB ( 1 , 3 , i , j ) = pAB ( 1 , 3 , i , j ) + fac * sum ( gDA ( jx , ix , 1 , 1 : nr ) * xyzin ( jy , iy , 2 , 1 : nr ) * dket ( 3 , 1 : nr )) pAB ( 3 , 1 , i , j ) = pAB ( 3 , 1 , i , j ) + fac * sum ( dket ( 1 , 1 : nr ) * xyzin ( jy , iy , 2 , 1 : nr ) * gDA ( jz , iz , 3 , 1 : nr )) pAB ( 2 , 3 , i , j ) = pAB ( 2 , 3 , i , j ) + fac * sum ( xyzin ( jx , ix , 1 , 1 : nr ) * gDA ( jy , iy , 2 , 1 : nr ) * dket ( 3 , 1 : nr )) pAB ( 3 , 2 , i , j ) = pAB ( 3 , 2 , i , j ) + fac * sum ( xyzin ( jx , ix , 1 , 1 : nr ) * dket ( 2 , 1 : nr ) * gDA ( jz , iz , 3 , 1 : nr )) END DO END DO END ASSOCIATE END DO END SUBROUTINE !> @brief Bra-bra and bra-charge second derivatives of the nuclear-attraction !>   integral for a single charge center c, contracted with a density block. !> @details Thin contraction wrapper over comp_coulomb_der2_blocks (the shared !>   production AM-shift kernel). On output: !>     p_XX += sum_ij dij(i,j) * d2/dX&#94;2 <i|znuc/|r-c||j>        (bra-bra) !>     p_XC += -sum_ij dij(i,j) * (d2/dX&#94;2 + d2/dX dY) <i|...|j> (bra-charge) !>   The bra-charge block uses single-center translational invariance !>   d/dc = -(d/dX + d/dY); no Rys root/weight differentiation is involved !>   (see comp_coulomb_der2_blocks). The caller (hess_en) obtains p_YY, p_YC by !>   calling again with the shell pair swapped, then assembles the 9 atom blocks. SUBROUTINE comp_coulomb_der2_braC ( cp , c , znuc , dij , p_XX , p_XC ) TYPE ( shpair_t ), INTENT ( IN ) :: cp REAL ( REAL64 ), INTENT ( IN ) :: c ( 3 ), znuc REAL ( REAL64 ), INTENT ( IN ) :: dij (:,:) REAL ( REAL64 ), CONTIGUOUS , INTENT ( INOUT ) :: p_XX (:,:), p_XC (:,:) REAL ( REAL64 ) :: pAA ( 3 , 3 , cp % inao , cp % jnao ), pAB ( 3 , 3 , cp % inao , cp % jnao ) REAL ( REAL64 ) :: bAA ( 3 , 3 ), bAB ( 3 , 3 ) INTEGER :: i , j CALL comp_coulomb_der2_blocks ( cp , c , znuc , pAA , pAB ) bAA = 0.0_real64 bAB = 0.0_real64 DO i = 1 , cp % inao DO j = 1 , cp % jnao bAA = bAA + dij ( i , j ) * pAA (:,:, i , j ) bAB = bAB + dij ( i , j ) * pAB (:,:, i , j ) END DO END DO p_XX = p_XX + bAA ! p_XC = d2/dA dC = -(d2/dA&#94;2 + d2/dA dB) by translational invariance p_XC = p_XC - ( bAA + bAB ) END SUBROUTINE !> @brief Compute 1e Ewald long-range contribution to the gradient (v.r.t. shifts of !>  shell's centers) !> @param[in]       nroots      roots for GaussRys !> @param[in]       cp          shell pair data !> @param[in]       c           coordinates of the charged particle !> @param[in]       znuc        particle charge !> @param[in]       dij         density matrix block !> @param[in]       omega       Ewald splitting parameter !> @param[inout]    dernuc      dimension(3), contribution to gradient ! !> @author   Vladimir Mironov ! !     REVISION HISTORY: !> @date _Sep, 2018_ Initial release ! SUBROUTINE comp_ewaldlr_der1 ( cp , c , znuc , dij , omega , dernuc ) !dir$ attributes inline :: comp_ewaldlr_der1 TYPE ( shpair_t ), INTENT ( IN ) :: cp REAL ( REAL64 ), INTENT ( IN ) :: c ( 3 ), znuc REAL ( REAL64 ), INTENT ( IN ) :: dij (:,:) REAL ( REAL64 ), INTENT ( IN ) :: omega REAL ( REAL64 ), INTENT ( OUT ) :: dernuc ( 3 ) REAL ( REAL64 ) :: xx type ( rys_root_t ) :: ryscomp REAL ( REAL64 ) :: der ( 3 ), fac , detmp ( 3 ), xfac INTEGER :: id , i , j , ix , iy , iz , jx , jy , jz real ( real64 ) :: xyzin ( 0 : 2 * max_ang + 1 , 0 : max_ang + 1 , 3 , max_nroots ) real ( real64 ) :: dxyzc ( 0 : max_ang_pad , 0 : max_ang , 3 , max_nroots ) !dir$ assume_aligned xyzin : 64 !dir$ assume_aligned dxyzc : 64 !dernuc = 0.0 DO id = 1 , cp % numpairs ASSOCIATE ( pp => cp % p ( id ), & iang => cp % iang , jang => cp % jang , & inao => cp % inao , jnao => cp % jnao ) xfac = omega * omega / ( pp % aa + omega * omega ) xx = pp % aa * sum (( pp % r - c ) ** 2 ) * xfac ryscomp % nroots = cp % nroots ryscomp % x = xx CALL QGaussRysEw ( ryscomp , cp , id , c , znuc , xfac , xyzin , 1 ) CALL der_coul_xyz ( dxyzc , xyzin , iang , jang , pp % ai , cp % nroots ) fac = pp % expfac * TWOPI * pp % aa1 * sqrt ( xfac ) detmp = 0.0 DO i = 1 , inao ix = CART_X ( i , iang ) iy = CART_Y ( i , iang ) iz = CART_Z ( i , iang ) DO j = 1 , jnao jx = CART_X ( j , jang ) jy = CART_Y ( j , jang ) jz = CART_Z ( j , jang ) der ( 1 ) = sum ( dxyzc ( jx , ix , 1 , 1 : cp % nroots )& * xyzin ( jy , iy , 2 , 1 : cp % nroots )& * xyzin ( jz , iz , 3 , 1 : cp % nroots ) ) der ( 2 ) = sum ( xyzin ( jx , ix , 1 , 1 : cp % nroots )& * dxyzc ( jy , iy , 2 , 1 : cp % nroots )& * xyzin ( jz , iz , 3 , 1 : cp % nroots ) ) der ( 3 ) = sum ( xyzin ( jx , ix , 1 , 1 : cp % nroots )& * xyzin ( jy , iy , 2 , 1 : cp % nroots )& * dxyzc ( jz , iz , 3 , 1 : cp % nroots ) ) detmp = detmp + der * dij ( i , j ) END DO END DO dernuc = dernuc + detmp * fac END ASSOCIATE END DO END SUBROUTINE !> @brief Compute Ewald long-range 1e Hellmann-Feynman contribution !>  to the gradient !> @param[in]       nroots      roots for GaussRys !> @param[in]       cp          shell pair data !> @param[in]       c           coordinates of the charged particle !> @param[in]       znuc        particle charge !> @param[in]       dij         density matrix block !> @param[in]       omega       Ewald splitting parameter !> @param[inout]    derhf       dimension(3), contribution to gradient ! !> @author   Vladimir Mironov ! !     REVISION HISTORY: !> @date _Sep, 2018_ Initial release ! SUBROUTINE comp_ewaldlr_helfeyder1 ( cp , c , znuc , dij , omega , derhf ) !dir$ attributes inline :: comp_ewaldlr_helfeyder1 TYPE ( shpair_t ), INTENT ( IN ) :: cp REAL ( REAL64 ), INTENT ( IN ) :: c ( 3 ), znuc REAL ( REAL64 ), INTENT ( IN ) :: dij (:,:) REAL ( REAL64 ), INTENT ( IN ) :: omega REAL ( REAL64 ), CONTIGUOUS , INTENT ( OUT ) :: derhf (:) REAL ( REAL64 ) :: xx type ( rys_root_t ) :: ryscomp REAL ( REAL64 ) :: ric ( 3 ) REAL ( REAL64 ) :: der ( 3 ), fac , xfac INTEGER :: id , i , j , ix , iy , iz , jx , jy , jz real ( real64 ) :: xyzin ( 0 : 2 * max_ang + 1 , 0 : max_ang + 1 , 3 , max_nroots ) real ( real64 ) :: dxyzc ( 0 : max_ang_pad , 0 : max_ang , 3 , max_nroots ) !dir$ assume_aligned xyzin : 64 !dir$ assume_aligned dxyzc : 64 derhf = 0.0 ric = cp % ri (: 3 ) - c (: 3 ) DO id = 1 , cp % numpairs ASSOCIATE ( pp => cp % p ( id ), & iang => cp % iang , jang => cp % jang , & inao => cp % inao , jnao => cp % jnao ) xfac = omega * omega / ( pp % aa + omega * omega ) xx = pp % aa * sum (( pp % r - c ) ** 2 ) * xfac ryscomp % nroots = cp % nroots ryscomp % x = xx CALL DQGaussRysEw ( ryscomp , cp , id , c , znuc , xfac , xyzin ) CALL der_helfey_xyz ( dxyzc , xyzin , iang , jang , ric , cp % nroots ) fac = pp % expfac * TWOPI * 2 * sqrt ( xfac ) DO i = 1 , inao ix = CART_X ( i , iang ) iy = CART_Y ( i , iang ) iz = CART_Z ( i , iang ) DO j = 1 , jnao jx = CART_X ( j , jang ) jy = CART_Y ( j , jang ) jz = CART_Z ( j , jang ) der ( 1 ) = sum ( dxyzc ( jx , ix , 1 , 1 : cp % nroots )& * xyzin ( jy , iy , 2 , 1 : cp % nroots )& * xyzin ( jz , iz , 3 , 1 : cp % nroots )) der ( 2 ) = sum ( xyzin ( jx , ix , 1 , 1 : cp % nroots )& * dxyzc ( jy , iy , 2 , 1 : cp % nroots )& * xyzin ( jz , iz , 3 , 1 : cp % nroots )) der ( 3 ) = sum ( xyzin ( jx , ix , 1 , 1 : cp % nroots )& * xyzin ( jy , iy , 2 , 1 : cp % nroots )& * dxyzc ( jz , iz , 3 , 1 : cp % nroots )) derhf = derhf + der * dij ( i , j ) * fac END DO END DO END ASSOCIATE END DO END SUBROUTINE !-------------------------------------------------------------------------------- !       K.E. AND OVERLAP 1D INTEGRALS !-------------------------------------------------------------------------------- !> @brief Compute 1D overlap integrals !> @details Return block of 1D integrals, dimensions: (Lj,Li,XYZ) !> @param[in]       ri          coordinates of first shell center !> @param[in]       rj          coordinates of second shell center !> @param[in]       rij         coordinates of shell-pair center of charge !> @param[in]       aa1         inverse total exponent !> @param[in]       li          max angular momentum for the first shell center !> @param[in]       lj          max angular momentum for the second shell center !> @param[inout]    xyzovl      block of 1D overlap integrals ! !> @author   Vladimir Mironov ! !     REVISION HISTORY: !> @date _Sep, 2018_ Initial release ! SUBROUTINE overlap_xyz ( ri , rj , rij , aa1 , li , lj , xyzovl ) !dir$ attributes forceinline :: overlap_xyz REAL ( REAL64 ), CONTIGUOUS , INTENT ( IN ) :: ri (:), rj (:), rij (:) REAL ( REAL64 ), INTENT ( IN ) :: aa1 INTEGER , INTENT ( IN ) :: li , lj REAL ( REAL64 ), CONTIGUOUS , INTENT ( OUT ) :: xyzovl ( 0 :, 0 :,:) INTEGER :: i , j REAL ( REAL64 ) :: taa , oint ( 3 ) taa = sqrt ( aa1 ) DO i = 0 , li DO j = 0 , lj CALL doQuadGaussHermite ( oint , taa , rij (: 3 ), & ri (: 3 ), rj (: 3 ), i , j ) xyzovl ( j , i ,:) = oint * taa END DO END DO END SUBROUTINE !> @brief Kinetic energy integrals, recursion over first shell !> @details Compute K.E.I. from overlap integrals using recurrence !>  over first shell !> @param[out] xyzt 1D kinetic energy integrals !> @param[in]  xyzs 1D overlap integrals !> @param[in]  ni   number of points for the 1st shell quad. !> @param[in]  nj   number of points for the 2nd shell quad. !> @param[in]  ai   first shell exponent !> @author   Vladimir Mironov ! !> @note Before running this routine, first you need to !>  compute overlap integrals for angular momentums (Li+2, Lj) ! !     REVISION HISTORY: !> @date _Sep, 2018_ Initial release ! SUBROUTINE kinetic_xyz_i ( xyzt , xyzs , ni , nj , ai ) !dir$ attributes forceinline :: kinetic_xyz_i REAL ( REAL64 ), CONTIGUOUS , INTENT ( OUT ) :: xyzt ( 0 :, 0 :,:) REAL ( REAL64 ), CONTIGUOUS , INTENT ( IN ) :: xyzs ( 0 :, 0 :,:) REAL ( REAL64 ), INTENT ( IN ) :: ai INTEGER , INTENT ( IN ) :: ni , nj INTEGER :: i REAL ( REAL64 ) :: fact1 , fact2 xyzt ( 0 : nj , 0 ,:) = ( xyzs ( 0 : nj , 0 ,:) - 2 * ai * xyzs ( 0 : nj , 2 ,:)) * ai IF ( ni == 0 ) RETURN xyzt ( 0 : nj , 1 ,:) = ( xyzs ( 0 : nj , 1 ,:) * 3.0D0 - 2 * ai * xyzs ( 0 : nj , 3 ,:)) * ai IF ( ni == 1 ) RETURN DO i = 2 , ni fact1 = 2 * i + 1 fact2 = real ( i * ( i - 1 ) / 2 , REAL64 ) xyzt ( 0 : nj , i ,:) = ( xyzs ( 0 : nj , i ,:) * fact1 - 2 * ai * xyzs ( 0 : nj , i + 2 ,:)) * ai - xyzs ( 0 : nj , i - 2 ,:) * fact2 END DO END SUBROUTINE !> @brief Kinetic energy integrals, recursion over second shell !> @details Compute K.E.I. from overlap integrals using recurrence !>  over second shell !> @param[out] xyzt 1D kinetic energy integrals !> @param[in]  xyzs 1D overlap integrals !> @param[in]  ni   number of points for the 1st shell quad. !> @param[in]  nj   number of points for the 2nd shell quad. !> @param[in]  aj   second shell exponent !> @author   Vladimir Mironov ! !> @note Before running this routine, first you need to !>  compute overlap integrals for angular momentums (Li+2, Lj) ! !     REVISION HISTORY: !> @date _Sep, 2018_ Initial release ! SUBROUTINE kinetic_xyz_j ( xyzt , xyzs , ni , nj , aj ) !dir$ attributes forceinline :: kinetic_xyz_j REAL ( REAL64 ), CONTIGUOUS , INTENT ( OUT ) :: xyzt ( 0 :, 0 :,:) REAL ( REAL64 ), CONTIGUOUS , INTENT ( IN ) :: xyzs ( 0 :, 0 :,:) REAL ( REAL64 ), INTENT ( IN ) :: aj INTEGER , INTENT ( IN ) :: ni , nj INTEGER :: j REAL ( REAL64 ) :: fact1 , fact2 xyzt ( 0 , 0 : ni ,:) = ( xyzs ( 0 , 0 : ni ,:) - 2 * aj * xyzs ( 2 , 0 : ni ,:)) * aj IF ( nj == 0 ) RETURN xyzt ( 1 , 0 : ni ,:) = ( xyzs ( 1 , 0 : ni ,:) * 3.0D0 - 2 * aj * xyzs ( 3 , 0 : ni ,:)) * aj IF ( nj == 1 ) RETURN DO j = 2 , nj fact1 = 2 * j + 1 fact2 = real ( j * ( j - 1 ) / 2 , REAL64 ) xyzt ( j , 0 : ni ,:) = ( xyzs ( j , 0 : ni ,:) * fact1 - 2 * aj * xyzs ( j + 2 , 0 : ni ,:)) * aj - xyzs ( j - 2 , 0 : ni ,:) * fact2 END DO END SUBROUTINE !-------------------------------------------------------------------------------- !       Multipole moment integrals !-------------------------------------------------------------------------------- !> @brief Compute multipole moment integrals using Gauss-Hermite quadrature !> @details Return block of 1D integrals, dimensions: (Lj,Li,XYZ) !> @param[in]       ri          coordinates of first shell center !> @param[in]       rj          coordinates of second shell center !> @param[in]       rij         coordinates of shell-pair center of charge !> @param[in]       aa1         inverse total exponent !> @param[in]       li          max angular momentum for the first shell center !> @param[in]       lj          max angular momentum for the second shell center !> @param[in]       r           origin of multipole moment integrals !> @param[in]       mxmom       max order of multipole moment integrals !> @param[inout]    xyzints     block of mutipole moments integrals ! !> @author   Vladimir Mironov ! !     REVISION HISTORY: !> @date _Sep, 2018_ Initial release ! SUBROUTINE multipole_xyz ( ri , rj , rij , aa1 , li , lj , r , mxmom , xyzints ) !dir$ attributes forceinline :: overlap_xyz REAL ( REAL64 ), CONTIGUOUS , INTENT ( IN ) :: ri (:), rj (:), rij (:), r (:) REAL ( REAL64 ), INTENT ( IN ) :: aa1 INTEGER , INTENT ( IN ) :: li , lj integer , intent ( in ) :: mxmom REAL ( REAL64 ), CONTIGUOUS , INTENT ( OUT ) :: xyzints (:, 0 :, 0 :, 0 :) INTEGER :: i , j REAL ( REAL64 ) :: taa , ppint ( 3 , 0 : MAX_EL_MOM ) taa = sqrt ( aa1 ) DO i = 0 , li DO j = 0 , lj CALL mulQuadGaussHermite ( ppint , taa , rij (: 3 ), & ri (: 3 ), rj (: 3 ), r (: 3 ), i , j , mxmom ) xyzints (:, 0 : mxmom , j , i ) = ppint (:, 0 : mxmom ) * taa END DO END DO END SUBROUTINE !-------------------------------------------------------------------------------- !       DERIVATIVE CODE 1D INTEGRALS !-------------------------------------------------------------------------------- !> @brief Compute derivatives of 1D Coulomb integrals v.r.t. shifts of shell centers !> @details Derivatives are computed using following equation: !>  \\f$ D(L_i,L_j) = 2\\alpha_i I(L_i+1,L_j) - L_i I(L_i-1,L_j) \\f$ !> @param[out] dxyzdi    1D Coulomb integral derivatives (dims: (Lj,Li,XYZ,NRoots) !> @param[in]  xyzin     1D Coulomb integrals (dims: (Lj,Li,XYZ,NRoots) !> @param[in]  lit       angular momentum of the 1st shell + 1 !> @param[in]  ljt       angular momentum of the 2nd shell + 1 !> @param[in]  ai        exponent of the first shell !> @param[in]  nroots    number of roots in Gauss-Rys quadrature !> @author   Vladimir Mironov ! !> @note based on DERI from grd1.src ! !     REVISION HISTORY: !> @date _Sep, 2018_ Initial release ! SUBROUTINE der_coul_xyz ( dxyzdi , xyzin , lit , ljt , ai , nroots ) !dir$ attributes forceinline :: der_coul_xyz REAL ( REAL64 ), INTENT ( IN ) :: ai REAL ( REAL64 ), CONTIGUOUS , INTENT ( IN ) :: xyzin ( 0 :, 0 :,:,:) REAL ( REAL64 ), CONTIGUOUS , INTENT ( OUT ) :: dxyzdi ( 0 :, 0 :,:,:) INTEGER , INTENT ( IN ) :: lit , ljt , nroots INTEGER :: i !dir$ assume_aligned xyzin : 64 !dir$ assume_aligned dxyzdi : 64 dxyzdi ( 0 : ljt , 0 : lit , 1 : 3 , 1 : nroots ) = 2 * ai * xyzin ( 0 : ljt , 1 : lit + 1 , 1 : 3 , 1 : nroots ) DO i = 1 , lit dxyzdi ( 0 : ljt , i , 1 : 3 , 1 : nroots ) = dxyzdi ( 0 : ljt , i , 1 : 3 , 1 : nroots ) - i * xyzin ( 0 : ljt , i - 1 , 1 : 3 , 1 : nroots ) END DO END SUBROUTINE !> @brief Second derivative of the 1D Coulomb (nuclear-attraction) integrals !>  with respect to the bra center, obtained by applying the bra-center !>  derivative recursion (der_coul_xyz) twice: !>    d2[j,i] = 4 ai&#94;2 [j,i+2] - 2 ai (2i+1) [j,i] + i(i-1) [j,i-2] !>  per Rys root. The input array must be available up to bra index lit+2 !>  (build QGaussRys with igrd=2 and a correspondingly sized xyzin). !> !>  Together with the analogous ket-center derivatives, this provides the !>  basis-center second-derivative blocks (AA, AB, BB) of the nuclear-attraction !>  Hessian. The charge-center (Hellmann-Feynman) and mixed blocks follow from !>  translational invariance, d/dC = -(d/dA + d/dB), so no second-derivative Rys !>  root machinery is required. SUBROUTINE der2_coul_xyz ( d2xyz , xyzin , lit , ljt , ai , nroots ) !dir$ attributes forceinline :: der2_coul_xyz REAL ( REAL64 ), INTENT ( IN ) :: ai REAL ( REAL64 ), CONTIGUOUS , INTENT ( IN ) :: xyzin ( 0 :, 0 :,:,:) REAL ( REAL64 ), CONTIGUOUS , INTENT ( OUT ) :: d2xyz ( 0 :, 0 :,:,:) INTEGER , INTENT ( IN ) :: lit , ljt , nroots INTEGER :: i !dir$ assume_aligned xyzin : 64 !dir$ assume_aligned d2xyz : 64 d2xyz ( 0 : ljt , 0 : lit , 1 : 3 , 1 : nroots ) = 4 * ai * ai * xyzin ( 0 : ljt , 2 : lit + 2 , 1 : 3 , 1 : nroots ) DO i = 0 , lit d2xyz ( 0 : ljt , i , 1 : 3 , 1 : nroots ) = d2xyz ( 0 : ljt , i , 1 : 3 , 1 : nroots ) & - 2 * ai * ( 2 * i + 1 ) * xyzin ( 0 : ljt , i , 1 : 3 , 1 : nroots ) END DO DO i = 2 , lit d2xyz ( 0 : ljt , i , 1 : 3 , 1 : nroots ) = d2xyz ( 0 : ljt , i , 1 : 3 , 1 : nroots ) & + i * ( i - 1 ) * xyzin ( 0 : ljt , i - 2 , 1 : 3 , 1 : nroots ) END DO END SUBROUTINE !> @brief Compute derivatives of 1D Coulomb integrals v.r.t. shifts of the nuclei !>  (Hellman-Feynman term) !>  Derivatives are computed using following equation: !>  \\f$ D(L_i,L_j) = I(L_i+1,L_j) - (r_i - r_c) I(L_i,L_j) \\f$ !> @param[out] dxyzdc    1D Coulomb integral derivatives (dims: (Lj,Li,XYZ,NRoots) !> @param[in]  xyzin     1D Coulomb integrals (dims: (Lj,Li,XYZ,NRoots) !> @param[in]  lit       angular momentum of the 1st shell + 1 !> @param[in]  ljt       angular momentum of the 2nd shell + 1 !> @param[in]  ric       (Ri-Rij)xyz !> @param[in]  nroots    number of roots in Gauss-Rys quadrature !> @author   Vladimir Mironov ! !     REVISION HISTORY: !> @date _Sep, 2018_ Initial release ! SUBROUTINE der_helfey_xyz ( dxyzdc , xyzin , lit , ljt , ric , nroots ) !dir$ attributes forceinline :: der_helfey_xyz REAL ( REAL64 ), INTENT ( IN ) :: ric ( 3 ) REAL ( REAL64 ), CONTIGUOUS , INTENT ( IN ) :: xyzin ( 0 :, 0 :,:,:) REAL ( REAL64 ), CONTIGUOUS , INTENT ( OUT ) :: dxyzdc ( 0 :, 0 :,:,:) INTEGER , INTENT ( IN ) :: lit , ljt , nroots !dir$ assume_aligned xyzin : 64 dxyzdc ( 0 : ljt , 0 : lit , 1 , 1 : nroots ) = xyzin ( 0 : ljt , 1 : lit + 1 , 1 , 1 : nroots ) + ric ( 1 ) * xyzin ( 0 : ljt , 0 : lit , 1 , 1 : nroots ) dxyzdc ( 0 : ljt , 0 : lit , 2 , 1 : nroots ) = xyzin ( 0 : ljt , 1 : lit + 1 , 2 , 1 : nroots ) + ric ( 2 ) * xyzin ( 0 : ljt , 0 : lit , 2 , 1 : nroots ) dxyzdc ( 0 : ljt , 0 : lit , 3 , 1 : nroots ) = xyzin ( 0 : ljt , 1 : lit + 1 , 3 , 1 : nroots ) + ric ( 3 ) * xyzin ( 0 : ljt , 0 : lit , 3 , 1 : nroots ) END SUBROUTINE !> @brief 1e overlap and kinetic energy integrals differentiation !> @param[out] dxyz 1D derivatives !> @param[in]  xyz  1D integrals !> @param[in]  lit  angular momentum of the 1st shell + 1 !> @param[in]  ljt  angular momentum of the 2nd shell + 1 !> @param[in]  ai   exponent of the first shell !> @author   Vladimir Mironov ! !     REVISION HISTORY: !> @date _Sep, 2018_ Initial release ! SUBROUTINE der_kinovl_xyz ( dxyz , xyz , lit , ljt , ai ) !dir$ attributes forceinline :: der_kinovl_xyz REAL ( REAL64 ), INTENT ( IN ) :: ai REAL ( REAL64 ), CONTIGUOUS , INTENT ( IN ) :: xyz ( 0 :, 0 :,:) REAL ( REAL64 ), CONTIGUOUS , INTENT ( OUT ) :: dxyz ( 0 :, 0 :,:) INTEGER , INTENT ( IN ) :: lit , ljt INTEGER :: i dxyz ( 0 : ljt , 0 : lit ,:) = 2 * ai * xyz ( 0 : ljt , 1 : lit + 1 ,:) !IF (lit==1) RETURN DO i = 1 , lit dxyz ( 0 : ljt , i ,:) = dxyz ( 0 : ljt , i ,:) - i * xyz ( 0 : ljt , i - 1 ,:) END DO END SUBROUTINE !> @brief Second derivative of 1D overlap/kinetic integrals w.r.t. the bra !>  center, obtained by applying the bra-center derivative operator twice: !>    d2[j,i] = 4 ai&#94;2 [j,i+2] - 2 ai (2i+1) [j,i] + i(i-1) [j,i-2] !>  This is identical to der_kinovl_xyz composed with itself; the input array !>  must therefore be available up to bra index lit+2. SUBROUTINE der2_kinovl_xyz ( d2xyz , xyz , lit , ljt , ai ) !dir$ attributes forceinline :: der2_kinovl_xyz REAL ( REAL64 ), INTENT ( IN ) :: ai REAL ( REAL64 ), CONTIGUOUS , INTENT ( IN ) :: xyz ( 0 :, 0 :,:) REAL ( REAL64 ), CONTIGUOUS , INTENT ( OUT ) :: d2xyz ( 0 :, 0 :,:) INTEGER , INTENT ( IN ) :: lit , ljt INTEGER :: i d2xyz ( 0 : ljt , 0 : lit ,:) = 4 * ai * ai * xyz ( 0 : ljt , 2 : lit + 2 ,:) DO i = 0 , lit d2xyz ( 0 : ljt , i ,:) = d2xyz ( 0 : ljt , i ,:) - 2 * ai * ( 2 * i + 1 ) * xyz ( 0 : ljt , i ,:) END DO DO i = 2 , lit d2xyz ( 0 : ljt , i ,:) = d2xyz ( 0 : ljt , i ,:) + i * ( i - 1 ) * xyz ( 0 : ljt , i - 2 ,:) END DO END SUBROUTINE !-------------------------------------------------------------------------------- !       GAUSS-RYS QUADRATURE RELATED ROUTINES !-------------------------------------------------------------------------------- !> @brief Compute 1D integrals for 1e Coulomb integrals !> @details In this implementation 1D integrals at Rys abscissae are !>  computed using VRR and HRR recurrences !> @note The common factor for the integral block is \\f$ 2\\Pi \\f$ !> @param[in]  nroots   roots for GaussRys !> @param[in]  cp       shell pair data !> @param[in]  id       current pair of primitives !> @param[in]  c        coordinates of the charged particle !> @param[in]  znuc     charge of the particle !> @param[out] xyzin    array of 1D integrals !> @param[in]  igrd     [opt] flag indicating that integral derivatives are needed !> @author   Vladimir Mironov ! !     REVISION HISTORY: !> @date _Sep, 2018_ Initial release ! SUBROUTINE QGaussRys ( ryscomp , cp , id , c , znuc , xyzin , igrd ) !dir$ attributes forceinline :: QGaussRys TYPE ( shpair_t ), INTENT ( IN ) :: cp INTEGER , INTENT ( IN ) :: id REAL ( REAL64 ), INTENT ( IN ) :: c ( 3 ), znuc REAL ( REAL64 ), CONTIGUOUS , INTENT ( OUT ) :: xyzin ( 0 :, 0 :,:,:) INTEGER , INTENT ( IN ), OPTIONAL :: igrd type ( rys_root_t ), intent ( inout ) :: ryscomp INTEGER :: ni , nj , k , igrd1 REAL ( REAL64 ) :: ww , tt REAL ( REAL64 ) :: b , d ( 3 ), dij ( 3 ) !dir$ assume_aligned xyzin : 64 igrd1 = 0 IF ( present ( igrd )) igrd1 = igrd call ryscomp % evaluate () ASSOCIATE ( pp => cp % p ( id ), iang => cp % iang , jang => cp % jang ) DO k = 1 , ryscomp % nroots ww = ryscomp % w ( k ) * znuc tt = ryscomp % u ( k ) / ( 1.0 + ryscomp % u ( k )) b = 0.5 * ( 1.0 - tt ) / pp % aa d = ( pp % r - cp % rj ) - tt * ( pp % r - c ) dij = cp % rj - cp % ri xyzin ( 0 , 0 , 1 , k ) = 1.0 xyzin ( 0 , 0 , 2 , k ) = 1.0 xyzin ( 0 , 0 , 3 , k ) = ww xyzin ( 1 , 0 , 1 , k ) = d ( 1 ) xyzin ( 1 , 0 , 2 , k ) = d ( 2 ) xyzin ( 1 , 0 , 3 , k ) = d ( 3 ) * ww ! VRR (Lj+1,0) <- Rpj*(Lj,0) + Lj*b*(Lj-1,0) DO nj = 2 , ( iang + jang ) + igrd1 xyzin ( nj , 0 ,:, k ) = d * xyzin ( nj - 1 , 0 ,:, k ) + ( nj - 1 ) * b * xyzin ( nj - 2 , 0 ,:, k ) END DO ! HRR (Lj,Li+1) <- (Lj+1,Li) + Rij*(Lj,Li) nj = ( iang + jang ) + igrd1 DO ni = 1 , iang + igrd1 nj = nj - 1 xyzin ( 0 : nj , ni , 1 , k ) = xyzin ( 1 : nj + 1 , ni - 1 , 1 , k ) + dij ( 1 ) * xyzin ( 0 : nj , ni - 1 , 1 , k ) xyzin ( 0 : nj , ni , 2 , k ) = xyzin ( 1 : nj + 1 , ni - 1 , 2 , k ) + dij ( 2 ) * xyzin ( 0 : nj , ni - 1 , 2 , k ) xyzin ( 0 : nj , ni , 3 , k ) = xyzin ( 1 : nj + 1 , ni - 1 , 3 , k ) + dij ( 3 ) * xyzin ( 0 : nj , ni - 1 , 3 , k ) END DO END DO END ASSOCIATE END SUBROUTINE !> @brief Compute 1D Coulomb integrals with Gaussian damping !> @details Compute 1D integrals for the modified Coulomb potential: !>  \\f$ |r-r_C|&#94;{-1}\\cdot e&#94;{-\\alpha(r-r_C)&#94;2} \\f$ !> @param[in]  nroots   roots for GaussRys !> @param[in]  cp       shell pair data !> @param[in]  id       current pair of primitives !> @param[in]  c        coordinates of the charged particle !> @param[in]  znuc     charge of the particle !> @param[in]  alpha    dumping exponent !> @param[out] xyzin    array of 1D integrals ! !> @author   Vladimir Mironov ! !     REVISION HISTORY: !> @date _Sep, 2018_ Initial release SUBROUTINE QGaussRys_damp ( ryscomp , cp , id , c , znuc , alpha , xyzin ) !dir$ attributes forceinline :: QGaussRys_damp TYPE ( shpair_t ), INTENT ( IN ) :: cp INTEGER , INTENT ( IN ) :: id REAL ( REAL64 ), INTENT ( IN ) :: alpha , c ( 3 ), znuc REAL ( REAL64 ), CONTIGUOUS , INTENT ( OUT ) :: xyzin ( 0 :, 0 :,:,:) type ( rys_root_t ), intent ( inout ) :: ryscomp INTEGER :: ni , nj INTEGER :: k REAL ( REAL64 ) :: ww , tt REAL ( REAL64 ) :: b , d ( 3 ), dij ( 3 ) !dir$ assume_aligned xyzin : 64 call ryscomp % evaluate () ASSOCIATE ( pp => cp % p ( id ), iang => cp % iang , jang => cp % jang ) DO k = 1 , ryscomp % nroots ww = ryscomp % w ( k ) * znuc tt = ryscomp % u ( k ) / ( 1.0 + ryscomp % u ( k )) !       Recurrence coefficients are slightly differend from those used in regular G-R quadrature b = 0.5 * ( 1.0 - tt ) / ( pp % aa + alpha ) d = ( c - cp % rj ) + 2 * pp % aa * b * ( pp % r - c ) dij = cp % rj - cp % ri xyzin ( 0 , 0 , 1 , k ) = 1.0 xyzin ( 0 , 0 , 2 , k ) = 1.0 xyzin ( 0 , 0 , 3 , k ) = ww xyzin ( 1 , 0 , 1 , k ) = d ( 1 ) xyzin ( 1 , 0 , 2 , k ) = d ( 2 ) xyzin ( 1 , 0 , 3 , k ) = d ( 3 ) * ww ! VRR (Lj+1,0) <- Rpj*(Lj,0) + Lj*b*(Lj-1,0) DO nj = 2 , iang + jang xyzin ( nj , 0 ,:, k ) = d (:) * xyzin ( nj - 1 , 0 ,:, k ) + ( nj - 1 ) * b * xyzin ( nj - 2 , 0 ,:, k ) END DO ! HRR (Lj,Li+1) <- (Lj+1,Li) + Rij*(Lj,Li) nj = iang + jang DO ni = 1 , iang nj = nj - 1 xyzin ( 0 : nj , ni , 1 , k ) = xyzin ( 1 : nj + 1 , ni - 1 , 1 , k ) + dij ( 1 ) * xyzin ( 0 : nj , ni - 1 , 1 , k ) xyzin ( 0 : nj , ni , 2 , k ) = xyzin ( 1 : nj + 1 , ni - 1 , 2 , k ) + dij ( 2 ) * xyzin ( 0 : nj , ni - 1 , 2 , k ) xyzin ( 0 : nj , ni , 3 , k ) = xyzin ( 1 : nj + 1 , ni - 1 , 3 , k ) + dij ( 3 ) * xyzin ( 0 : nj , ni - 1 , 3 , k ) END DO END DO END ASSOCIATE END SUBROUTINE !> @brief Compute 1D integrals for Ewald long-range 1e Coulomb integrals !> @details In this implementation 1D integrals at Rys abscissae are !>  computed using VRR and HRR recurrences !> @note The common factor for the integral block is \\f$ 2\\Pi \\f$ !> @param[in]  nroots   roots for GaussRys !> @param[in]  cp       shell pair data !> @param[in]  id       current pair of primitives !> @param[in]  c        coordinates of the charged particle !> @param[in]  znuc     charge of the particle !> @param[in]  xfac     factor a*a/(p+a*a) !> @param[out] xyzin    array of 1D integrals !> @param[in]  igrd     [opt] flag indicating that integral derivatives are needed !> @author   Vladimir Mironov ! !     REVISION HISTORY: !> @date _Sep, 2018_ Initial release ! SUBROUTINE QGaussRysEw ( ryscomp , cp , id , c , znuc , xfac , xyzin , igrd ) !dir$ attributes forceinline :: QGaussRysEw TYPE ( shpair_t ), INTENT ( IN ) :: cp INTEGER , INTENT ( IN ) :: id REAL ( REAL64 ), INTENT ( IN ) :: c ( 3 ), znuc , xfac REAL ( REAL64 ), CONTIGUOUS , INTENT ( OUT ) :: xyzin ( 0 :, 0 :,:,:) INTEGER , INTENT ( IN ), OPTIONAL :: igrd type ( rys_root_t ) :: ryscomp INTEGER :: ni , nj , k , igrd1 REAL ( REAL64 ) :: ww , tt REAL ( REAL64 ) :: b , d ( 3 ), dij ( 3 ) !dir$ assume_aligned xyzin : 64 igrd1 = 0 IF ( present ( igrd )) igrd1 = igrd call ryscomp % evaluate () ASSOCIATE ( pp => cp % p ( id ), iang => cp % iang , jang => cp % jang ) DO k = 1 , ryscomp % nroots ww = ryscomp % w ( k ) * znuc tt = ryscomp % u ( k ) / ( 1.0 + ryscomp % u ( k )) * xfac b = 0.5 * ( 1.0 - tt ) / pp % aa d = ( pp % r - cp % rj ) - tt * ( pp % r - c ) dij = cp % rj - cp % ri xyzin ( 0 , 0 , 1 , k ) = 1.0 xyzin ( 0 , 0 , 2 , k ) = 1.0 xyzin ( 0 , 0 , 3 , k ) = ww xyzin ( 1 , 0 , 1 , k ) = d ( 1 ) xyzin ( 1 , 0 , 2 , k ) = d ( 2 ) xyzin ( 1 , 0 , 3 , k ) = d ( 3 ) * ww ! VRR (Lj+1,0) <- Rpj*(Lj,0) + Lj*b*(Lj-1,0) DO nj = 2 , iang + jang + igrd1 xyzin ( nj , 0 ,:, k ) = d * xyzin ( nj - 1 , 0 ,:, k ) + ( nj - 1 ) * b * xyzin ( nj - 2 , 0 ,:, k ) END DO ! HRR (Lj,Li+1) <- (Lj+1,Li) + Rij*(Lj,Li) nj = iang + jang + igrd1 DO ni = 1 , iang + igrd1 nj = nj - 1 xyzin ( 0 : nj , ni , 1 , k ) = xyzin ( 1 : nj + 1 , ni - 1 , 1 , k ) + dij ( 1 ) * xyzin ( 0 : nj , ni - 1 , 1 , k ) xyzin ( 0 : nj , ni , 2 , k ) = xyzin ( 1 : nj + 1 , ni - 1 , 2 , k ) + dij ( 2 ) * xyzin ( 0 : nj , ni - 1 , 2 , k ) xyzin ( 0 : nj , ni , 3 , k ) = xyzin ( 1 : nj + 1 , ni - 1 , 3 , k ) + dij ( 3 ) * xyzin ( 0 : nj , ni - 1 , 3 , k ) END DO END DO END ASSOCIATE END SUBROUTINE !> @brief Compute 1D integrals needed in calculation of the  Hellmann-Feynman !>  contribution to the gradient !> @details They differ from the regular integrals !>  only by the \\f$ 2u&#94;2 \\f$ factor. Note, that 2*(ai+aj) factor is absent !>  here - it will be applied to the final gradient contribution !  TODO: !  Redesign Gauss-Rys quadrature code to handle both cases !> @note The common factor for the integral block is \\f$ 2\\Pi \\f$ !> @param[in]  nroots   roots for GaussRys !> @param[in]  cp       shell pair data !> @param[in]  id       current pair of primitives !> @param[in]  c        coordinates of the charged particle !> @param[in]  znuc     charge of the particle !> @param[out] xyzin    array of 1D integrals !> @author   Vladimir Mironov ! !     REVISION HISTORY: !> @date _Sep, 2018_ Initial release ! SUBROUTINE DQGaussRys ( ryscomp , cp , id , c , znuc , xyzin , igrd ) !dir$ attributes forceinline :: DQGaussRys TYPE ( shpair_t ), INTENT ( IN ) :: cp INTEGER , INTENT ( IN ) :: id REAL ( REAL64 ), INTENT ( IN ) :: c ( 3 ), znuc REAL ( REAL64 ), CONTIGUOUS , INTENT ( OUT ) :: xyzin ( 0 :, 0 :,:,:) INTEGER , INTENT ( IN ), OPTIONAL :: igrd type ( rys_root_t ), intent ( inout ) :: ryscomp INTEGER :: ni , nj , k , igrd1 REAL ( REAL64 ) :: ww , tt REAL ( REAL64 ) :: b , d ( 3 ), dij ( 3 ) !dir$ assume_aligned xyzin : 64 igrd1 = 1 IF ( present ( igrd )) igrd1 = igrd call ryscomp % evaluate () ASSOCIATE ( pp => cp % p ( id ), iang => cp % iang , jang => cp % jang ) dij = cp % rj - cp % ri DO k = 1 , ryscomp % nroots ww = ryscomp % w ( k ) * znuc * ryscomp % u ( k ) tt = ryscomp % u ( k ) / ( 1.0 + ryscomp % u ( k )) b = 0.5 * ( 1.0 - tt ) / pp % aa d = ( pp % r - cp % rj ) - tt * ( pp % r - c ) xyzin ( 0 , 0 , 1 , k ) = 1.0 xyzin ( 0 , 0 , 2 , k ) = 1.0 xyzin ( 0 , 0 , 3 , k ) = ww xyzin ( 1 , 0 , 1 , k ) = d ( 1 ) xyzin ( 1 , 0 , 2 , k ) = d ( 2 ) xyzin ( 1 , 0 , 3 , k ) = d ( 3 ) * ww ! VRR (Lj+1,0) <- Rpj*(Lj,0) + Lj*b*(Lj-1,0) DO nj = 2 , iang + jang + igrd1 xyzin ( nj , 0 ,:, k ) = d (:) * xyzin ( nj - 1 , 0 ,:, k ) + ( nj - 1 ) * b * xyzin ( nj - 2 , 0 ,:, k ) END DO ! HRR (Lj,Li+1) <- (Lj+1,Li) + Rij*(Lj,Li) nj = iang + jang + igrd1 DO ni = 1 , iang + igrd1 nj = nj - 1 xyzin ( 0 : nj , ni , 1 , k ) = xyzin ( 1 : nj + 1 , ni - 1 , 1 , k ) + dij ( 1 ) * xyzin ( 0 : nj , ni - 1 , 1 , k ) xyzin ( 0 : nj , ni , 2 , k ) = xyzin ( 1 : nj + 1 , ni - 1 , 2 , k ) + dij ( 2 ) * xyzin ( 0 : nj , ni - 1 , 2 , k ) xyzin ( 0 : nj , ni , 3 , k ) = xyzin ( 1 : nj + 1 , ni - 1 , 3 , k ) + dij ( 3 ) * xyzin ( 0 : nj , ni - 1 , 3 , k ) END DO END DO END ASSOCIATE END SUBROUTINE !> @brief Compute 1D integrals needed in calculation of the  Hellmann-Feynman !>  contribution to the gradient (Ewald long-range) !> @details They differ from the regular integrals !>  only by the \\f$ 2u&#94;2 \\f$ factor. Note, that 2*(ai+aj) factor is absent !>  here - it will be applied to the final gradient contribution !  TODO: !  Redesign Gauss-Rys quadrature code to handle both cases !> @note The common factor for the integral block is \\f$ 2\\Pi \\f$ !> @param[in]  nroots   roots for GaussRys !> @param[in]  cp       shell pair data !> @param[in]  id       current pair of primitives !> @param[in]  c        coordinates of the charged particle !> @param[in]  znuc     charge of the particle !> @param[in]  xfac     factor a*a/(p+a*a) !> @param[out] xyzin    array of 1D integrals !> @author   Vladimir Mironov ! !     REVISION HISTORY: !> @date _Sep, 2018_ Initial release ! SUBROUTINE DQGaussRysEw ( ryscomp , cp , id , c , znuc , xfac , xyzin ) !dir$ attributes forceinline :: DQGaussRys TYPE ( shpair_t ), INTENT ( IN ) :: cp INTEGER , INTENT ( IN ) :: id REAL ( REAL64 ), INTENT ( IN ) :: c ( 3 ), znuc , xfac REAL ( REAL64 ), CONTIGUOUS , INTENT ( OUT ) :: xyzin ( 0 :, 0 :,:,:) type ( rys_root_t ) :: ryscomp INTEGER :: ni , nj , k REAL ( REAL64 ) :: ww , tt REAL ( REAL64 ) :: b , d ( 3 ), dij ( 3 ) !dir$ assume_aligned xyzin : 64 call ryscomp % evaluate () ASSOCIATE ( pp => cp % p ( id ), iang => cp % iang , jang => cp % jang ) dij = cp % rj - cp % ri DO k = 1 , ryscomp % nroots ww = ryscomp % w ( k ) * znuc * ryscomp % u ( k ) tt = ryscomp % u ( k ) / ( 1.0 + ryscomp % u ( k )) * xfac b = 0.5 * ( 1.0 - tt ) / pp % aa d = ( pp % r - cp % rj ) - tt * ( pp % r - c ) xyzin ( 0 , 0 , 1 , k ) = 1.0 xyzin ( 0 , 0 , 2 , k ) = 1.0 xyzin ( 0 , 0 , 3 , k ) = ww xyzin ( 1 , 0 , 1 , k ) = d ( 1 ) xyzin ( 1 , 0 , 2 , k ) = d ( 2 ) xyzin ( 1 , 0 , 3 , k ) = d ( 3 ) * ww ! VRR (Lj+1,0) <- Rpj*(Lj,0) + Lj*b*(Lj-1,0) DO nj = 2 , iang + jang + 1 xyzin ( nj , 0 ,:, k ) = d (:) * xyzin ( nj - 1 , 0 ,:, k ) + ( nj - 1 ) * b * xyzin ( nj - 2 , 0 ,:, k ) END DO ! HRR (Lj,Li+1) <- (Lj+1,Li) + Rij*(Lj,Li) nj = iang + jang + 1 DO ni = 1 , iang + 1 nj = nj - 1 xyzin ( 0 : nj , ni , 1 , k ) = xyzin ( 1 : nj + 1 , ni - 1 , 1 , k ) + dij ( 1 ) * xyzin ( 0 : nj , ni - 1 , 1 , k ) xyzin ( 0 : nj , ni , 2 , k ) = xyzin ( 1 : nj + 1 , ni - 1 , 2 , k ) + dij ( 2 ) * xyzin ( 0 : nj , ni - 1 , 2 , k ) xyzin ( 0 : nj , ni , 3 , k ) = xyzin ( 1 : nj + 1 , ni - 1 , 3 , k ) + dij ( 3 ) * xyzin ( 0 : nj , ni - 1 , 3 , k ) END DO END DO END ASSOCIATE END SUBROUTINE !-------------------------------------------------------------------------------- !       GENERAL SUPPLEMENTARY ROUTINES !-------------------------------------------------------------------------------- !> @brief Add contribution of the 1e-integral block to the triangular matrix !> @param[in]       shi     first shell data !> @param[in]       shj     second shell data !> @param[in]       mblk    square block of 1e integrals passed as 1D array !> @param[inout]    m       packed triangular matrix of 1e integral contribution ! !> @author   Vladimir Mironov ! !     REVISION HISTORY: !> @date _Sep, 2018_ Initial release ! SUBROUTINE update_triang_matrix ( shi , shj , mblk , m ) TYPE ( shell_t ), INTENT ( IN ) :: shi , shj REAL ( REAL64 ), CONTIGUOUS , INTENT ( INOUT ) :: m (:) REAL ( REAL64 ), CONTIGUOUS , INTENT ( IN ) :: mblk (:) INTEGER :: i , j , nn , li , lj , mj , mi , jmax LOGICAL :: iandj !dir$ assume_aligned mblk : 64 iandj = shi % shid == shj % shid jmax = shj % nao - 1 nn = 0 DO i = 0 , shi % nao - 1 li = shi % locao + i mi = ( li * ( li - 1 )) / 2 IF ( iandj ) jmax = i DO j = 0 , jmax lj = shj % locao + j mj = lj + mi nn = nn + 1 m ( mj ) = m ( mj ) + mblk ( nn ) END DO END DO END SUBROUTINE !> @brief Add contribution of the 1e-integral block to the rectangular matrix !> @param[in]       shi     first shell data !> @param[in]       shj     second shell data !> @param[in]       mblk    square block of 1e integrals passed as 1D array !> @param[inout]    m       rectangular matrix of 1-e integral contribution ! !> @author   Igor S. Gerasimov ! !     REVISION HISTORY: !> @date _Oct, 2022_ Initial release ! SUBROUTINE update_rectangular_matrix ( shi , shj , mblk , m ) TYPE ( shell_t ), INTENT ( IN ) :: shi , shj REAL ( REAL64 ), CONTIGUOUS , INTENT ( INOUT ) :: m (:,:) REAL ( REAL64 ), CONTIGUOUS , INTENT ( IN ) :: mblk (:) INTEGER :: i , j , nn , li , lj !dir$ assume_aligned mblk : 64 nn = 0 DO i = 0 , shi % nao - 1 li = shi % locao + i DO j = 0 , shj % nao - 1 lj = shj % locao + j nn = nn + 1 m ( lj , li ) = m ( lj , li ) + mblk ( nn ) END DO END DO END SUBROUTINE !> @brief Copy density block from the triangular density matrix !> @details This subroutine assumes arbitrary order of shell IDs !> @param[in]       shi     first shell data !> @param[in]       shj     second shell data !> @param[in]       dij     density matrix in packed triangular form !> @param[out]      denab   density matrix block for shells shi and shj !> @note Used in TVDER-based subroutines ! !> @author   Vladimir Mironov ! !     REVISION HISTORY: !> @date _Sep, 2018_ Initial release ! SUBROUTINE density_unordered ( shi , shj , dij , denab ) TYPE ( shell_t ), INTENT ( IN ) :: shi , shj REAL ( REAL64 ), CONTIGUOUS , INTENT ( IN ) :: denab (:) REAL ( REAL64 ), CONTIGUOUS , INTENT ( OUT ) :: dij (:) INTEGER :: ij , i , j , nn , i0 , j0 ij = 0 DO i = 0 , shi % nao - 1 DO j = 0 , shj % nao - 1 ij = ij + 1 i0 = max ( shi % locao + i , shj % locao + j ) j0 = min ( shi % locao + i , shj % locao + j ) nn = ( i0 - 1 ) * i0 / 2 + j0 dij ( ij ) = 2 * denab ( nn ) END DO END DO END SUBROUTINE !> @brief Copy density block from the triangular density matrix !> @details This subroutine assumes `shi%shid>=shj%shid` !> @param[in]       shi     first shell data !> @param[in]       shj     second shell data !> @param[in]       dij     density matrix in packed triangular form !> @param[out]      denab   density matrix block for shells shi and shj !> @note Used in HELFEY-based subroutines ! !> @author   Vladimir Mironov ! !     REVISION HISTORY: !> @date _Sep, 2018_ Initial release ! SUBROUTINE density_ordered ( shi , shj , dij , denab ) TYPE ( shell_t ), INTENT ( IN ) :: shi , shj REAL ( REAL64 ), CONTIGUOUS , INTENT ( IN ) :: denab (:) REAL ( REAL64 ), CONTIGUOUS , INTENT ( OUT ) :: dij (:) INTEGER :: ij , i , j , nn , jmax , i0 , j0 REAL ( REAL64 ) :: den LOGICAL :: iandj iandj = shi % shid == shj % shid jmax = shj % nao - 1 ij = 0 DO i = 0 , shi % nao - 1 IF ( iandj ) jmax = i DO j = 0 , jmax ij = ij + 1 i0 = shi % locao + i j0 = shj % locao + j nn = ( i0 - 1 ) * i0 / 2 + j0 den = 2 * denab ( nn ) IF ( iandj . AND . i == j ) den = denab ( nn ) dij ( ij ) = den END DO END DO END SUBROUTINE !> @brief Compute double derivative of 1D Coulomb integral table !>        for PVP integrals: d²/d(bra_x) d(ket_x) of xyzin !> !> @details For each direction gamma and each Rys root k: !> !>   dxyz(j,i,gamma,k) = !>       4*ai*aj * xyzin(j+1, i+1, gamma, k) !>     - 2*ai*j  * xyzin(j-1, i+1, gamma, k)   ! j=0 => 0 !>     - 2*aj*i  * xyzin(j+1, i-1, gamma, k)   ! i=0 => 0 !>     +     i*j * xyzin(j-1, i-1, gamma, k)   ! i=0 or j=0 => 0 !> !>   where i = 0..li  (bra angular momentum) !>         j = 0..lj  (ket angular momentum) !> !> @param[in]  xyzin   1D Coulomb integral table, built with igrd=2 !> @param[in]  li      bra max angular momentum !> @param[in]  lj      ket max angular momentum !> @param[in]  ai      bra primitive exponent !> @param[in]  aj      ket primitive exponent !> @param[in]  nroots  number of Rys roots !> @param[out] dxyz    derivative table, same indexing as xyzin ! !> @author   Vladimir Makhnev ! subroutine pvp_xyz_ij ( xyzin , li , lj , ai , aj , nroots , dxyz ) !dir$ attributes forceinline :: pvp_xyz_ij implicit none real ( real64 ), contiguous , intent ( in ) :: xyzin ( 0 :, 0 :,:,:) real ( real64 ), contiguous , intent ( out ) :: dxyz ( 0 :, 0 :,:,:) real ( real64 ), intent ( in ) :: ai , aj integer , intent ( in ) :: li , lj , nroots integer :: i , j , k real ( real64 ) :: ai2 , aj2 ai2 = 2.0_real64 * ai aj2 = 2.0_real64 * aj do k = 1 , nroots ! i=0, j=0: only 4*ai*aj term survives dxyz ( 0 , 0 , :, k ) = ai2 * aj2 * xyzin ( 1 , 1 , :, k ) ! i=0, j>0: j-1 terms vanish ! only 4ai*aj and -2ai*j terms survive do j = 1 , lj dxyz ( j , 0 , :, k ) = ai2 * aj2 * xyzin ( j + 1 , 1 , :, k ) & - ai2 * j * xyzin ( j - 1 , 1 , :, k ) end do ! j=0, i>0: i-1 terms vanish ! only 4ai*aj and -2aj*i terms survive do i = 1 , li dxyz ( 0 , i , :, k ) = ai2 * aj2 * xyzin ( 1 , i + 1 , :, k ) & - aj2 * i * xyzin ( 1 , i - 1 , :, k ) end do ! general case i>0, j>0: all four terms do i = 1 , li do j = 1 , lj dxyz ( j , i , :, k ) = ai2 * aj2 * xyzin ( j + 1 , i + 1 , :, k ) & - ai2 * j * xyzin ( j - 1 , i + 1 , :, k ) & - aj2 * i * xyzin ( j + 1 , i - 1 , :, k ) & + real ( i * j , real64 ) * xyzin ( j - 1 , i - 1 , :, k ) end do end do end do end subroutine pvp_xyz_ij !> @brief Compute primitive block of PVP integrals !>        <mu | p . (-Z/|r-C|) . p | nu> !>        = <d(mu)/dx | -Z/|r-C| | d(nu)/dx> !>        + <d(mu)/dy | -Z/|r-C| | d(nu)/dy> !>        + <d(mu)/dz | -Z/|r-C| | d(nu)/dz> !> !> @param[in]     cp     shell pair data !> @param[in]     id     current pair of primitives !> @param[in]     c      coordinates of the nucleus !> @param[in]     znuc   nuclear charge (passed as -Z, same as coulomb) !> @param[inout]  pvpblk block of PVP integrals (accumulated) ! !> @author  Vladimir Makhnev ! subroutine comp_pvp_int1_prim ( cp , id , c , znuc , pvpblk ) !dir$ attributes inline :: comp_pvp_int1_prim implicit none type ( shpair_t ), intent ( in ) :: cp integer , intent ( in ) :: id real ( real64 ), intent ( in ) :: c ( 3 ), znuc real ( real64 ), contiguous , intent ( inout ) :: pvpblk (:) !dir$ assume_aligned pvpblk : 64 real ( real64 ) :: xyzin ( 0 : 2 * max_ang + 3 , 0 : max_ang + 2 , 3 , max_nroots + 1 ) real ( real64 ) :: dxyz ( 0 : 2 * max_ang + 3 , 0 : max_ang + 2 , 3 , max_nroots + 1 ) !dir$ assume_aligned xyzin : 64 !dir$ assume_aligned dxyz  : 64 type ( rys_root_t ) :: ryscomp integer :: i , j , ij , jmax integer :: nx , ny , nz , mx , my , mz integer :: nroots_pvp real ( real64 ) :: xx , dij , dum associate ( pp => cp % p ( id ), & iang => cp % iang , jang => cp % jang , & inao => cp % inao , jnao => cp % jnao ) nroots_pvp = cp % nroots + 1 xx = pp % aa * sum (( pp % r - c ) ** 2 ) ryscomp % nroots = nroots_pvp ryscomp % x = xx call QGaussRys ( ryscomp , cp , id , c , znuc , xyzin , 2 ) call pvp_xyz_ij ( xyzin , iang , jang , pp % ai , pp % aj , nroots_pvp , dxyz ) dij = pp % expfac * TWOPI * pp % aa1 ij = 0 jmax = jnao do i = 1 , inao nx = CART_X ( i , iang ) ny = CART_Y ( i , iang ) nz = CART_Z ( i , iang ) if ( cp % iandj ) jmax = i do j = 1 , jmax mx = CART_X ( j , jang ) my = CART_Y ( j , jang ) mz = CART_Z ( j , jang ) ij = ij + 1 ! (pVp) = p_x V p_x  +  p_y V p_y  +  p_z V p_z dum = sum ( dxyz ( mx , nx , 1 , 1 : nroots_pvp ) & ! d²/dx_bra dx_ket * xyzin ( my , ny , 2 , 1 : nroots_pvp ) & ! y: * xyzin ( mz , nz , 3 , 1 : nroots_pvp ) ) & ! z: + sum ( xyzin ( mx , nx , 1 , 1 : nroots_pvp ) & ! x: * dxyz ( my , ny , 2 , 1 : nroots_pvp ) & ! d²/dy_bra dy_ket * xyzin ( mz , nz , 3 , 1 : nroots_pvp ) ) & ! z: + sum ( xyzin ( mx , nx , 1 , 1 : nroots_pvp ) & ! x: * xyzin ( my , ny , 2 , 1 : nroots_pvp ) & ! y: * dxyz ( mz , nz , 3 , 1 : nroots_pvp ) ) ! d²/dz_bra dz_ket pvpblk ( ij ) = pvpblk ( ij ) + dij * dum end do end do end associate end subroutine comp_pvp_int1_prim !> @brief Build one-sided Gaussian derivative tables for SOC integrals !> @details !>   di(m,n) = 2*ai*xyzin(m,n+1) - n*xyzin(m,n-1)  [d/d bra, second index] !>   dj(m,n) = 2*aj*xyzin(m+1,n) - m*xyzin(m-1,n)  [d/d ket, first index] !> @param[in]  xyzin   1D Rys integral table (dims: (Lj,Li,XYZ,NRoots)) !> @param[in]  iang    angular momentum of bra shell !> @param[in]  jang    angular momentum of ket shell !> @param[in]  ai      exponent of bra primitive !> @param[in]  aj      exponent of ket primitive !> @param[in]  nroots  number of Rys roots !> @param[out] di      bra-side derivative table (dims: (Lj,Li,XYZ,NRoots)) !> @param[out] dj      ket-side derivative table (dims: (Lj,Li,XYZ,NRoots)) ! !> @author  Vladimir Makhnev !> @date    March 2026 subroutine soc_xyz_ij ( xyzin , iang , jang , ai , aj , nroots , di , dj ) !dir$ attributes forceinline :: soc_xyz_ij implicit none real ( real64 ), contiguous , intent ( in ) :: xyzin ( 0 :, 0 :, :, :) real ( real64 ), contiguous , intent ( out ) :: di ( 0 :, 0 :, :, :) real ( real64 ), contiguous , intent ( out ) :: dj ( 0 :, 0 :, :, :) integer , intent ( in ) :: iang , jang , nroots real ( real64 ), intent ( in ) :: ai , aj integer :: n !dir$ assume_aligned xyzin : 64 !dir$ assume_aligned di    : 64 !dir$ assume_aligned dj    : 64 ! bra derivative (second index): di(m,n) = n*xyzin(m,n-1) - 2*ai*xyzin(m,n+1) di ( 0 : jang , 0 : iang , 1 : 3 , 1 : nroots ) = - 2 * ai * xyzin ( 0 : jang , 1 : iang + 1 , 1 : 3 , 1 : nroots ) do n = 1 , iang di ( 0 : jang , n , 1 : 3 , 1 : nroots ) = di ( 0 : jang , n , 1 : 3 , 1 : nroots ) & + n * xyzin ( 0 : jang , n - 1 , 1 : 3 , 1 : nroots ) end do ! ket derivative (first index): dj(m,n) = m*xyzin(m-1,n) - 2*aj*xyzin(m+1,n) dj ( 0 : jang , 0 : iang , 1 : 3 , 1 : nroots ) = - 2 * aj * xyzin ( 1 : jang + 1 , 0 : iang , 1 : 3 , 1 : nroots ) do n = 1 , jang dj ( n , 0 : iang , 1 : 3 , 1 : nroots ) = dj ( n , 0 : iang , 1 : 3 , 1 : nroots ) & + n * xyzin ( n - 1 , 0 : iang , 1 : 3 , 1 : nroots ) end do end subroutine soc_xyz_ij !> @brief Compute primitive block of 1e SOC integrals for one nucleus !> @details Evaluates <mu|Z_eff*L/r_A&#94;3|nu> via IBP reduction to Coulomb !>  integrals with one-sided Gaussian derivatives: !>   Lx: <d/dy mu|1/r|d/dz nu> - <d/dz mu|1/r|d/dy nu> !>   Ly: <d/dz mu|1/r|d/dx nu> - <d/dx mu|1/r|d/dz nu> !>   Lz: <d/dx mu|1/r|d/dy nu> - <d/dy mu|1/r|d/dx nu> !> !> @param[in]     cp      shell pair data !> @param[in]     id      current pair of primitives !> @param[in]     c       nuclear coordinates !> @param[in]     znuc    effective nuclear charge Z_eff !> @param[inout]  socblk  accumulated SOC block (nfunc,3): Lx, Ly, Lz ! !> @author  Vladimir Makhnev !> @date    March 2026 subroutine comp_soc_int1_prim ( cp , id , c , znuc , socblk ) !dir$ attributes inline :: comp_soc_int1_prim implicit none type ( shpair_t ), intent ( in ) :: cp integer , intent ( in ) :: id real ( real64 ), intent ( in ) :: c ( 3 ), znuc real ( real64 ), contiguous , intent ( inout ) :: socblk (:, :) type ( rys_root_t ) :: ryscomp integer :: i , j , ij , jmax , nroots_soc integer :: nx , ny , nz , mx , my , mz real ( real64 ) :: dij , lx , ly , lz real ( real64 ) :: xyzin ( 0 : 2 * max_ang + 1 , 0 : max_ang + 1 , 3 , max_nroots + 1 ) real ( real64 ) :: di ( 0 : max_ang_pad , 0 : max_ang , 3 , max_nroots + 1 ) real ( real64 ) :: dj ( 0 : max_ang_pad , 0 : max_ang , 3 , max_nroots + 1 ) !dir$ assume_aligned xyzin  : 64 !dir$ assume_aligned socblk : 64 associate ( pp => cp % p ( id ), & iang => cp % iang , jang => cp % jang , & inao => cp % inao , jnao => cp % jnao ) ! nroots_soc = cp % nroots + 2 ryscomp % nroots = nroots_soc ryscomp % x = pp % aa * sum (( pp % r - c ) ** 2 ) call QGaussRys ( ryscomp , cp , id , c , znuc , xyzin , 2 ) call soc_xyz_ij ( xyzin , iang , jang , pp % ai , pp % aj , nroots_soc , di , dj ) dij = pp % expfac * TWOPI * pp % aa1 ij = 0 jmax = jnao do i = 1 , inao nx = CART_X ( i , iang ); ny = CART_Y ( i , iang ); nz = CART_Z ( i , iang ) if ( cp % iandj ) jmax = i do j = 1 , jmax mx = CART_X ( j , jang ); my = CART_Y ( j , jang ); mz = CART_Z ( j , jang ) ij = ij + 1 ! Lx = <d/dy mu|1/r|d/dz nu> - <d/dz mu|1/r|d/dy nu> lx = sum ( xyzin ( mx , nx , 1 , 1 : nroots_soc ) & * di ( my , ny , 2 , 1 : nroots_soc ) & * dj ( mz , nz , 3 , 1 : nroots_soc ) )& - sum ( xyzin ( mx , nx , 1 , 1 : nroots_soc ) & * di ( mz , nz , 3 , 1 : nroots_soc ) & * dj ( my , ny , 2 , 1 : nroots_soc ) ) ! Ly = <d/dz mu|1/r|d/dx nu> - <d/dx mu|1/r|d/dz nu> ly = sum ( xyzin ( my , ny , 2 , 1 : nroots_soc ) & * di ( mz , nz , 3 , 1 : nroots_soc ) & * dj ( mx , nx , 1 , 1 : nroots_soc ) )& - sum ( xyzin ( my , ny , 2 , 1 : nroots_soc ) & * di ( mx , nx , 1 , 1 : nroots_soc ) & * dj ( mz , nz , 3 , 1 : nroots_soc ) ) ! Lz = <d/dx mu|1/r|d/dy nu> - <d/dy mu|1/r|d/dx nu> lz = sum ( xyzin ( mz , nz , 3 , 1 : nroots_soc ) & * di ( mx , nx , 1 , 1 : nroots_soc ) & * dj ( my , ny , 2 , 1 : nroots_soc ) )& - sum ( xyzin ( mz , nz , 3 , 1 : nroots_soc ) & * di ( my , ny , 2 , 1 : nroots_soc ) & * dj ( mx , nx , 1 , 1 : nroots_soc ) ) socblk ( ij , 1 ) = socblk ( ij , 1 ) + dij * lx socblk ( ij , 2 ) = socblk ( ij , 2 ) + dij * ly socblk ( ij , 3 ) = socblk ( ij , 3 ) + dij * lz end do end do end associate end subroutine comp_soc_int1_prim ! 2e part starts here. !> @brief Compute 1D integrals for two-electron spin-orbit operator (4-centre ERI) !> @details Analogue of QGaussRys but for a Gaussian charge distribution !>   (shell pair cpkl) instead of a point nucleus.  The output gfull is the !>   4-index table !> !>     gfull(nj, ni, nl, nk, xyz, t) !>       = G_{ni,nj | nk,nl}&#94;{xyz} for Rys root t !> !>   after both electron-1 and electron-2 HRR transfers, exactly as !>   GAMESS XYZ2E builds XINT(1+NI+MAXP1*NJ, 1+NK+MAXP*NL). !> !>   Calling convention in comp_soc_int2_prim: !>     for each (k,l) subshell with angular powers (nxk,nyk,nzk), (nxl,nyl,nzl): !>       xyzin(nj,ni,1,t) = gfull(nj,ni,nxl,nxk,1,t) !>       xyzin(nj,ni,2,t) = gfull(nj,ni,nyl,nyk,2,t) !>       xyzin(nj,ni,3,t) = gfull(nj,ni,nzl,nzk,3,t) !>     call soc_xyz_ij(xyzin, ...) as in the 1e case. !> !>   Corresponds to GAMESS SOINT2 + XYZ2E. !> !> @param[inout] ryscomp   Rys object; caller sets nroots; x is set here !> @param[in]    cpij      shell pair electron 1 (bra=I, ket=J) !> @param[in]    idij      primitive index in cpij !> @param[in]    cpkl      shell pair electron 2 (bra=K, ket=L) !> @param[in]    idkl      primitive index in cpkl !> @param[out]   gfull     4-index integral table !>                         shape (0:jang+1, 0:iang+1, 0:lang, 0:kang, 3, nroots) SUBROUTINE QGaussRys2e ( ryscomp , cpij , idij , cpkl , idkl , gfull ) !dir$ attributes forceinline :: QGaussRys2e USE ISO_FORTRAN_ENV , ONLY : real64 USE mod_shell_tools , ONLY : shpair_t USE rys , ONLY : rys_root_t IMPLICIT NONE TYPE ( rys_root_t ), INTENT ( INOUT ) :: ryscomp TYPE ( shpair_t ), INTENT ( IN ) :: cpij , cpkl INTEGER , INTENT ( IN ) :: idij , idkl REAL ( real64 ), CONTIGUOUS , INTENT ( OUT ) :: gfull ( 0 :, 0 :, 0 :, 0 :, :, :) !dir$ assume_aligned gfull : 64 ! --- local constants --- REAL ( real64 ), PARAMETER :: PI252 = 3 4.986836655250_real64 ! 2*pi&#94;(5/2) ! --- local scalars --- INTEGER :: t , n , m , ni , nj , nk , nl , nmax REAL ( real64 ) :: f00 , aandb , rho REAL ( real64 ) :: b00 , b10 , bp01 , c10 , cp01 , cp10 , c01 REAL ( real64 ) :: expe REAL ( real64 ) :: c00 ( 3 ), cp00 ( 3 ), dij ( 3 ), dkl ( 3 ), pq ( 3 ) integer :: nj_e1 , ni_max , n_lo , n_hi ! --- intermediate 2D table (GAMESS-style packed: row=electron1, col=electron2) --- ! Dimensions: (0:maxij+1, 0:maxkl+1, 3) ! Row index N = NI + maxp1*NJ  where maxp1 = maxij+1 ! Col index M = NK + maxp *NL  where maxp  = maxkl+1 INTEGER :: maxij , maxkl , maxp1 , maxp INTEGER , PARAMETER :: ND52 = ( MAX_ANG + 2 ) ** 2 ! electron 1, row INTEGER , PARAMETER :: ND51 = ( MAX_ANG + 1 ) ** 2 ! electron 2, col REAL ( real64 ) :: g ( 0 : ND52 , 0 : ND51 , 3 ) ASSOCIATE ( ppij => cpij % p ( idij ), ppkl => cpkl % p ( idkl ), & iang => cpij % iang , jang => cpij % jang , & kang => cpkl % iang , lang => cpkl % jang ) ! ---------------------------------------------------------------- ! Geometry ! ---------------------------------------------------------------- aandb = ppij % aa + ppkl % aa rho = ppij % aa * ppkl % aa / aandb pq = ppij % r - ppkl % r ryscomp % x = rho * SUM ( pq ** 2 ) CALL ryscomp % evaluate () maxij = iang + jang + 1 ! = MAXIJ in GAMESS maxkl = kang + lang ! = MAXKL in GAMESS maxp1 = maxij + 1 ! MAX_ANG + 2 !maxij + 1          ! stride for NJ in row index maxp = maxkl + 1 ! MAX_ANG + 1 !maxkl + 1          ! stride for NL in col index !    print *, 'maxij=', maxij, ' maxp1=', maxp1, ' g size dim1=', maxij+2 ! Shifts for HRR (GAMESS: DXIJ, DXKL etc.) dij = cpij % ri - cpij % rj ! A - B dkl = cpkl % ri - cpkl % rj ! C - D ! Prefactor without Rys weight (GAMESS: EXPE without W(t)) expe = PI252 / ( ppij % aa * ppkl % aa * SQRT ( aandb )) & * EXP ( - ryscomp % x / rho ) ! ppij%expfac * ppkl%expfac !write(*,'(a,5e20.12)') 'OQP expe rho x ai aj:', & !    expe, rho, ryscomp%x, ppij%ai, ppij%aj !write(*,'(a,4e20.12)') 'OQP ak al aa bb:', & !    ppkl%ai, ppkl%aj, ppij%aa, ppkl%aa !write(*,'(a,2e20.12)') 'OQP Kij Kkl:', ppij%expfac, ppkl%expfac !    print *, 'DEBUG expe=', expe ! ---------------------------------------------------------------- ! Loop over Rys roots ! ---------------------------------------------------------------- DO t = 1 , ryscomp % nroots g = 0.0_real64 ! F00 = EXPE * W(t)  (GAMESS notation) f00 = expe * ryscomp % w ( t ) !if (t == 1) write(*,'(a,3e20.12)') 'OQP f00 w(1) t=1:', f00, ryscomp%w(t), ryscomp%u(t) ! VRR recurrence coefficients (GAMESS: B00, B10, BP01, XC00, XCP00) ! denom = 2*(aa*bb + u*rho*(aa+bb)) ASSOCIATE ( uu => ryscomp % u ( t )) b00 = uu * rho / ( 2 * ( ppij % aa * ppkl % aa + uu * rho * aandb )) b10 = ( ppkl % aa + uu * rho ) / ( 2 * ( ppij % aa * ppkl % aa + uu * rho * aandb )) bp01 = ( ppij % aa + uu * rho ) / ( 2 * ( ppij % aa * ppkl % aa + uu * rho * aandb )) END ASSOCIATE !        if (t==1) print *, 'b00=', b00, ' b10=', b10, ' bp01=', bp01 ! VRR centres c00 = ( ppij % r - cpij % ri ) + 2 * b00 * ppkl % aa * pq ! XC00 cp00 = ( ppkl % r - cpkl % ri ) - 2 * b00 * ppij % aa * pq ! XCP00 ! ---------------------------------------------------------------- ! Seed values  (GAMESS XYZ2E: XINT(1,1) etc.) ! In OQP packed: N=0 → NI=0,NJ=0; M=0 → NK=0,NL=0 ! z-component carries F00 (the Rys weight × prefactor) ! ---------------------------------------------------------------- g ( 0 , 0 , 1 ) = 1.0_real64 g ( 0 , 0 , 2 ) = 1.0_real64 g ( 0 , 0 , 3 ) = f00 g ( 1 , 0 , 1 ) = c00 ( 1 ) g ( 1 , 0 , 2 ) = c00 ( 2 ) g ( 1 , 0 , 3 ) = c00 ( 3 ) * f00 g ( 0 , 1 , 1 ) = cp00 ( 1 ) g ( 0 , 1 , 2 ) = cp00 ( 2 ) g ( 0 , 1 , 3 ) = cp00 ( 3 ) * f00 g ( 1 , 1 , 1 ) = c00 ( 1 ) * cp00 ( 1 ) + b00 g ( 1 , 1 , 2 ) = c00 ( 2 ) * cp00 ( 2 ) + b00 g ( 1 , 1 , 3 ) = ( c00 ( 3 ) * cp00 ( 3 ) + b00 ) * f00 !        if (t==1) print *, 'DEBUG g(0,0,3)=', g(0,0,3) !        if (t==1) print *, 'after seed g(1,1,1)=', g(1,1,1) !        if (t==1) print *, 'after seed g(1,1,3)=', g(1,1,3) ! ---------------------------------------------------------------- ! VRR for electron 1 (N increases, M=0 and M=1) ! GAMESS loop 30: C10 = 0; CP10 = B00 !   G(N+1,0) = C10*G(N-1,0) + C00*G(N,0)   [C10 = (N-1)*B10] !   G(N+1,1) = CP10*G(N,0)  + CP00*G(N+1,0) [CP10 = N*B00] ! ---------------------------------------------------------------- c10 = 0.0_real64 cp10 = b00 DO n = 2 , maxij c10 = c10 + b10 cp10 = cp10 + b00 g ( n , 0 , :) = c10 * g ( n - 2 , 0 , :) + c00 * g ( n - 1 , 0 , :) g ( n , 1 , :) = cp10 * g ( n - 1 , 0 , :) + cp00 * g ( n , 0 , :) END DO !        if (t==1) print *, 'after VRR1 g(0,0,3)=', g(0,0,3) !        if (t==1) print *, 'after VRR1 g(1,1,1)=', g(1,1,1) ! ---------------------------------------------------------------- ! VRR for electron 2 (M increases, N=0 and N=1) ! GAMESS loop 60: CP01 = 0; C01 = B00 !   G(0,M+1) = CP01*G(0,M-1) + CP00*G(0,M)   [CP01 = (M-1)*BP01] !   G(1,M+1) = C01*G(0,M)    + C00*G(0,M+1)  [C01  = M*B00] ! ---------------------------------------------------------------- cp01 = 0.0_real64 c01 = b00 DO m = 2 , maxkl cp01 = cp01 + bp01 c01 = c01 + b00 g ( 0 , m , :) = cp01 * g ( 0 , m - 2 , :) + cp00 * g ( 0 , m - 1 , :) g ( 1 , m , :) = c01 * g ( 0 , m - 1 , :) + c00 * g ( 0 , m , :) ! mixed recurrence for N >= 2  (GAMESS loop 50) ! G(N,M+1) = CP01*G(N,M-1) + CP10_m*G(N-1,M) + CP00*G(N,M) ! CP10_m starts at B00 and increments by B00 per N step cp10 = b00 nmax = MIN ( maxij , maxij + 2 - m ) DO n = 2 , nmax cp10 = cp10 + b00 g ( n , m , :) = cp01 * g ( n , m - 2 , :) + cp10 * g ( n - 1 , m - 1 , :) + cp00 * g ( n , m - 1 , :) END DO END DO !        if (t==1) print *, 'after VRR2 g(0,0,3)=', g(0,0,3) !        if (t==1) print *, 'after VRR2 g(1,1,1)=', g(1,1,1) ! ---------------------------------------------------------------- ! HRR for electron 1: transfer from NI to (NI, NJ) representation ! G(NI, NJ) = G(NI+1, NJ-1) + dij * G(NI, NJ-1) ! In packed form: g(NI + maxp1*NJ, M) = g(NI + maxp1*(NJ-1) + 1, M) !                                       + dij * g(NI + maxp1*(NJ-1), M) ! GAMESS: backward loop over NI is required. ! ---------------------------------------------------------------- DO nj = 1 , jang + 1 !            if (t==1 .and. nj==1) print *, 'HRR1 start nj=1 g(0,0,3)=', g(0,0,3) DO ni = maxij - nj , 0 , - 1 !                if (t==1) print *, 'HRR1 nj ni=', nj, ni, ' writes to', ni+maxp1*nj g ( ni + maxp1 * nj , 0 : maxkl , :) = & g ( ni + maxp1 * ( nj - 1 ) + 1 , 0 : maxkl , :) & + spread ( dij , 1 , maxkl + 1 ) * g ( ni + maxp1 * ( nj - 1 ), 0 : maxkl , :) END DO END DO !        if (t==1) print *, 'after HRR1 g(0,0,3)=', g(0,0,3) !        if (t==1) print *, 'after HRR1 g(1,1,1)=', g(1,1,1) ! ---------------------------------------------------------------- ! HRR for electron 2: transfer from NK to (NK, NL) representation ! G(NI_packed, NK, NL) = G(NI_packed, NK+1, NL-1) !                       + dkl * G(NI_packed, NK, NL-1) ! In col packed: g(N, NK + maxp*NL, :) = g(N, NK + maxp*(NL-1)+1, :) !                                        + dkl * g(N, NK+maxp*(NL-1), :) ! Loop over valid N values (all electron-1 packed indices). ! ---------------------------------------------------------------- !        DO nl = 1, lang !            DO nk = maxkl - nl, 0, -1 !                g(0:maxij, nk + maxp*nl, :) = & !                    g(0:maxij, nk + maxp*(nl-1) + 1, :) & !                  + SPREAD(dkl, 1, maxij+1) * g(0:maxij, nk + maxp*(nl-1), :) !            END DO !        END DO ! СТАЛО (все NJ строки как в GAMESS): DO nl = 1 , lang DO nk = maxkl - nl , 0 , - 1 DO nj_e1 = 0 , jang + 1 ni_max = MIN ( iang + 1 , maxij - nj_e1 ) IF ( ni_max < 0 ) EXIT n_lo = maxp1 * nj_e1 n_hi = ni_max + n_lo g ( n_lo : n_hi , nk + maxp * nl , :) = & g ( n_lo : n_hi , nk + maxp * ( nl - 1 ) + 1 , :) & + SPREAD ( dkl , 1 , ni_max + 1 ) * g ( n_lo : n_hi , nk + maxp * ( nl - 1 ), :) END DO END DO END DO !        if (t==1) print *, 'after HRR2 g(0,0,3)=', g(0,0,3) !        if (t==1) print *, 'after HRR2 g(1,1,1)=', g(1,1,1) ! ---------------------------------------------------------------- ! Extract into gfull(nj, ni, nl, nk, xyz, t) ! From packed: g(ni + maxp1*nj, nk + maxp*nl, xyz) ! ---------------------------------------------------------------- DO nl = 0 , lang DO nk = 0 , kang DO nj = 0 , jang + 1 DO ni = 0 , iang + 1 gfull ( nj , ni , nl , nk , :, t ) = g ( ni + maxp1 * nj , nk + maxp * nl , :) !g(nj + maxp1*ni, nl + maxp*nk, :) !g(ni + maxp1*nj, nk + maxp*nl, :) END DO END DO END DO END DO END DO ! Rys roots !write(*,'(a,e20.12)') 'OQP gfull(0,0,0,0,3,1) [F00]:', gfull(0,0,0,0,3,1) !write(*,'(a,e20.12)') 'OQP gfull(1,0,0,0,1,1) [C00x]:', gfull(1,0,0,0,1,1) !write(*,'(a,e20.12)') 'OQP gfull(0,0,1,0,1,1) [CP00x]:', gfull(0,0,1,0,1,1) !rite(*,'(a,e20.12)') 'OQP gfull(0,1,0,1,1,1) [B00x]:', gfull(0,1,0,1,1,1) END ASSOCIATE END SUBROUTINE QGaussRys2e !> @brief Two-electron SOC primitive integral over one primitive pair (idij, idkl) !> !> Computes the two-electron mean-field spin-orbit coupling contribution !> for a single pair of contracted primitives: !> !>   socblk(ij) += dij_factor * Lx(i,j,k,l)   summed over all (k,l) of electron 2 !> !> where Lx = <d/dy mu | 1/r12 | d/dz nu> - <d/dz mu | 1/r12 | d/dy nu> !> !> Correspondence with GAMESS SOINT2: !>   - QGaussRys2e  builds gfull  ←→  XYZ2E builds XINT/YINT/ZINT + XINTI/YINTJ etc. !>   - gfull(nj,ni,nl,nk,xyz,t)  ←→  XINT(1+ni+MAXP1*nj, 1+nk+MAXP*nl) !>   - loop over (i,j)           ←→  DO 7700 I / DO 7600 J !>   - loop over (k,l)           ←→  DO 7500 K / DO 7400 L !>   - lx formula                ←→  SOL(1) = (YINTI*ZINTJ - YINTJ*ZINTI)*XINT !>   - dij_factor                ←→  FACI*CONJ(J)*CONK(K)*PNRM(K)*CONL(L)*PNRM(L) !>                                   (EXPE is already inside gfull via F00) !> !> @param[in]    cpij    shell pair for electron 1 (bra=mu, ket=nu) !> @param[in]    idij    primitive index within cpij !> @param[in]    cpkl    shell pair for electron 2 (bra=lambda, ket=sigma) !> @param[in]    idkl    primitive index within cpkl !> @param[inout] socblk  accumulated block, shape (inao*jnao, 3) subroutine comp_soc_int2_prim ( cpij , idij , cpkl , idkl , socblk ) !dir$ attributes inline :: comp_soc_int2_prim use ISO_FORTRAN_ENV , only : real64 use mod_shell_tools , only : shpair_t use rys , only : rys_root_t use constants , only : CART_X , CART_Y , CART_Z , MAX_ANG => BAS_MXANG implicit none type ( shpair_t ), intent ( in ) :: cpij , cpkl integer , intent ( in ) :: idij , idkl real ( real64 ), contiguous , intent ( inout ) :: socblk (:, :) type ( rys_root_t ) :: ryscomp integer :: nroots_2e ! gfull(nj, ni, nl, nk, xyz, t) after VRR+HRR+unpack real ( real64 ) :: gfull ( 0 : MAX_ANG + 1 , 0 : MAX_ANG + 1 , 0 : MAX_ANG , 0 : MAX_ANG , 3 , ( 2 * MAX_ANG + 1 ) / 2 + 2 ) ! derivatives for electron 1 (same arrays as comp_soc_int1_prim) integer , parameter :: MAX_ANG_PAD = MAX_ANG + 1 integer , parameter :: MAX_NROOTS = ( 2 * MAX_ANG + 1 ) / 2 + 2 real ( real64 ) :: xyzin ( 0 : MAX_ANG + 1 , 0 : MAX_ANG + 1 , 3 , MAX_NROOTS ) real ( real64 ) :: di ( 0 : MAX_ANG_PAD , 0 : MAX_ANG , 3 , MAX_NROOTS ) real ( real64 ) :: dj ( 0 : MAX_ANG_PAD , 0 : MAX_ANG , 3 , MAX_NROOTS ) !dir$ assume_aligned gfull  : 64 !dir$ assume_aligned socblk : 64 ! loop indices integer :: i , j , ij , jmax integer :: k , l , lmax integer :: nxi , nyi , nzi ! Cartesian powers of function i (bra electron 1) integer :: nxj , nyj , nzj ! Cartesian powers of function j (ket electron 1) integer :: nxk , nyk , nzk ! Cartesian powers of function k (bra electron 2) integer :: nxl , nyl , nzl ! Cartesian powers of function l (ket electron 2) ! prefactor and SOC components real ( real64 ) :: dij_fac ! EXPE is inside gfull; this carries contraction coeff only real ( real64 ) :: lx , ly , lz associate ( ppij => cpij % p ( idij ), ppkl => cpkl % p ( idkl ), & iang => cpij % iang , jang => cpij % jang , & inao => cpij % inao , jnao => cpij % jnao , & kang => cpkl % iang , lang => cpkl % jang , & knao => cpkl % inao , lnao => cpkl % jnao ) ! Number of Rys roots: total angular momentum of all four shells + 1 ! GAMESS: NROOTS = MAXNM/2 + 1 where MAXNM = ILAM+JLAM+KLAM+LLAM+1 nroots_2e = ( iang + jang + kang + lang + 1 ) / 2 + 1 ryscomp % nroots = nroots_2e ! Build the 4-index 1D integral table via Rys quadrature + VRR + HRR ! GAMESS equivalent: XYZ2E → XINT(N,M), YINT(N,M), ZINT(N,M) call QGaussRys2e ( ryscomp , cpij , idij , cpkl , idkl , gfull ) !    if (iang==1 .and. jang==0 .and. kang==0 .and. idij==1 .and. idkl==1) then !      write(6,'(a,3e20.12)') 'OQP gfull 00/10/01:', & !      gfull(0,0,0,0,3,1), &   ! ZINT(1,1) = F00 !      gfull(0,1,0,0,1,1), &   ! XINT(2,1) = XC00 !      gfull(0,0,0,1,1,1)      ! XINT(1,2) = XCP00 !    endif ! Contraction prefactor for electron 1 primitive pair ! GAMESS: FACI*CONJ(J) are absorbed here; CONK*PNRM(K)*CONL*PNRM(L) go in (k,l) loop ! In OQP: pp%expfac already contains exp(-ai*aj/aa * |A-B|&#94;2) * (pi/aa)&#94;1.5 !         EXPE is inside gfull (built into F00 = EXPE * w_t) !         So dij_fac here = 1.0 — all factors are already in gfull !         This mirrors how comp_soc_int1_prim uses dij = pp%expfac * TWOPI * pp%aa1 ! EXPE is already inside gfull via F00 = EXPE*w(t) in QGaussRys2e. ! Contraction coefficients are applied in the outer loop (compute_som2e_ao). dij_fac = cpij % p ( idij )% expfac * cpkl % p ( idkl )% expfac ! 1.0_real64 ! --- Loop over subshell indices of electron 1 (GAMESS: DO 7700 I / DO 7600 J) --- ij = 0 jmax = jnao do i = 1 , inao nxi = CART_X ( i , iang ); nyi = CART_Y ( i , iang ); nzi = CART_Z ( i , iang ) ! GAMESS: if IIEQJJ then JJMAX = I-1 (handled by cp%iandj in OQP) if ( cpij % iandj ) jmax = i - 1 do j = 1 , jmax nxj = CART_X ( j , jang ); nyj = CART_Y ( j , jang ); nzj = CART_Z ( j , jang ) ij = ij + 1 !            write(*,'(a,4i4)') 'DBG i j ij jmax=', i, j, ij, jmax ! Extract xyzin slice for this (i,j) pair from gfull: ! xyzin(nxl, nxk, 1, t) = gfull(nxj, nxi, nxl, nxk, 1, t) ! This replaces the XINT(NXX, MX) lookup in GAMESS ! --- Loop over subshell indices of electron 2 (GAMESS: DO 7500 K / DO 7400 L) --- lx = 0.0_real64 ; ly = 0.0_real64 ; lz = 0.0_real64 !       write(*,'(a,3i4,e14.6)') 'DBG i j ij lx=', i, j, ij, lx do k = 1 , knao nxk = CART_X ( k , kang ); nyk = CART_Y ( k , kang ); nzk = CART_Z ( k , kang ) ! GAMESS: if KKEQLL then LLMAX = K lmax = lnao if ( cpkl % iandj ) lmax = k do l = 1 , lmax nxl = CART_X ( l , lang ); nyl = CART_Y ( l , lang ); nzl = CART_Z ( l , lang ) ! Build xyzin for this (k,l) pair by taking the appropriate slice of gfull ! GAMESS: MX=1+NX(K)+MAXP*NX(L), then XINT(NXX,MX) = gfull(nyj,nyi,nyl,nyk,2,t) ! ! xyzin(nxl, nxk, xyz, t) = gfull(nxj, nxi, nxl, nxk, xyz, t) ! but we need to build derivatives di, dj from xyzin first. ! Here we directly use gfull elements in the Lx formula, ! following GAMESS: SOL(1) = (YINTI(NYY,MY)*ZINTJ(NZZ,MZ) !                           - YINTJ(NYY,MY)*ZINTI(NZZ,MZ)) * XINT(NXX,MX) ! ! In OQP notation (after soc_xyz_ij on the (nxl,nxk) slice): !   XINT(NXX,MX) = gfull(nxj, nxi, nxl, nxk, 1, t)   (no derivative) !   YINTI(NYY,MY)= derivative of gfull w.r.t. bra-y on electron 1 !   ZINTJ(NZZ,MZ)= derivative w.r.t. ket-z on electron 1 ! Build xyzin for this (k,l) pair: three separate slices of gfull, ! one per Cartesian component. Each component uses its own (nl,nk) index. ! GAMESS: MX=1+NX(K)+MAXP*NX(L) selects col in XINT/YINT/ZINT. !   xyzin(:,:,1,:) <- gfull(:,:, nxl, nxk, 1, :) !   xyzin(:,:,2,:) <- gfull(:,:, nyl, nyk, 2, :) !   xyzin(:,:,3,:) <- gfull(:,:, nzl, nzk, 3, :) xyzin ( 0 : jang + 1 , 0 : iang + 1 , 1 , 1 : nroots_2e ) = & gfull ( 0 : jang + 1 , 0 : iang + 1 , nxl , nxk , 1 , 1 : nroots_2e ) xyzin ( 0 : jang + 1 , 0 : iang + 1 , 2 , 1 : nroots_2e ) = & gfull ( 0 : jang + 1 , 0 : iang + 1 , nyl , nyk , 2 , 1 : nroots_2e ) xyzin ( 0 : jang + 1 , 0 : iang + 1 , 3 , 1 : nroots_2e ) = & gfull ( 0 : jang + 1 , 0 : iang + 1 , nzl , nzk , 3 , 1 : nroots_2e ) ! Build derivatives di(m,n) = n*xyzin(m,n-1) - 2*ai*xyzin(m,n+1)  [bra] !              and dj(m,n) = m*xyzin(m-1,n) - 2*aj*xyzin(m+1,n)  [ket] ! GAMESS: YINTI(NYY,MY) = NI*YINT(NI-1,MY) - 2*AI*YINT(NI+1,MY) call soc_xyz_ij ( xyzin , iang , jang , ppij % ai , ppij % aj , nroots_2e , di , dj ) !if (iang==1 .and. jang==0 .and. kang==0 .and. idij==1 .and. idkl==1) then !  write(6,'(a,4i3,6e16.8)') 'OQP di/dj i/j/k/l=', i,j,k,l, & !    di(nyj,nyi,2,1), dj(nyj,nyi,2,1), & !    di(nzj,nzi,3,1), dj(nzj,nzi,3,1), & !    di(nxj,nxi,1,1), dj(nxj,nxi,1,1) !endif ! --- Lx, Ly, Lz (GAMESS: SOL(1), SOL(2), SOL(3)) --- ! SOL(1) = (YINTI(NYY,MY)*ZINTJ(NZZ,MZ) - YINTJ(NYY,MY)*ZINTI(NZZ,MZ)) !        * XINT(NXX,MX) ! In OQP: !   XINT(NXX,MX)   = sum_t xyzin(nxj,nxi,1,t)   [no derivative] !   YINTI(NYY,MY)  = sum_t di(nyj,nyi,2,t) !   ZINTJ(NZZ,MZ)  = sum_t dj(nzj,nzi,3,t) !   YINTJ(NYY,MY)  = sum_t dj(nyj,nyi,2,t) !   ZINTI(NZZ,MZ)  = sum_t di(nzj,nzi,3,t) lx = lx + sum ( xyzin ( nxj , nxi , 1 , 1 : nroots_2e ) & * di ( nyj , nyi , 2 , 1 : nroots_2e ) & * dj ( nzj , nzi , 3 , 1 : nroots_2e ) )& - sum ( xyzin ( nxj , nxi , 1 , 1 : nroots_2e ) & * di ( nzj , nzi , 3 , 1 : nroots_2e ) & * dj ( nyj , nyi , 2 , 1 : nroots_2e ) ) ly = ly + sum ( xyzin ( nyj , nyi , 2 , 1 : nroots_2e ) & * di ( nzj , nzi , 3 , 1 : nroots_2e ) & * dj ( nxj , nxi , 1 , 1 : nroots_2e ) )& - sum ( xyzin ( nyj , nyi , 2 , 1 : nroots_2e ) & * di ( nxj , nxi , 1 , 1 : nroots_2e ) & * dj ( nzj , nzi , 3 , 1 : nroots_2e ) ) lz = lz + sum ( xyzin ( nzj , nzi , 3 , 1 : nroots_2e ) & * di ( nxj , nxi , 1 , 1 : nroots_2e ) & * dj ( nyj , nyi , 2 , 1 : nroots_2e ) )& - sum ( xyzin ( nzj , nzi , 3 , 1 : nroots_2e ) & * di ( nyj , nyi , 2 , 1 : nroots_2e ) & * dj ( nxj , nxi , 1 , 1 : nroots_2e ) ) !                    if (iang==1 .and. jang==0 .and. kang==0 .and. idij==1 .and. idkl==1) then !                      write(6,'(a,4i3,3e20.12)') 'OQP lx/ly/lz i/j/k/l=', i,j,k,l, lx,ly,lz !                    endif end do ! l end do ! k !if (idij==1 .and. idkl==1 .and. i==2 .and. j==1) then !    write(*,'(a,3e14.6)') 'OQP lx ly lz:', lx, ly, lz !end if ! Accumulate into socblk ! GAMESS: SO2AO -= TDENFC * SOL  where TDENFC = FACK*CONL*PNRM(L) ! In OQP: dij_fac carries the primitive prefactor; contraction !         weights from p_kl are applied in the outer loop (compute_som2e_ao) socblk ( ij , 1 ) = socblk ( ij , 1 ) - dij_fac * lx socblk ( ij , 2 ) = socblk ( ij , 2 ) - dij_fac * ly socblk ( ij , 3 ) = socblk ( ij , 3 ) - dij_fac * lz end do ! j end do ! i end associate end subroutine comp_soc_int2_prim ! 2e part ends here. END MODULE","tags":"","url":"sourcefile/mod_1e_primitives.f90.html"},{"title":"otr_interface.F90 – OpenQP Fortran API","text":"Source Code !> @brief Thin interface between OpenQP and OpenTrustRegion. !> @detail Provides callback glue so OpenTrustRegion’s generic trust-region !>         optimizer can drive OpenQP’s TRAH SCF updates without requiring !>         an external solver class. Exposes: !>           - init_trah_solver: bind OpenQP state to module pointers !>           - run_trah_solver : configure and invoke the OTR solver !>           - update_orbs     : objective/gradient/Hdiag callback !>           - hess_x_cb       : Hessian–vector product callback !>           - obj_func        : energy-only evaluation (trial move) !>           - logger          : forwards OTR log lines to OpenQP I/O !> @author Mohsen Mazaherifar !> @date August 2025 module otr_interface use , intrinsic :: iso_c_binding , only : c_bool use opentrustregion , only : solver , update_orbs_type ,& obj_func_type , hess_x_type , logger_type , rp , ip , & solver_settings_type , stability_settings_type , & default_solver_settings use mathlib , only : unpack_matrix use scf_converger , only : trah_converger , scf_conv_trah_result , scf_conv_result use scf_addons , only : compute_energy , calc_fock use precision , only : dp use types , only : information use mod_dft_molgrid , only : dft_grid_t use basis_tools , only : basis_set use guess , only : get_ab_initio_density use scf_addons , only : scf_energy_t implicit none ! Module-level state for callbacks class ( information ), pointer :: infos ! OpenQP information object type ( dft_grid_t ), pointer :: molgrid type ( trah_converger ), pointer :: conv type ( scf_energy_t ), pointer :: energy integer :: iter_otr real ( dp ) :: grad_norm real ( dp ), allocatable :: work1 (:,:), work2 (:,:) contains !> @brief Initialize the OTR–OpenQP bridge and working buffers. !> @detail Stores references to OpenQP objects (infos, molgrid, TRAH converger, !>         energy accumulator), allocates temporary work arrays, and zeros the !>         incremental Fock/Density buffers used for ΔD updates. !> @param[inout] infos_in   OpenQP information/control object (target). !> @param[in]    molgrid_in DFT molecular grid (target). !> @param[inout] conv_in    TRAH converger (provides MO/D/Fock buffers). !> @param[inout] energy_in  SCF energy structure to be updated. !> @author Mohsen Mazaherifar !> @date August 2025 subroutine init_trah_solver ( infos_in , molgrid_in , conv_in , energy_in ) class ( information ), intent ( inout ), target :: infos_in type ( dft_grid_t ), intent ( in ), target :: molgrid_in class ( trah_converger ), intent ( inout ), target :: conv_in class ( scf_energy_t ), intent ( inout ), target :: energy_in type ( basis_set ), pointer :: basis ! Initialize module state infos => infos_in molgrid => molgrid_in conv => conv_in energy => energy_in iter_otr = 0 basis => infos % basis allocate ( work1 ( conv % nbf , conv % nbf ), work2 ( conv % nbf , conv % nbf )) conv % f_old = 0.0_dp conv % d_old = 0.0_dp end subroutine init_trah_solver !> @brief Configure and run the OpenTrustRegion driver. !> @detail Wires the required callbacks (`update_orbs`, `obj_func`, `logger`), !>         maps OpenQP control flags to OTR options (stability, line-search, !>         Davidson/Jacobi–Davidson, trust-radius settings), executes the solve, !>         and returns iteration/error status in `res`. !> @param[inout] res  Output SCF converger result (TRAH-specific fields filled). !> @note Updates the active OpenQP buffers (MO/Fock) upon return. !> @author Mohsen Mazaherifar !> @date August 2025 subroutine run_trah_solver ( res ) procedure ( update_orbs_type ), pointer :: p_update procedure ( obj_func_type ), pointer :: p_obj procedure ( logger_type ), pointer :: p_log class ( scf_conv_result ), intent ( inout ) :: res type ( solver_settings_type ) :: settings logical ( kind = 4 ) :: stability , line_search , davidson ,& jacobi_davidson , prefer_jacobi_davidson integer ( ip ) :: error , n_random_trial_vectors , n_micro ,& n_param , max_iter , verbose real ( dp ) :: start_trust_radius , global_red_factor ,& local_red_factor , conv_tol n_param = conv % n_param max_iter = int ( infos % control % maxit , kind = ip ) conv_tol = real ( infos % control % conv , kind = rp ) verbose = int ( 3 , kind = ip ) settings = default_solver_settings settings % conv_tol = conv_tol settings % verbose = verbose settings % stability = ( infos % control % trh_stab . eqv . . true . _ c_bool ) settings % line_search = ( infos % control % trh_ls . eqv . . true . _ c_bool ) select case ( infos % control % trh_sub_solver ) case ( 0 ) settings % subsystem_solver = \"davidson\" case ( 1 ) settings % subsystem_solver = \"jacobi_davidson\" case ( 2 ) settings % subsystem_solver = \"tcg\" case default error stop \"Invalid trh_sub_solver value\" end select settings % n_random_trial_vectors = int ( infos % control % trh_nrtv , kind = ip ) settings % start_trust_radius = real ( infos % control % trh_r0 , kind = ip ) settings % jacobi_davidson_start = int ( infos % control % trh_jd_start , kind = ip ) settings % global_red_factor = real ( infos % control % trh_gred , kind = rp ) settings % local_red_factor = real ( infos % control % trh_lred , kind = rp ) settings % n_macro = max_iter settings % n_micro = int ( infos % control % trh_nmic , kind = ip ) settings % logger => logger call print_trah_settings ( settings ) ! Bind callbacks p_update => update_orbs p_obj => obj_func call solver ( p_update , p_obj , n_param , error , settings ) conv % dat % buffer ( conv % dat % slot )% mo_a = conv % mo_a conv % dat % buffer ( conv % dat % slot )% focks = conv % fock_ao if ( infos % control % scftype > 1 ) then conv % dat % buffer ( conv % dat % slot )% mo_b = conv % mo_b end if select type ( res ) class is ( scf_conv_trah_result ) res % iter = iter_otr end select if ( error /= 0 ) then write ( * , * ) 'OpenTrustRegion solver failed.' res % ierr = 4 select type ( res ) class is ( scf_conv_trah_result ) res % iter = max_iter end select else if ( grad_norm > conv_tol ) then write ( * , * ) 'Trust radius too small. Convergence criterion& is not fulfilled but calculation should be converged up to floating& point precision.' res % error = min ( conv_tol * 0.99 , grad_norm ) else res % error = grad_norm end if endif if ( allocated ( work1 )) deallocate ( work1 ) if ( allocated ( work2 )) deallocate ( work2 ) end subroutine run_trah_solver !> @brief Objective/gradient/Hessian-diagonal callback used by OTR. !> @detail Applies orbital rotations `kappa` to (α[,β]) MOs, rebuilds densities, !>         constructs Fock via `calc_fock` (using incremental ΔD/ΔF when available), !>         then forms orbital-rotation gradient and Hessian diagonal with !>         `conv%calc_g_h`. Also binds the Hessian–vector product callback. !> @param[in]   kappa    Packed rotation vector(s). !> @param[out]  func     Objective value (total electronic energy). !> @param[out]  grad     Objective gradient in rotation coordinates. !> @param[out]  h_diag   Diagonal of approximate Hessian in rotation space. !> @param[out]  hess_x_funptr Pointer to Hessian–vector product routine. !> @author Mohsen Mazaherifar !> @date August 2025 subroutine update_orbs ( kappa , func , grad , h_diag , hess_x_funptr , error ) real ( dp ), intent ( in ), target :: kappa (:) real ( dp ), intent ( out ) :: func real ( dp ), intent ( out ), target :: grad (:), h_diag (:) procedure ( hess_x_type ), intent ( out ), pointer :: hess_x_funptr integer ( ip ), intent ( out ) :: error type ( basis_set ), pointer :: basis integer :: nschwz basis => infos % basis iter_otr = iter_otr + 1 ! Rotate orbitals select case ( infos % control % scftype ) case ( 1 ) call conv % rotate_orbs ( kappa , conv % nbf , conv % nocc_a , conv % mo_a ) call get_ab_initio_density ( conv % dens (:, 1 ), conv % mo_a , conv % dens (:, 1 ), conv % mo_a , infos , basis ) call calc_fock ( basis , infos , molgrid , conv % fock_ao , energy , conv % mo_a , conv % dens , conv % mo_b , nschwz , conv % f_old , conv % d_old ) call conv % calc_g_h ( grad , h_diag ) case ( 2 ) call conv % rotate_orbs ( kappa ( 1 : conv % nocc_a * conv % nvir_a ), conv % nbf , conv % nocc_a , conv % mo_a ) call conv % rotate_orbs ( kappa ( conv % nocc_a * conv % nvir_a + 1 :), conv % nbf , conv % nocc_b , conv % mo_b ) call get_ab_initio_density ( conv % dens (:, 1 ), conv % mo_a , conv % dens (:, 2 ), conv % mo_b , infos , basis ) call calc_fock ( basis , infos , molgrid , conv % fock_ao , energy , conv % mo_a , conv % dens , conv % mo_b , nschwz , conv % f_old , conv % d_old ) call conv % calc_g_h ( grad , h_diag ) case ( 3 ) call conv % rotate_orbs ( kappa , conv % nbf , conv % nocc_a , conv % mo_a ) conv % mo_b = conv % mo_a call get_ab_initio_density ( conv % dens (:, 1 ), conv % mo_a , conv % dens (:, 2 ), conv % mo_b , infos , basis ) call calc_fock ( basis , infos , molgrid , conv % fock_ao , energy , conv % mo_a , conv % dens , conv % mo_b , nschwz , conv % f_old , conv % d_old ) call conv % calc_g_h ( grad , h_diag ) end select grad_norm = sqrt ( dot_product ( grad , grad ) / conv % n_param ) func = compute_energy ( energy ) conv % etot = func hess_x_funptr => hess_x_cb h_diag = 2.0_dp * h_diag grad = 2.0_dp * grad end subroutine update_orbs !> @brief hess_x_cb. !> @author Mohsen Mazaherifar !> @date August 2025 subroutine hess_x_cb ( x , hx , error ) real ( dp ), intent ( in ), target :: x (:) real ( dp ), intent ( out ), target :: hx (:) integer ( ip ), intent ( out ) :: error call conv % calc_h_op ( infos , x , hx ) hx = 2.0_dp * hx end subroutine hess_x_cb !> @brief Energy-only objective for a trial move (no gradient). !> @detail Rotates temporary copies of the MOs according to `kappa`, rebuilds !>         densities, recomputes Fock and energies, and returns the total energy. !>         Used by line-search/auxiliary steps in OTR. !> @param[in]  kappa  Packed rotation vector(s). !> @return     val    Total electronic energy at the trial point. !> @author Mohsen Mazaherifar !> @date August 2025 function obj_func ( kappa , error ) result ( val ) real ( dp ), intent ( in ), target :: kappa (:) integer ( ip ), intent ( out ) :: error real ( dp ) :: val type ( basis_set ), pointer :: basis integer :: nschwz basis => infos % basis select case ( infos % control % scftype ) case ( 1 ) work1 = conv % mo_a call conv % rotate_orbs ( kappa , conv % nbf , conv % nocc_a , work1 ) call get_ab_initio_density ( conv % dens (:, 1 ), work1 , conv % dens (:, 1 ), work1 , infos , basis ) call calc_fock ( basis , infos , molgrid , conv % fock_ao , energy , work1 , conv % dens , work1 , nschwz , conv % f_old , conv % d_old ) case ( 2 ) work1 = conv % mo_a work2 = conv % mo_b call conv % rotate_orbs ( kappa ( 1 : conv % nvir_a * conv % nocc_a ), conv % nbf , conv % nocc_a , work1 ) call conv % rotate_orbs ( kappa ( conv % nvir_a * conv % nocc_a + 1 :), conv % nbf , conv % nocc_b , work2 ) call get_ab_initio_density ( conv % dens (:, 1 ), work1 , conv % dens (:, 2 ), work2 , infos , basis ) call calc_fock ( basis , infos , molgrid , conv % fock_ao , energy , work1 , conv % dens , work2 , nschwz , conv % f_old , conv % d_old ) case ( 3 ) work1 = conv % mo_a work2 = conv % mo_b call conv % rotate_orbs ( kappa , conv % nbf , conv % nocc_a , work1 ) work2 = work1 call get_ab_initio_density ( conv % dens (:, 1 ), work1 , conv % dens (:, 2 ), work2 , infos , basis ) call calc_fock ( basis , infos , molgrid , conv % fock_ao , energy , work1 , conv % dens , work2 , nschwz , conv % f_old , conv % d_old ) end select val = compute_energy ( energy ) end function obj_func subroutine logger ( message ) use io_constants , only : IW implicit none character ( * ), intent ( in ) :: message write ( IW , \"(A)\" ) trim ( message ) end subroutine subroutine print_trah_settings ( settings ) use io_constants , only : IW implicit none type ( solver_settings_type ), intent ( in ) :: settings write ( IW , '(5X, a)' ) \"----------------------------------------\" write ( IW , '(6X, a)' ) \"TRAH / Trust-Region Augmented Hessian Settings\" write ( IW , '(5X, a)' ) \"----------------------------------------\" write ( IW , '(7X, a, es12.5)' ) \"conv_tol                : \" , settings % conv_tol write ( IW , '(7X, a, i0)' ) \"verbose                 : \" , settings % verbose write ( IW , '(7X, a, l1)' ) \"stability               : \" , settings % stability write ( IW , '(7X, a, l1)' ) \"line_search             : \" , settings % line_search write ( IW , '(7X, a, a)' ) \"subsystem_solver        : \" , & trim ( settings % subsystem_solver ) write ( IW , '(7X, a, i0)' ) \"n_random_trial_vectors  : \" , & settings % n_random_trial_vectors write ( IW , '(7X, a, es12.5)' ) \"start_trust_radius      : \" , & settings % start_trust_radius write ( IW , '(7X, a, i0)' ) \"jacobi_davidson_start   : \" , & settings % jacobi_davidson_start write ( IW , '(7X, a, es12.5)' ) \"global_red_factor       : \" , & settings % global_red_factor write ( IW , '(7X, a, es12.5)' ) \"local_red_factor        : \" , & settings % local_red_factor write ( IW , '(7X, a, i0)' ) \"n_macro                 : \" , settings % n_macro write ( IW , '(7X, a, i0)' ) \"n_micro                 : \" , settings % n_micro write ( IW , '(5X, a)' ) \"----------------------------------------\" flush ( IW ) end subroutine print_trah_settings end module otr_interface","tags":"","url":"sourcefile/otr_interface.f90.html"},{"title":"dft_partfunc.F90 – OpenQP Fortran API","text":"Source Code module mod_dft_partfunc use precision , only : fp implicit none !> @brief Interface for func: double -> double abstract interface pure real ( KIND = fp ) function func_d_d ( x ) import real ( KIND = fp ), intent ( IN ) :: x end function func_d_d end interface !> @brief Type for partition function calculation type partition_function !< Values beyond (-limit,+limit) interval considered as 0.0 or 1.0 real ( KIND = fp ) :: limit = 1.0_fp !< Compute partition function value procedure ( func_d_d ), nopass , pointer :: eval !< Compute partition function derivative procedure ( func_d_d ), nopass , pointer :: deriv contains procedure :: set => set_partition_function end type integer , parameter :: PTYPE_SSF = 0 integer , parameter :: PTYPE_ERF = 1 integer , parameter :: PTYPE_BECKE4 = 2 integer , parameter :: PTYPE_SMSTP2 = 3 integer , parameter :: PTYPE_SMSTP3 = 4 integer , parameter :: PTYPE_SMSTP4 = 5 integer , parameter :: PTYPE_SMSTP5 = 6 integer , parameter :: PTYPE_BECKE3 = 7 private public partition_function public PTYPE_BECKE4 public PTYPE_BECKE3 public PTYPE_SSF public PTYPE_ERF public PTYPE_SMSTP2 public PTYPE_SMSTP3 public PTYPE_SMSTP4 public PTYPE_SMSTP5 !******************************************************************************* contains !> @brief Becke's partition function (4th order) pure function partf_eval_becke4 ( x ) result ( f ) real ( KIND = fp ) :: f real ( KIND = fp ), intent ( IN ) :: x !    REAL(KIND=fp), PARAMETER :: LIMIT = 1.0, SCALEF = 1.0 integer :: i f = x do i = 1 , 4 f = 0.5_fp * f * ( 3.0_fp - f * f ) end do f = 0.5_fp - 0.5_fp * f end function !> @brief Becke's partition function (4th order) derivative pure function partf_diff_becke4 ( x ) result ( df ) real ( KIND = fp ) :: df real ( KIND = fp ), intent ( IN ) :: x !    REAL(KIND=fp), PARAMETER :: LIMIT = 1.0, SCALEF = 1.0 real ( KIND = fp ), parameter :: FACTOR = 8 1.0_fp / 3 2.0_fp real ( KIND = fp ) :: f integer :: i f = x df = 1.0_fp do i = 1 , 4 df = df * ( 1.0_fp - f * f ) f = 0.5_fp * f * ( 3.0_fp - f * f ) end do df = - FACTOR * df end function !------------------------------------------------------------------------------- !> @brief Becke's original partition function (3 softening iterations), !>  Becke, JCP 88, 2547 (1988). This is the standard \"k=3\" stiffness used by !>  the reference ddCOSMO/ddPCM source projection (and by PySCF's gen_grid), !>  as opposed to the 4-iteration variant PTYPE_BECKE4 above. pure function partf_eval_becke3 ( x ) result ( f ) real ( KIND = fp ) :: f real ( KIND = fp ), intent ( IN ) :: x integer :: i f = x do i = 1 , 3 f = 0.5_fp * f * ( 3.0_fp - f * f ) end do f = 0.5_fp - 0.5_fp * f end function !> @brief Becke's original (3-iteration) partition function derivative pure function partf_diff_becke3 ( x ) result ( df ) real ( KIND = fp ) :: df real ( KIND = fp ), intent ( IN ) :: x real ( KIND = fp ), parameter :: FACTOR = 2 7.0_fp / 1 6.0_fp real ( KIND = fp ) :: f integer :: i f = x df = 1.0_fp do i = 1 , 3 df = df * ( 1.0_fp - f * f ) f = 0.5_fp * f * ( 3.0_fp - f * f ) end do df = - FACTOR * df end function !------------------------------------------------------------------------------- !> @brief SSF partition function pure function partf_eval_ssf ( x ) result ( f ) real ( KIND = fp ) :: f real ( KIND = fp ), intent ( IN ) :: x real ( KIND = fp ), parameter :: LIMIT = 0.64_fp , SCALEF = 1.0_fp / LIMIT real ( KIND = fp ) :: f1 , f2 , f4 if ( abs ( x ) > LIMIT ) then f = 0.5_fp - sign ( 0.5_fp , x ) return end if f1 = x * SCALEF f2 = f1 * f1 f4 = f2 * f2 f = 0.0625_fp * f1 * (( 3 5.0_fp - 3 5.0_fp * f2 ) + f4 * ( 2 1.0_fp - 5.0_fp * f2 )) f = 0.5_fp - 0.5_fp * f end function !> @brief SSF partition function derivative pure function partf_diff_ssf ( x ) result ( df ) real ( KIND = fp ) :: df real ( KIND = fp ), intent ( IN ) :: x real ( KIND = fp ), parameter :: LIMIT = 0.64_fp , SCALEF = 1.0_fp / LIMIT real ( KIND = fp ) :: f1 , f2 , f4 if ( abs ( x ) > LIMIT ) then df = 0.0_fp return end if f1 = x * SCALEF f2 = f1 * f1 f4 = f2 * f2 df = 0.0625_fp * (( 3 5.0_fp - 10 5.0_fp * f2 ) + & f4 * ( 10 5.0_fp - 3 5.0_fp * f2 )) df = - 0.5_fp * SCALEF * df end function !------------------------------------------------------------------------------- !> @brief Modified SSF with erf(a*x/(1-x&#94;2)) scaling (like in NWChem) pure function partf_eval_erf ( x ) result ( f ) real ( KIND = fp ) :: f real ( KIND = fp ), intent ( IN ) :: x real ( KIND = fp ), parameter :: LIMIT = 0.725_fp , SCALEF = 1.0_fp / 0.3_fp if ( abs ( x ) > LIMIT ) then f = 0.5_fp - sign ( 0.5_fp , x ) return end if f = erf ( x / ( 1.0_fp - x ** 2 ) * SCALEF ) f = 0.5_fp - 0.5_fp * f end function !> @brief Modified SSF with erf(a*x/(1-x&#94;2)) scaling (like in NWChem) derivative pure function partf_diff_erf ( x ) result ( df ) real ( KIND = fp ) :: df real ( KIND = fp ), intent ( IN ) :: x real ( KIND = fp ), parameter :: LIMIT = 0.725_fp , SCALEF = 1.0_fp / 0.3_fp real ( KIND = fp ), parameter :: PI = 3.141592653589793d0 real ( KIND = fp ), parameter :: FACTOR = SCALEF / sqrt ( PI ) real ( KIND = fp ) :: ex , frac if ( abs ( x ) > LIMIT ) then df = 0.0_fp return end if frac = 1.0_fp / ( 1.0_fp - x * x ) ex = exp ( - ( SCALEF * SCALEF * x * x * frac * frac )) df = - FACTOR * ex * ( 1.0_fp + x * x ) * frac end function !------------------------------------------------------------------------------- !> @brief Smoothstep function (2nd order) pure function partf_eval_smoothstep2 ( x ) result ( f ) real ( KIND = fp ) :: f real ( KIND = fp ), intent ( IN ) :: x real ( KIND = fp ) :: f1 , f2 real ( KIND = fp ), parameter :: LIMIT = 0.55_fp , SCALEF = 0.5_fp / LIMIT if ( abs ( x ) > LIMIT ) then f = 0.5_fp - sign ( 0.5_fp , x ) return else f1 = 0.5_fp - x * SCALEF f2 = f1 * f1 f = f2 * f1 * ( 1 0.0_fp - 1 5.0_fp * f1 + 6.0_fp * f2 ) end if end function !> @brief Smoothstep function (2nd order) derivative pure function partf_diff_smoothstep2 ( x ) result ( df ) real ( KIND = fp ) :: df real ( KIND = fp ), intent ( IN ) :: x real ( KIND = fp ) :: f1 , f2 real ( KIND = fp ), parameter :: LIMIT = 0.55_fp , SCALEF = 0.5_fp / LIMIT if ( abs ( x ) > LIMIT ) then df = 0.0_fp return else f1 = 0.5_fp - x * SCALEF f2 = f1 * f1 df = f2 * ( 3 0.0_fp - 6 0.0_fp * f1 + 3 0.0_fp * f2 ) end if end function !------------------------------------------------------------------------------- !> @brief Smoothstep function (3th order) pure function partf_eval_smoothstep3 ( x ) result ( f ) real ( KIND = fp ) :: f real ( KIND = fp ), intent ( IN ) :: x real ( KIND = fp ) :: f1 , f2 , f4 real ( KIND = fp ), parameter :: LIMIT = 0.62_fp , SCALEF = 0.5_fp / LIMIT if ( abs ( x ) > LIMIT ) then f = 0.5_fp - sign ( 0.5_fp , x ) return else f1 = 0.5_fp - x * SCALEF f2 = f1 * f1 f4 = f2 * f2 f = f4 * (( 3 5.0_fp - 8 4.0_fp * f1 ) + & f2 * ( 7 0.0_fp - 2 0.0_fp * f1 )) end if end function !> @brief Smoothstep function (3th order) derivative pure function partf_diff_smoothstep3 ( x ) result ( df ) real ( KIND = fp ) :: df real ( KIND = fp ), intent ( IN ) :: x real ( KIND = fp ) :: f1 , f2 , f4 real ( KIND = fp ), parameter :: LIMIT = 0.62_fp , SCALEF = 0.5_fp / LIMIT if ( abs ( x ) > LIMIT ) then df = 0.0_fp return else f1 = 0.5_fp - x * SCALEF f2 = f1 * f1 f4 = f2 * f2 df = f2 * f1 * (( 14 0.0_fp - 42 0.0_fp * f1 ) + & f2 * ( 42 0.0_fp - 14 0.0_fp * f1 )) end if end function !------------------------------------------------------------------------------- !> @brief Smoothstep function (4th order) pure function partf_eval_smoothstep4 ( x ) result ( f ) real ( KIND = fp ) :: f real ( KIND = fp ), intent ( IN ) :: x real ( KIND = fp ) :: f1 , f2 , f4 real ( KIND = fp ), parameter :: LIMIT = 0.69_fp , SCALEF = 0.5_fp / LIMIT if ( abs ( x ) > LIMIT ) then f = 0.5_fp - sign ( 0.5_fp , x ) return else f1 = 0.5_fp - x * SCALEF f2 = f1 * f1 f4 = f2 * f2 f = f4 * f1 * (( 12 6.0_fp - 42 0.0_fp * f1 ) + & f2 * ( 54 0.0_fp - 31 5.0_fp * f1 ) + & f4 * 7 0.0_fp ) end if end function !> @brief Smoothstep function (4th order) derivative pure function partf_diff_smoothstep4 ( x ) result ( df ) real ( KIND = fp ) :: df real ( KIND = fp ), intent ( IN ) :: x real ( KIND = fp ) :: f1 , f2 , f4 real ( KIND = fp ), parameter :: LIMIT = 0.69_fp , SCALEF = 0.5_fp / LIMIT if ( abs ( x ) > LIMIT ) then df = 0.0_fp return else f1 = 0.5_fp - x * SCALEF f2 = f1 * f1 f4 = f2 * f2 df = f4 * (( 63 0.0_fp - 252 0.0_fp * f1 ) + & f2 * ( 378 0.0_fp - 252 0.0_fp * f1 ) + & f4 * 63 0.0_fp ) end if end function !------------------------------------------------------------------------------- !> @brief Smoothstep function (5th order) pure function partf_eval_smoothstep5 ( x ) result ( f ) real ( KIND = fp ) :: f real ( KIND = fp ), intent ( IN ) :: x real ( KIND = fp ) :: f1 , f2 , f4 real ( KIND = fp ), parameter :: LIMIT = 0.73_fp , SCALEF = 0.5_fp / LIMIT if ( abs ( x ) > LIMIT ) then f = 0.5_fp - sign ( 0.5_fp , x ) return else f1 = 0.5_fp - x * SCALEF f2 = f1 * f1 f4 = f2 * f2 f = f4 * f2 * (( 46 2.0_fp - 198 0.0_fp * f1 ) + & f2 * ( 346 5.0_fp - 308 0.0_fp * f1 ) + & f4 * ( 138 6.0_fp - 25 2.0_fp * f1 )) end if end function !> @brief Smoothstep function (5th order) derivative pure function partf_diff_smoothstep5 ( x ) result ( df ) real ( KIND = fp ) :: df real ( KIND = fp ), intent ( IN ) :: x real ( KIND = fp ) :: f1 , f2 , f4 real ( KIND = fp ), parameter :: LIMIT = 0.73_fp , SCALEF = 0.5_fp / LIMIT if ( abs ( x ) > LIMIT ) then df = 0.0_fp return else f1 = 0.5_fp - x * SCALEF f2 = f1 * f1 f4 = f2 * f2 df = f4 * f1 * (( 277 2.0_fp - 1386 0.0_fp * f1 ) + & f2 * ( 2772 0.0_fp - 2772 0.0_fp * f1 ) + & f4 * ( 1386 0.0_fp - 277 2.0_fp * f1 )) end if end function !******************************************************************************* !> @brief Set up partition function parameters subroutine set_partition_function ( partfunc , ptype ) class ( partition_function ), intent ( INOUT ) :: partfunc integer , intent ( IN ) :: ptype select case ( ptype ) case ( PTYPE_BECKE4 ) partfunc % limit = 1.0_fp partfunc % eval => partf_eval_becke4 partfunc % deriv => partf_diff_becke4 case ( PTYPE_BECKE3 ) partfunc % limit = 1.0_fp partfunc % eval => partf_eval_becke3 partfunc % deriv => partf_diff_becke3 case ( PTYPE_SSF ) partfunc % limit = 0.64_fp partfunc % eval => partf_eval_ssf partfunc % deriv => partf_diff_ssf case ( PTYPE_ERF ) partfunc % limit = 0.725_fp partfunc % eval => partf_eval_erf partfunc % deriv => partf_diff_erf case ( PTYPE_SMSTP2 ) partfunc % limit = 0.55_fp partfunc % eval => partf_eval_smoothstep2 partfunc % deriv => partf_diff_smoothstep2 case ( PTYPE_SMSTP3 ) partfunc % limit = 0.62_fp partfunc % eval => partf_eval_smoothstep3 partfunc % deriv => partf_diff_smoothstep3 case ( PTYPE_SMSTP4 ) partfunc % limit = 0.69_fp partfunc % eval => partf_eval_smoothstep4 partfunc % deriv => partf_diff_smoothstep4 case ( PTYPE_SMSTP5 ) partfunc % limit = 0.74_fp partfunc % eval => partf_eval_smoothstep5 partfunc % deriv => partf_diff_smoothstep5 case DEFAULT partfunc % limit = 0.62_fp partfunc % eval => partf_eval_smoothstep3 partfunc % deriv => partf_diff_smoothstep3 end select end subroutine !------------------------------------------------------------------------------- ! SUBROUTINE toupper(s, u) !     CHARACTER(LEN=*), INTENT(IN)  :: s !     CHARACTER(LEN=*), INTENT(OUT) :: u !     INTEGER, PARAMETER :: ISHIFT = (iachar(\"A\")-iachar(\"a\")) !     INTEGER :: i, code ! !     DO i = 1, min(len(s), len(u)) !         SELECT CASE (s(i:i)) !         CASE ( \"a\" : \"z\" ) !             code = iachar(s(i:i)) !             u(i:i) = achar(code+ISHIFT) !         CASE DEFAULT !             u(i:i) = s(i:i) !         END SELECT !     END DO ! ! END SUBROUTINE end module mod_dft_partfunc","tags":"","url":"sourcefile/dft_partfunc.f90.html"},{"title":"basis_tools.F90 – OpenQP Fortran API","text":"Source Code !>  @brief This module contains types and subroutines to manipulate basis set !>  @details The main goal of this module is to split SP(L) type shells !>   onto pair of S and P shells. It significantly simplifies code for !>   one- and two-electron integrals. !   REVISION HISTORY: !>  @date -Sep, 2018- Initial release !>  @author  Vladimir Mironov module basis_tools use iso_fortran_env , only : real64 use precision , only : dp use atomic_structure_m , only : atomic_structure use constants , only : BAS_MXANG , ANGULAR_LABEL , NUM_CART_BF , NUM_SPH_BF , & cart_X , cart_Y , cart_Z , HARMONIC_ACTIVE use cart2sph , only : cart2sph_vec use io_constants , only : IW use parallel , only : par_env_t implicit none type ecp_parameters real ( real64 ), dimension (:), allocatable :: & ecp_ex , & !< ecp_cc , & !< ecp_coord !< integer , dimension (:), allocatable :: & ecp_r_ex , & !< ecp_am , & !< n_expo !< logical :: is_ecp = . false . end type type basis_set real ( real64 ), dimension (:), allocatable :: & ex , & !< Array of primitive Gaussian exponents cc , & !< Array of contraction coefficients bfnrm !< Array of normalization constants integer , dimension (:), allocatable :: & g_offset , & !< Locations of the first Gaussian in shells origin , & !< Tells which atom the shell is centered on am , & !< Array of shell angular momentum harmonic , & !< Per-shell flag: 1 = pure spherical-harmonic, 0 = Cartesian ncontr , & !< Array of contraction degrees ao_offset , & !< Indices of shells in the total AO basis naos , & !< Array of shell's AO numbers ecp_zn_num !< number of electrons removed by ecp integer :: & nshell = 0 , & !< Number of shells in the basis set nprim = 0 , & !< Number of primitive Gaussians in the basis set nbf = 0 , & !< Number of basis set functions mxcontr = 0 , & !< Max. contraction degree mxam = 0 !< Max. angular momentum among basis set type ( ecp_parameters ) :: ecp_params type ( atomic_structure ), pointer :: atoms real ( real64 ), allocatable :: at_mx_dist2 (:) real ( real64 ), allocatable :: prim_mx_dist2 (:) real ( real64 ), allocatable :: shell_mx_dist2 (:) real ( real64 ), allocatable :: shell_centers (:, :) contains procedure , pass ( basis ) :: from_file procedure , pass ( basis ) :: append procedure , pass ( basis ) :: dump , load procedure , pass ( basis ) :: normalize_primitives procedure , pass ( basis ) :: normalize_contracted procedure , pass ( basis ) :: set_bfnorms procedure , pass ( basis ) :: reserve => omp_sp_reserve procedure , pass ( basis ) :: destroy => omp_sp_destroy generic :: aoval => compAOv , compAOVg , compAOVgg procedure , pass ( basis ) :: compAOv procedure , pass ( basis ) :: compAOvg procedure , pass ( basis ) :: compAOvgg procedure , pass ( basis ) :: init_shell_centers procedure :: set_screening => comp_basis_mxdists procedure , pass ( basis ) :: basis_broadcast procedure , pass ( basis ) :: bf_label procedure , pass ( basis ) :: bf_to_shell end type private public basis_set public bas_norm_matrix public bas_denorm_matrix public build_cart_density interface bas_norm_matrix module procedure bas_norm_matrix_tr module procedure bas_norm_matrix_sq end interface interface bas_denorm_matrix module procedure bas_denorm_matrix_tr module procedure bas_denorm_matrix_sq end interface contains !>  @brief Append a set of shells to the basis set ! !   PARAMETERS: !>  @param[in]  atom            basis set for atom, which contains: !>                 nshells        number of shells to append !>                 nprims         number of primites to append !>                 nbfs           number of basis functions to append !>                 ang(:)         array of shells angular momentums !>                 ncontract(:)   array of shells contraction degrees !>                 ex(:)          array of primitive exponent coefficients !>                 cc(:)          array of primitive contraction coefficients !>  @param[in]  atom_index      index of added atom in molecule specification !>  @param[in[  atom_number     number/charge of added atom in molecule specification !>  @param[in]  newatom         whether to add a new atom or add to the last one !>  @param[inout]  err         err flag ! !>  @author  Vladimir Mironov ! !   REVISION HISTORY: !>  @date -Sep, 2021- Initial release subroutine append ( basis , atom , atom_index , atom_number , err , newatom ) use basis_library , only : atom_basis_t use elements , only : ELEMENTS_LONG_NAME class ( basis_set ), intent ( inout ) :: basis class ( atom_basis_t ), intent ( in ) :: atom integer , intent ( in ) :: atom_index , atom_number logical , optional , intent ( in ) :: newatom logical , intent ( inout ) :: err integer :: i , atom_id , prim_id , bf_id logical :: newatom_int associate ( nshell => basis % nshell & , nprim => basis % nprim & , nbf => basis % nbf & ) !       Check that basis on atom is not emply if ( atom % nshells == 0 ) then write ( iw , '(A,I0,A)' ) \" *** Warning! Element \" // trim ( ELEMENTS_LONG_NAME ( atom_number )) // \" with index \" & , atom_index , \" does not have basis functions!\" err = . true . return end if newatom_int = . true . if ( present ( newatom )) newatom_int = newatom !       Get atom id for new shells atom_id = 1 if ( nshell > 0 ) then atom_id = basis % origin ( nshell ) if ( newatom_int ) atom_id = atom_id + 1 end if !       Get initial primitive index for new primitives prim_id = 1 if ( nshell > 0 ) prim_id = basis % g_offset ( nshell ) & + basis % ncontr ( nshell ) !       Get initial basis function index for new basis functions bf_id = 1 if ( nshell > 0 ) bf_id = basis % ao_offset ( nshell ) & + NUM_CART_BF ( basis % am ( nshell )) !       Set new atom id for new shells basis % origin ( nshell + 1 : nshell + atom % nshells ) = atom_id !       Copy contraction degree and angular momentum types basis % ncontr ( nshell + 1 : nshell + atom % nshells ) = atom % ncontract (: atom % nshells ) basis % am ( nshell + 1 : nshell + atom % nshells ) = atom % ang (: atom % nshells ) !     Update basis max contraction degree basis % mxcontr = max ( basis % mxcontr , maxval ( atom % ncontract (: atom % nshells ))) !     Update basis max angular momentum basis % mxam = max ( basis % mxam , & maxval ( atom % ang (: atom % nshells ))) !     Compute nbf (used in integral code) basis % naos ( nshell + 1 : nshell + atom % nshells ) = NUM_CART_BF ( atom % ang (: atom % nshells )) do i = 1 , atom % nshells !           Compute location of the first primitive for every shell basis % g_offset ( nshell + i ) = prim_id prim_id = prim_id + atom % ncontract ( i ) !           Compute location of the first basis set function for every shell basis % ao_offset ( nshell + i ) = bf_id bf_id = bf_id + NUM_CART_BF ( atom % ang ( i )) end do !       Copy primitive exponential and contraction coefficients basis % ex ( nprim + 1 : nprim + atom % nprims ) = atom % ex (: atom % nprims ) basis % cc ( nprim + 1 : nprim + atom % nprims ) = atom % cc (: atom % nprims ) !       Update counters nshell = nshell + atom % nshells nprim = nprim + atom % nprims nbf = nbf + atom % nbfs end associate end subroutine !-------------------------------------------------------------------------------- !>  @brief Allocate arrays in `BASIS_SET` type variable ! !   PARAMETERS: !   @param[inout]  basis    basis_set type variable ! !>  @author  Vladimir Mironov ! !   REVISION HISTORY: !>  @date -Sep, 2021- Initial release subroutine omp_sp_reserve ( basis , num_shell , num_gauss , num_bf ) class ( basis_set ), intent ( INOUT ) :: basis integer , intent ( in ) :: num_shell , num_gauss , num_bf if ( allocated ( basis % ex )) call basis % destroy () ! cleanup basis % nshell = 0 basis % nprim = 0 basis % nbf = 0 allocate ( basis % ex ( num_gauss ), source = 0.0d0 ) allocate ( basis % cc ( num_gauss ), source = 0.0d0 ) allocate ( basis % bfnrm ( num_bf ), source = 0.0d0 ) allocate ( basis % g_offset ( num_shell ), source = 0 ) allocate ( basis % origin ( num_shell ), source = 0 ) allocate ( basis % am ( num_shell ), source = 0 ) allocate ( basis % harmonic ( num_shell ), source = 0 ) allocate ( basis % ncontr ( num_shell ), source = 0 ) allocate ( basis % ao_offset ( num_shell ), source = 0 ) allocate ( basis % naos ( num_shell ), source = 0 ) end subroutine !-------------------------------------------------------------------------------- !>  @brief Dellocate arrays in `BASIS_SET` type variable ! !   PARAMETERS: !   @param[inout]  basis    basis_set type variable ! !>  @author  Vladimir Mironov ! !   REVISION HISTORY: !>  @date -Sep, 2021- Initial release subroutine omp_sp_destroy ( basis ) class ( basis_set ), intent ( INOUT ) :: basis deallocate ( basis % ex ) deallocate ( basis % cc ) deallocate ( basis % bfnrm ) deallocate ( basis % g_offset ) deallocate ( basis % origin ) deallocate ( basis % am ) deallocate ( basis % harmonic ) deallocate ( basis % ncontr ) deallocate ( basis % ao_offset ) deallocate ( basis % naos ) end subroutine !-------------------------------------------------------------------------------- !>  @brief Remove normalization for primitives ! !>  @author  Vladimir Mironov ! !   REVISION HISTORY: !>  @date -Sep, 2021- Initial release subroutine normalize_primitives ( basis ) class ( basis_set ), intent ( inout ) :: basis integer :: ish , ig , ityp , k1 , k2 real ( real64 ) :: ee associate ( nshell => basis % nshell & , g0 => basis % g_offset & , am => basis % am & , ncontr => basis % ncontr & , naos => basis % naos & , ex => basis % ex & , cc => basis % cc & ) do ish = 1 , nshell k1 = g0 ( ish ) k2 = g0 ( ish ) + ncontr ( ish ) - 1 ityp = am ( ish ) do ig = k1 , k2 ee = ex ( ig ) * 2.0d0 cc ( ig ) = cc ( ig ) / sqrt ( gauss_norm ( ee , ityp )) end do end do end associate end subroutine !-------------------------------------------------------------------------------- !>  @brief Normalize *contracted* shells ! !>  @author  Vladimir Mironov ! !   REVISION HISTORY: !>  @date -Sep, 2021- Initial release subroutine normalize_contracted ( basis ) class ( basis_set ), intent ( inout ) :: basis integer :: ish , ig , jg , ityp , iat , k1 , k2 real ( real64 ) :: ee , fact , norm real ( real64 ), parameter :: THRESH = 1.0d-10 real ( real64 ), parameter :: WARNAT = 1.0d-6 character ( len =* ), parameter :: & WRN_ATOM_NORMALIZATION = & '(\" *** Warning! Atom\",I4,\" shell\",I5,\" type \",A1,& &\" has normalization\",F13.8)' associate ( nshell => basis % nshell & , g0 => basis % g_offset & , am => basis % am & , ncontr => basis % ncontr & , naos => basis % naos & , origin => basis % origin & , ex => basis % ex & , cc => basis % cc & ) do ish = 1 , nshell k1 = g0 ( ish ) k2 = g0 ( ish ) + ncontr ( ish ) - 1 ityp = am ( ish ) iat = origin ( ish ) fact = 0.0d0 do ig = k1 , k2 do jg = k1 , ig ee = ex ( ig ) + ex ( jg ) norm = cc ( ig ) * cc ( jg ) * gauss_norm ( ee , ityp ) if ( ig /= jg ) norm = 2 * norm fact = fact + norm end do end do if ( fact > THRESH ) fact = 1.0d0 / sqrt ( fact ) if (( abs ( fact - 1.0d0 ) > WARNAT )) then write ( * , fmt = WRN_ATOM_NORMALIZATION ) & iat , nshell , ANGULAR_LABEL ( ityp + 1 : ityp + 1 ), fact end if cc ( k1 : k2 ) = cc ( k1 : k2 ) * fact end do end associate end subroutine !-------------------------------------------------------------------------------- !>  @brief Initialize array of basis function normalization factors ! !   PARAMETERS: !   @param[inout]  p(:)    array of normalization factors ! !>  @author  Vladimir Mironov ! !   REVISION HISTORY: !>  @date -Sep, 2018- Initial release subroutine set_bfnorms ( basis ) use constants , only : shells_pnrm2 class ( basis_set ), intent ( inout ) :: basis integer :: mini , maxi , n , i , ang do i = 1 , basis % nshell maxi = basis % naos ( i ) n = basis % ao_offset ( i ) ang = basis % am ( i ) if ( HARMONIC_ACTIVE . and . basis % harmonic ( i ) == 1 ) then ! Pure spherical components are already unit-normalized by the ! Cartesian->spherical transform (which folds in shells_pnrm2), so ! bas_norm_matrix must not rescale them again. basis % bfnrm ( n : n + maxi - 1 ) = 1.0_dp else basis % bfnrm ( n : n + maxi - 1 ) = shells_pnrm2 ( 1 : maxi , ang ) end if end do end subroutine !-------------------------------------------------------------------------------- !>  @brief Build the Cartesian-effective density used by gradient/Hessian !>         kernels from a spherical (bfnrm-folded) density matrix. !>  @details The analytic-derivative kernels iterate Cartesian shell blocks !>           and contract them with the AO density. When pure spherical !>           shells are active the density is spherical-dimensioned, so we !>           expand it block by block to the Cartesian \"effective\" density !>           D_cart = B'_i D_sph B'_j&#94;T (B' = c2s * shells_pnrm2), and return !>           Cartesian per-shell offsets to index it. With HARMONIC_ACTIVE !>           off (or a fully Cartesian basis) this is a plain copy. subroutine build_cart_density ( basis , dsph , dcart , cart_off , nbf_cart ) use cart2sph , only : c2s_expand_block class ( basis_set ), intent ( in ) :: basis real ( dp ), intent ( in ) :: dsph (:,:) real ( dp ), allocatable , intent ( out ) :: dcart (:,:) integer , allocatable , intent ( out ) :: cart_off (:) integer , intent ( out ) :: nbf_cart integer :: ish , jsh , oi , oj , nci , ncj , nsi , nsj , soi , soj allocate ( cart_off ( basis % nshell )) nbf_cart = 0 do ish = 1 , basis % nshell cart_off ( ish ) = nbf_cart + 1 nbf_cart = nbf_cart + NUM_CART_BF ( basis % am ( ish )) end do allocate ( dcart ( nbf_cart , nbf_cart ), source = 0.0d0 ) do ish = 1 , basis % nshell oi = cart_off ( ish ); nci = NUM_CART_BF ( basis % am ( ish )) soi = basis % ao_offset ( ish ); nsi = basis % naos ( ish ) do jsh = 1 , basis % nshell oj = cart_off ( jsh ); ncj = NUM_CART_BF ( basis % am ( jsh )) soj = basis % ao_offset ( jsh ); nsj = basis % naos ( jsh ) call c2s_expand_block ( & dsph ( soi : soi + nsi - 1 , soj : soj + nsj - 1 ), & dcart ( oi : oi + nci - 1 , oj : oj + ncj - 1 ), & basis % am ( ish ), basis % harmonic ( ish ), & basis % am ( jsh ), basis % harmonic ( jsh )) end do end do end subroutine build_cart_density !-------------------------------------------------------------------------------- !>  @brief Scale matrix `A` with matrix \\f$ P \\cdot P&#94;T \\f$ !>  @details `A` is a packed square matrix, `P` is a column vector ! !   PARAMETERS: !   @param[inout]  a(:)    triangular matrix (dimension `LD`*(`LD`+1)/2) !   @param[in]     p(:)    vector (dimension `LD`) !   @param[in]     ld      leading dimension of P and matrix A in unpacked form ! !>  @author  Vladimir Mironov ! !   REVISION HISTORY: !>  @date -Sep, 2018- Initial release subroutine bas_norm_matrix_tr ( a , p , ld ) real ( real64 ), intent ( INOUT ) :: a (:) integer , intent ( IN ) :: ld real ( real64 ), allocatable , intent ( IN ) :: p (:) integer :: i , n !$omp parallel do private(i,n) do i = 1 , ld n = i * ( i - 1 ) / 2 a ( n + 1 : n + i ) = a ( n + 1 : n + i ) * p ( i ) * p ( 1 : i ) end do !$omp end parallel do end subroutine !-------------------------------------------------------------------------------- !>  @brief Scale matrix `A` with matrix \\f$ P \\cdot P&#94;T \\f$ !>  @details `A` is a full square matrix, `P` is a column vector ! !   PARAMETERS: !   @param[inout]  a(:,:)  square matrix (dimension `LD`*`LD`) !   @param[in]     p(:)    vector (dimension `LD`) !   @param[in]     ld      leading dimension of P and matrix A in unpacked form ! !>  @author  Vladimir Mironov ! !   REVISION HISTORY: !>  @date -Sep, 2018- Initial release subroutine bas_norm_matrix_sq ( a , p , ld ) real ( real64 ), intent ( INOUT ) :: a (:,:) integer , intent ( IN ) :: ld real ( real64 ), allocatable , intent ( IN ) :: p (:) integer :: i , n !$omp parallel do private(i) do i = 1 , ld ! Scale the full column: a(j,i) *= p(i)*p(j), j = 1..ld.  (The previous ! p(1:i) section was non-conforming Fortran; it only worked by accident ! at -O2 and aborts under -fcheck=bounds.) a ( 1 : ld , i ) = a ( 1 : ld , i ) * p ( i ) * p ( 1 : ld ) end do !$omp end parallel do end subroutine !-------------------------------------------------------------------------------- !>  @brief Scale matrix `A` with matrix \\f$ 1/P \\cdot 1/P&#94;T \\f$ !>  @details `A` is a packed square matrix, `P` is a column vector ! !   PARAMETERS: !   @param[inout]  a(:)    triangular matrix (dimension `LD`*(`LD`+1)/2) !   @param[in]     p(:)    vector (dimension `LD`) !   @param[in]     ld      leading dimension of P and matrix A in unpacked form ! !>  @author  Vladimir Mironov ! !   REVISION HISTORY: !>  @date -Sep, 2018- Initial release subroutine bas_denorm_matrix_tr ( a , p , ld ) real ( real64 ), intent ( INOUT ) :: a (:) integer , intent ( IN ) :: ld real ( real64 ), allocatable , intent ( INOUT ) :: p (:) p = 1 / p call bas_norm_matrix ( a , p , ld ) p = 1 / p end subroutine !-------------------------------------------------------------------------------- !>  @brief Scale matrix `A` with matrix \\f$ 1/P \\cdot 1/P&#94;T \\f$ !>  @details `A` is a full square matrix, `P` is a column vector ! !   PARAMETERS: !   @param[inout]  a(:,:)  square matrix (dimension `LD`*`LD`) !   @param[in]     p(:)    vector (dimension `LD`) !   @param[in]     ld      leading dimension of P and matrix A in unpacked form ! !>  @author  Vladimir Mironov ! !   REVISION HISTORY: !>  @date -Sep, 2018- Initial release subroutine bas_denorm_matrix_sq ( a , p , ld ) real ( real64 ), intent ( INOUT ) :: a (:,:) integer , intent ( IN ) :: ld real ( real64 ), allocatable , intent ( INOUT ) :: p (:) p = 1 / p call bas_norm_matrix ( a , p , ld ) p = 1 / p end subroutine subroutine dump ( basis , LU ) class ( basis_set ), intent ( in ) :: basis integer , intent ( in ) :: LU integer :: i write ( LU , * ) basis % nshell , basis % nprim , basis % nbf do i = 1 , basis % nshell write ( LU , '(*(I8))' ) basis % g_offset ( i ) & , basis % origin ( i ) & , basis % am ( i ) & , basis % harmonic ( i ) & , basis % ncontr ( i ) & , basis % ao_offset ( i ) & , basis % naos ( i ) end do do i = 1 , basis % nprim write ( LU , '(*(ES23.15))' ) basis % ex ( i ), basis % cc ( i ) end do do i = 1 , basis % nbf write ( LU , '(A8, ES23.15)' ) basis % bf_label ( i ), basis % bfnrm ( i ) end do end subroutine dump subroutine load ( basis , LU ) class ( basis_set ), intent ( inout ) :: basis integer , intent ( in ) :: LU integer :: i , nshell , nprim , nbf character ( 8 ) :: label read ( LU , * ) nshell , nprim , nbf call basis % reserve ( nshell , nprim , nbf ) basis % nshell = nshell basis % nprim = nprim basis % nbf = nbf do i = 1 , basis % nshell read ( LU , '(*(I8))' ) basis % g_offset ( i ) & , basis % origin ( i ) & , basis % am ( i ) & , basis % harmonic ( i ) & , basis % ncontr ( i ) & , basis % ao_offset ( i ) & , basis % naos ( i ) end do do i = 1 , basis % nprim read ( LU , '(*(ES23.15))' ) basis % ex ( i ), basis % cc ( i ) end do do i = 1 , basis % nbf read ( LU , '(A8, ES23.15)' ) label , basis % bfnrm ( i ) end do basis % mxcontr = maxval ( basis % ncontr ( 1 : basis % nshell )) basis % mxam = maxval ( basis % am ( 1 : basis % nshell )) end subroutine load elemental function gauss_norm ( e , la ) result ( res ) use constants , only : pi real ( real64 ), parameter :: & NORMS ( 0 : * ) = pi * sqrt ( pi ) * [ 1.0d+00 , 0.5d+00 , 0.75d+00 , 1.875d+00 , & 6.5625d+00 , 2 9.53125d+00 , 16 2.421875d+00 ] real ( real64 ), intent ( in ) :: e integer , intent ( in ) :: la real ( real64 ) :: res real ( real64 ) :: f f = e * sqrt ( e ) res = NORMS ( la ) / ( f * e ** la ) end function !> @brief Compute AO values in a point !> @param[in]    basis  atomic basis set !> @param[in]    ptxyz  coordinates of a point in space !> @param[out]   naos   number of significant AOs !> @param[out]   aov    AO values !> @author Vladimir Mironov subroutine compAOv ( basis , ptxyz , naos , & aov , shells ) use precision , only : fp implicit none class ( basis_set ) :: basis real ( kind = fp ), intent ( in ) :: ptxyz ( 3 ) integer , intent ( OUT ) :: naos real ( KIND = fp ), contiguous , intent ( OUT ) :: aov (:) !> Optional list of shells to evaluate (e.g. prescreened for a grid !> slice); AOs of unlisted shells are left untouched integer , optional , intent ( in ) :: shells (:) real ( KIND = fp ) :: & vexp , vexp1 , vexp2 , dum integer :: & k2 , loci , & ishell , imomfct , ix , iy , iz , ityp real ( kind = fp ) :: dr1 ( 0 : 10 , 3 ), rsqrd integer :: i integer :: ishl , nshl logical :: useList dr1 ( 0 ,:) = 1 useList = present ( shells ) nshl = basis % nshell if ( useList ) nshl = size ( shells ) naos = 0 do ishl = 1 , nshl if ( useList ) then ishell = shells ( ishl ) else ishell = ishl end if associate ( & iatm => basis % origin ( ishell ), & offset => basis % ao_offset ( ishell ), & k1 => basis % g_offset ( ishell ), & ncontr => basis % ncontr ( ishell ), & am => basis % am ( ishell ), & maxi => basis % naos ( ishell )) !       Angular intermediates for the density and gradient dr1 ( 1 ,:) = ptxyz - basis % atoms % xyz (: 3 , iatm ) rsqrd = sum ( dr1 ( 1 ,:) ** 2 ) if ( rsqrd <= basis % shell_mx_dist2 ( ishell )) then vexp1 = 0.0_fp vexp2 = 0.0_fp k2 = ncontr - 1 + k1 do imomfct = k1 , k2 if ( rsqrd > basis % prim_mx_dist2 ( imomfct )) cycle dum = basis % ex ( imomfct ) * rsqrd vexp = exp ( - dum ) * basis % cc ( imomfct ) vexp1 = vexp1 + vexp vexp2 = vexp2 + 2 * vexp * basis % ex ( imomfct ) end do else aov ( offset : offset + maxi - 1 ) = 0.0_fp cycle end if naos = naos + 1 select case ( am ) case ( 0 ) aov ( offset ) = vexp1 case ( 1 ) aov ( offset ) = vexp1 * dr1 ( 1 , 1 ) aov ( offset + 1 ) = vexp1 * dr1 ( 1 , 2 ) aov ( offset + 2 ) = vexp1 * dr1 ( 1 , 3 ) case DEFAULT do i = 2 , am dr1 ( i ,:) = dr1 ( i - 1 ,:) * dr1 ( 1 ,:) end do loci = offset - 1 if ( HARMONIC_ACTIVE . and . basis % harmonic ( ishell ) == 1 ) then ! Evaluate the full Cartesian AO vector, then reduce to spherical. block real ( kind = fp ) :: cbuf ( NUM_CART_BF ( am )), sbuf ( NUM_SPH_BF ( am )) do ityp = 1 , NUM_CART_BF ( am ) cbuf ( ityp ) = vexp1 * dr1 ( cart_x ( ityp , am ), 1 ) & * dr1 ( cart_y ( ityp , am ), 2 ) & * dr1 ( cart_z ( ityp , am ), 3 ) end do call cart2sph_vec ( cbuf , sbuf , am ) aov ( offset : offset + NUM_SPH_BF ( am ) - 1 ) = sbuf end block else do ityp = 1 , maxi ix = cart_x ( ityp , am ) iy = cart_y ( ityp , am ) iz = cart_z ( ityp , am ) !             Compute AO value at a grid point aov ( loci + ityp ) = vexp1 * dr1 ( ix , 1 ) & * dr1 ( iy , 2 ) & * dr1 ( iz , 3 ) end do end if end select end associate end do end subroutine !> @brief Compute AO values and gradient in a point !> @param[in]    basis  atomic basis set !> @param[in]    ptxyz  coordinates of a point in space !> @param[out]   naos   number of significant AOs !> @param[out]   aov    AO values !> @param[out]   aogx   AO gradient, X component !> @param[out]   aogy   AO gradient, Y component !> @param[out]   aogz   AO gradient, Z component !> @author Vladimir Mironov subroutine compAOvg ( basis , ptxyz , naos , & aov , aogx , aogy , aogz , shells ) use precision , only : fp implicit none class ( basis_set ) :: basis real ( kind = fp ), intent ( in ) :: ptxyz ( 3 ) integer , intent ( OUT ) :: naos real ( KIND = fp ), contiguous , intent ( OUT ) :: aov (:) real ( KIND = fp ), contiguous , intent ( OUT ) :: aogx (:), aogy (:), aogz (:) !> Optional list of shells to evaluate (e.g. prescreened for a grid !> slice); AOs of unlisted shells are left untouched integer , optional , intent ( in ) :: shells (:) integer :: & ishell , loci , & !, iatm, mini, maxi, loci0, & !ifct ityp , ix , iy , iz real ( KIND = fp ) :: & vexp1 , vexp2 , x , y , z , & xm , ym , zm , & xp , yp , zp real ( KIND = fp ) :: & dum , vexp integer :: & k2 , imomfct real ( kind = fp ) :: dr1 ( - 1 : 10 , 3 ), rsqrd integer :: i integer :: ishl , nshl logical :: useList dr1 (: - 1 ,:) = 0 dr1 ( 0 ,:) = 1 useList = present ( shells ) nshl = basis % nshell if ( useList ) nshl = size ( shells ) naos = 0 do ishl = 1 , nshl if ( useList ) then ishell = shells ( ishl ) else ishell = ishl end if associate ( & iatm => basis % origin ( ishell ), & maxi => basis % naos ( ishell ), & offset => basis % ao_offset ( ishell ), & k1 => basis % g_offset ( ishell ), & ncontr => basis % ncontr ( ishell ), & am => basis % am ( ishell )) dr1 ( 1 ,:) = ptxyz - basis % atoms % xyz (: 3 , iatm ) rsqrd = sum ( dr1 ( 1 ,:) ** 2 ) if ( rsqrd <= basis % shell_mx_dist2 ( ishell )) then vexp1 = 0.0_fp vexp2 = 0.0_fp k2 = ncontr - 1 + k1 do imomfct = k1 , k2 if ( rsqrd > basis % prim_mx_dist2 ( imomfct )) cycle dum = basis % ex ( imomfct ) * rsqrd vexp = exp ( - dum ) * basis % cc ( imomfct ) vexp1 = vexp1 + vexp vexp2 = vexp2 + 2 * vexp * basis % ex ( imomfct ) end do else aov ( offset : offset + maxi - 1 ) = 0.0_fp aogx ( offset : offset + maxi - 1 ) = 0.0_fp aogy ( offset : offset + maxi - 1 ) = 0.0_fp aogz ( offset : offset + maxi - 1 ) = 0.0_fp cycle end if naos = naos + 1 loci = offset - 1 select case ( am ) case ( 0 ) !           Special fast code for S functions aov ( offset ) = vexp1 aogx ( offset ) = - vexp2 * dr1 ( 1 , 1 ) aogy ( offset ) = - vexp2 * dr1 ( 1 , 2 ) aogz ( offset ) = - vexp2 * dr1 ( 1 , 3 ) case ( 1 ) !           Special fast code for P functions x = dr1 ( 1 , 1 ) y = dr1 ( 1 , 2 ) z = dr1 ( 1 , 3 ) aov ( offset ) = vexp1 * x aov ( offset + 1 ) = vexp1 * y aov ( offset + 2 ) = vexp1 * z aogx ( offset ) = vexp1 - vexp2 * x * x aogx ( offset + 1 ) = - vexp2 * x * y aogx ( offset + 2 ) = - vexp2 * x * z aogy ( offset ) = - vexp2 * x * y aogy ( offset + 1 ) = vexp1 - vexp2 * y * y aogy ( offset + 2 ) = - vexp2 * y * z aogz ( offset ) = - vexp2 * x * z aogz ( offset + 1 ) = - vexp2 * y * z aogz ( offset + 2 ) = vexp1 - vexp2 * z * z case DEFAULT do i = 2 , am + 1 dr1 ( i ,:) = dr1 ( i - 1 ,:) * dr1 ( 1 ,:) end do if ( HARMONIC_ACTIVE . and . basis % harmonic ( ishell ) == 1 ) then ! Build the full Cartesian value + gradient vectors, then reduce ! each to spherical (c2s is r-independent, so it commutes with d/dr). block real ( kind = fp ) :: cv ( NUM_CART_BF ( am )), cx ( NUM_CART_BF ( am )) real ( kind = fp ) :: cy ( NUM_CART_BF ( am )), cz ( NUM_CART_BF ( am )) real ( kind = fp ) :: sv ( NUM_SPH_BF ( am )), sx ( NUM_SPH_BF ( am )) real ( kind = fp ) :: sy ( NUM_SPH_BF ( am )), sz ( NUM_SPH_BF ( am )) integer :: ns do ityp = 1 , NUM_CART_BF ( am ) ix = cart_x ( ityp , am ); iy = cart_y ( ityp , am ); iz = cart_z ( ityp , am ) x = dr1 ( ix , 1 ); y = dr1 ( iy , 2 ); z = dr1 ( iz , 3 ) xm = ix * dr1 ( ix - 1 , 1 ); ym = iy * dr1 ( iy - 1 , 2 ); zm = iz * dr1 ( iz - 1 , 3 ) xp = dr1 ( ix + 1 , 1 ) * vexp2 ; yp = dr1 ( iy + 1 , 2 ) * vexp2 ; zp = dr1 ( iz + 1 , 3 ) * vexp2 cv ( ityp ) = vexp1 * x * y * z cx ( ityp ) = ( - xp + vexp1 * xm ) * y * z cy ( ityp ) = ( - yp + vexp1 * ym ) * x * z cz ( ityp ) = ( - zp + vexp1 * zm ) * x * y end do ns = NUM_SPH_BF ( am ) call cart2sph_vec ( cv , sv , am ); aov ( offset : offset + ns - 1 ) = sv call cart2sph_vec ( cx , sx , am ); aogx ( offset : offset + ns - 1 ) = sx call cart2sph_vec ( cy , sy , am ); aogy ( offset : offset + ns - 1 ) = sy call cart2sph_vec ( cz , sz , am ); aogz ( offset : offset + ns - 1 ) = sz end block else do ityp = 1 , maxi ix = cart_x ( ityp , am ) iy = cart_y ( ityp , am ) iz = cart_z ( ityp , am ) aov ( loci + ityp ) = vexp1 * dr1 ( ix , 1 ) & * dr1 ( iy , 2 ) & * dr1 ( iz , 3 ) !               Compute gradient AO value at a grid point !               Gradient is by the electron (not nuclear) coordinates x = dr1 ( ix , 1 ) y = dr1 ( iy , 2 ) z = dr1 ( iz , 3 ) !               Gradient minus one component xm = ix * dr1 ( ix - 1 , 1 ) ym = iy * dr1 ( iy - 1 , 2 ) zm = iz * dr1 ( iz - 1 , 3 ) !               Gradient plus one component xp = dr1 ( ix + 1 , 1 ) * vexp2 yp = dr1 ( iy + 1 , 2 ) * vexp2 zp = dr1 ( iz + 1 , 3 ) * vexp2 aogx ( loci + ityp ) = ( - xp + vexp1 * xm ) * y * z aogy ( loci + ityp ) = ( - yp + vexp1 * ym ) * x * z aogz ( loci + ityp ) = ( - zp + vexp1 * zm ) * x * y end do end if end select end associate end do end subroutine !> @brief Compute AO values, and their 1st and 2nd derivatives in a point !> @param[in]    basis    atomic basis set !> @param[in]    ptxyz    coordinates of a point in space !> @param[out]   naos     number of significant AOs !> @param[out]   aov      AO values !> @param[out]   aogx     AO gradient, X component !> @param[out]   aogy     AO gradient, Y component !> @param[out]   aogz     AO gradient, Z component !> @param[out]   aog2xx   AO 2nd derivative, XX component !> @param[out]   aog2yy   AO 2nd derivative, YY component !> @param[out]   aog2zz   AO 2nd derivative, ZZ component !> @param[out]   aog2xy   AO 2nd derivative, XY component !> @param[out]   aog2yz   AO 2nd derivative, YZ component !> @param[out]   aog2xz   AO 2nd derivative, XZ component !> @author Vladimir Mironov subroutine compAOvgg ( basis , ptxyz , naos , & aov , aogx , aogy , aogz , & aog2xx , aog2yy , aog2zz , aog2xy , aog2yz , aog2xz , shells ) use precision , only : fp implicit none class ( basis_set ) :: basis real ( kind = fp ), intent ( in ) :: ptxyz ( 3 ) integer , intent ( OUT ) :: naos real ( KIND = fp ), contiguous , intent ( OUT ) :: aov (:) real ( KIND = fp ), contiguous , intent ( OUT ) :: aogx (:), aogy (:), aogz (:) real ( KIND = fp ), contiguous , intent ( OUT ) :: & aog2xx (:), aog2yy (:), aog2zz (:), & aog2xy (:), aog2yz (:), aog2xz (:) !> Optional list of shells to evaluate (e.g. prescreened for a grid !> slice); AOs of unlisted shells are left untouched integer , optional , intent ( in ) :: shells (:) integer :: & ishell , loci , & !, iatm, mini, maxi, loci0, & !ifct ityp , ix , iy , iz real ( KIND = fp ) :: & vexp1 , vexp2 , vexp3 , & xm , ym , zm , & xp , yp , zp , & x , y , z real ( KIND = fp ) :: & dx , dy , dz , dxx , dyy , dzz , dxy , dxz , dyz real ( KIND = fp ) :: & xmm , ymm , zmm , & xpp , ypp , zpp real ( KIND = fp ) :: & dum , vexp , tmp ( 3 ) integer :: & k2 , imomfct real ( kind = fp ) :: dr1 ( - 2 : 10 , 3 ), rsqrd integer :: i integer :: ishl , nshl logical :: useList dr1 (: - 1 ,:) = 0 dr1 ( 0 ,:) = 1 useList = present ( shells ) nshl = basis % nshell if ( useList ) nshl = size ( shells ) naos = 0 do ishl = 1 , nshl if ( useList ) then ishell = shells ( ishl ) else ishell = ishl end if associate ( & iatm => basis % origin ( ishell ), & maxi => basis % naos ( ishell ), & offset => basis % ao_offset ( ishell ), & k1 => basis % g_offset ( ishell ), & ncontr => basis % ncontr ( ishell ), & am => basis % am ( ishell )) dr1 ( 1 ,:) = ptxyz - basis % atoms % xyz (: 3 , iatm ) rsqrd = sum ( dr1 ( 1 ,:) ** 2 ) if ( rsqrd <= basis % shell_mx_dist2 ( ishell )) then vexp1 = 0.0_fp vexp2 = 0.0_fp vexp3 = 0.0_fp k2 = ncontr - 1 + k1 do imomfct = k1 , k2 if ( rsqrd > basis % prim_mx_dist2 ( imomfct )) cycle dum = basis % ex ( imomfct ) * rsqrd vexp = exp ( - dum ) * basis % cc ( imomfct ) vexp1 = vexp1 + vexp vexp2 = vexp2 + 2 * vexp * basis % ex ( imomfct ) vexp3 = vexp3 + 4 * vexp * basis % ex ( imomfct ) * basis % ex ( imomfct ) end do else aov ( offset : offset + maxi - 1 ) = 0.0_fp aogx ( offset : offset + maxi - 1 ) = 0.0_fp aogy ( offset : offset + maxi - 1 ) = 0.0_fp aogz ( offset : offset + maxi - 1 ) = 0.0_fp aog2xx ( offset : offset + maxi - 1 ) = 0.0_fp aog2yy ( offset : offset + maxi - 1 ) = 0.0_fp aog2zz ( offset : offset + maxi - 1 ) = 0.0_fp aog2xy ( offset : offset + maxi - 1 ) = 0.0_fp aog2yz ( offset : offset + maxi - 1 ) = 0.0_fp aog2xz ( offset : offset + maxi - 1 ) = 0.0_fp cycle end if naos = naos + 1 loci = offset - 1 select case ( am ) case ( 0 ) !       Special fast code for S functions aov ( offset ) = vexp1 x = dr1 ( 1 , 1 ) y = dr1 ( 1 , 2 ) z = dr1 ( 1 , 3 ) aogx ( offset ) = - vexp2 * x aogy ( offset ) = - vexp2 * y aogz ( offset ) = - vexp2 * z aog2xx ( offset ) = vexp3 * x * x - vexp2 aog2yy ( offset ) = vexp3 * y * y - vexp2 aog2zz ( offset ) = vexp3 * z * z - vexp2 aog2xy ( offset ) = vexp3 * x * y aog2yz ( offset ) = vexp3 * y * z aog2xz ( offset ) = vexp3 * x * z case ( 1 ) !       Special fast code for P functions x = dr1 ( 1 , 1 ) y = dr1 ( 1 , 2 ) z = dr1 ( 1 , 3 ) aov ( offset ) = vexp1 * x aov ( offset + 1 ) = vexp1 * y aov ( offset + 2 ) = vexp1 * z aogx ( offset ) = vexp1 - vexp2 * x * x aogx ( offset + 1 ) = - vexp2 * x * y aogx ( offset + 2 ) = - vexp2 * x * z aogy ( offset ) = - vexp2 * x * y aogy ( offset + 1 ) = vexp1 - vexp2 * y * y aogy ( offset + 2 ) = - vexp2 * y * z aogz ( offset ) = - vexp2 * x * z aogz ( offset + 1 ) = - vexp2 * y * z aogz ( offset + 2 ) = vexp1 - vexp2 * z * z tmp = vexp3 * dr1 ( 1 , 1 : 3 ) * dr1 ( 1 , 1 : 3 ) - vexp2 aog2xx ( offset ) = ( tmp ( 1 ) - 2.0_fp * vexp2 ) * x aog2xx ( offset + 1 ) = tmp ( 1 ) * y aog2xx ( offset + 2 ) = tmp ( 1 ) * z aog2yy ( offset ) = tmp ( 2 ) * x aog2yy ( offset + 1 ) = ( tmp ( 2 ) - 2.0_fp * vexp2 ) * y aog2yy ( offset + 2 ) = tmp ( 2 ) * z aog2zz ( offset ) = tmp ( 3 ) * x aog2zz ( offset + 1 ) = tmp ( 3 ) * y aog2zz ( offset + 2 ) = ( tmp ( 3 ) - 2.0_fp * vexp2 ) * z aog2xy ( offset ) = aog2xx ( offset + 1 ) aog2xy ( offset + 1 ) = aog2yy ( offset ) aog2xy ( offset + 2 ) = vexp3 * x * y * z aog2yz ( offset ) = vexp3 * x * y * z aog2yz ( offset + 1 ) = aog2yy ( offset + 2 ) aog2yz ( offset + 2 ) = aog2zz ( offset + 1 ) aog2xz ( offset ) = aog2xx ( offset + 2 ) aog2xz ( offset + 1 ) = vexp3 * x * y * z aog2xz ( offset + 2 ) = aog2zz ( offset ) case DEFAULT do i = 2 , am + 2 dr1 ( i ,:) = dr1 ( i - 1 ,:) * dr1 ( 1 ,:) end do ! For pure spherical shells, evaluate the full Cartesian value + ! 1st + 2nd derivative vectors, then reduce each to spherical ! (c2s is r-independent, so it commutes with all derivatives). if ( HARMONIC_ACTIVE . and . basis % harmonic ( ishell ) == 1 ) then block integer , parameter :: NV = 10 real ( kind = fp ) :: cb ( NUM_CART_BF ( am ), NV ), sb ( NUM_SPH_BF ( am )) integer :: ns do ityp = 1 , NUM_CART_BF ( am ) ix = cart_x ( ityp , am ); iy = cart_y ( ityp , am ); iz = cart_z ( ityp , am ) x = dr1 ( ix , 1 ); y = dr1 ( iy , 2 ); z = dr1 ( iz , 3 ) xp = dr1 ( ix + 1 , 1 ); yp = dr1 ( iy + 1 , 2 ); zp = dr1 ( iz + 1 , 3 ) xm = ix * dr1 ( ix - 1 , 1 ); ym = iy * dr1 ( iy - 1 , 2 ); zm = iz * dr1 ( iz - 1 , 3 ) xpp = dr1 ( ix + 2 , 1 ); ypp = dr1 ( iy + 2 , 2 ); zpp = dr1 ( iz + 2 , 3 ) xmm = ix * ( ix - 1 ) * dr1 ( ix - 2 , 1 ); ymm = iy * ( iy - 1 ) * dr1 ( iy - 2 , 2 ) zmm = iz * ( iz - 1 ) * dr1 ( iz - 2 , 3 ) dx = - vexp2 * xp + vexp1 * xm dy = - vexp2 * yp + vexp1 * ym dz = - vexp2 * zp + vexp1 * zm dxx = vexp3 * xpp - vexp2 * ( 2 * ix + 1 ) * x + vexp1 * xmm dyy = vexp3 * ypp - vexp2 * ( 2 * iy + 1 ) * y + vexp1 * ymm dzz = vexp3 * zpp - vexp2 * ( 2 * iz + 1 ) * z + vexp1 * zmm dxy = vexp3 * xp * yp - vexp2 * ( xp * ym + xm * yp ) + vexp1 * xm * ym dyz = vexp3 * yp * zp - vexp2 * ( yp * zm + ym * zp ) + vexp1 * ym * zm dxz = vexp3 * xp * zp - vexp2 * ( xp * zm + xm * zp ) + vexp1 * xm * zm cb ( ityp , 1 ) = vexp1 * x * y * z cb ( ityp , 2 ) = dx * y * z cb ( ityp , 3 ) = x * dy * z cb ( ityp , 4 ) = x * y * dz cb ( ityp , 5 ) = dxx * y * z cb ( ityp , 6 ) = x * dyy * z cb ( ityp , 7 ) = x * y * dzz cb ( ityp , 8 ) = dxy * z cb ( ityp , 9 ) = dyz * x cb ( ityp , 10 ) = dxz * y end do ns = NUM_SPH_BF ( am ) call cart2sph_vec ( cb (:, 1 ), sb , am ); aov ( offset : offset + ns - 1 ) = sb call cart2sph_vec ( cb (:, 2 ), sb , am ); aogx ( offset : offset + ns - 1 ) = sb call cart2sph_vec ( cb (:, 3 ), sb , am ); aogy ( offset : offset + ns - 1 ) = sb call cart2sph_vec ( cb (:, 4 ), sb , am ); aogz ( offset : offset + ns - 1 ) = sb call cart2sph_vec ( cb (:, 5 ), sb , am ); aog2xx ( offset : offset + ns - 1 ) = sb call cart2sph_vec ( cb (:, 6 ), sb , am ); aog2yy ( offset : offset + ns - 1 ) = sb call cart2sph_vec ( cb (:, 7 ), sb , am ); aog2zz ( offset : offset + ns - 1 ) = sb call cart2sph_vec ( cb (:, 8 ), sb , am ); aog2xy ( offset : offset + ns - 1 ) = sb call cart2sph_vec ( cb (:, 9 ), sb , am ); aog2yz ( offset : offset + ns - 1 ) = sb call cart2sph_vec ( cb (:, 10 ), sb , am ); aog2xz ( offset : offset + ns - 1 ) = sb end block else do ityp = 1 , maxi ix = cart_x ( ityp , am ) iy = cart_y ( ityp , am ) iz = cart_z ( ityp , am ) !         0 components: x = dr1 ( ix , 1 ) y = dr1 ( iy , 2 ) z = dr1 ( iz , 3 ) !         +1 components xp = dr1 ( ix + 1 , 1 ) yp = dr1 ( iy + 1 , 2 ) zp = dr1 ( iz + 1 , 3 ) !         -1 components xm = ix * dr1 ( ix - 1 , 1 ) ym = iy * dr1 ( iy - 1 , 2 ) zm = iz * dr1 ( iz - 1 , 3 ) !         +2 components xpp = dr1 ( ix + 2 , 1 ) ypp = dr1 ( iy + 2 , 2 ) zpp = dr1 ( iz + 2 , 3 ) !         -2 components xmm = ix * ( ix - 1 ) * dr1 ( ix - 2 , 1 ) ymm = iy * ( iy - 1 ) * dr1 ( iy - 2 , 2 ) zmm = iz * ( iz - 1 ) * dr1 ( iz - 2 , 3 ) !         AO value: aov ( loci + ityp ) = vexp1 * x * y * z !         First AO derivatives: dx = - vexp2 * xp + vexp1 * xm dy = - vexp2 * yp + vexp1 * ym dz = - vexp2 * zp + vexp1 * zm aogx ( loci + ityp ) = dx * y * z aogy ( loci + ityp ) = x * dy * z aogz ( loci + ityp ) = x * y * dz !         Second AO derivatives: dxx = vexp3 * xpp - vexp2 * ( 2 * ix + 1 ) * x + vexp1 * xmm dyy = vexp3 * ypp - vexp2 * ( 2 * iy + 1 ) * y + vexp1 * ymm dzz = vexp3 * zpp - vexp2 * ( 2 * iz + 1 ) * z + vexp1 * zmm aog2xx ( loci + ityp ) = dxx * y * z aog2yy ( loci + ityp ) = x * dyy * z aog2zz ( loci + ityp ) = x * y * dzz dxy = vexp3 * xp * yp - vexp2 * ( xp * ym + xm * yp ) + vexp1 * xm * ym dyz = vexp3 * yp * zp - vexp2 * ( yp * zm + ym * zp ) + vexp1 * ym * zm dxz = vexp3 * xp * zp - vexp2 * ( xp * zm + xm * zp ) + vexp1 * xm * zm aog2xy ( loci + ityp ) = dxy * z aog2yz ( loci + ityp ) = dyz * x aog2xz ( loci + ityp ) = dxz * y end do end if end select end associate end do end subroutine !------------------------------------------------------------------------------- !> @brief Compute maximum extent of basis set primitives up to a given !>  tolerance. !> @details Find the largest root of the eqn.: r**n * exp(-a*r**2) = tol, !>  and fill prim_mx_dist2 array with correspoinding r**2 values !>  For n==0 (S shells) the solution is trivial. !>  For n>0 (P,D,F... shells) the equivalent equation is used: !>      ln(q)/2 - a*q/n - ln(tol)/n == 0, where q = r**2 !>  The solution of this equation is: !>      q = -n/(2*a) * W_{-1} (-(2*a/n)*tol**(2/n)) !>  where W_{k} (x) - k-th branch of Lambert W function !>  Assuming that a << 0.5*tol**(-2/n), W_{-1} (x) can be approximated: !>      W_{-1} (-x) =  log(x) - log(-log(x)) !>  The assumption holds for reasonable basis sets. !>  Next, the approximated result is then refined by making 1-2 !>  Newton-Raphson steps. !>  The error of this approximation is (much) less than 10**(-4) Bohr**2 !>  for typical cases: !>  a < 10&#94;6, n = (1 to 3) (P to F shells), tol = 10**(-10) !>  a < 10&#94;3, n = (4 to 6) (G to I shells), tol = 10**(-10) !  TODO: move to basis set related source file !> @param[in] basis     basis set variable !> @param[in] mlogtol   -ln(tol) value !> @author Vladimir Mironov subroutine comp_basis_mxdists ( basis , mLogTol ) use precision , only : dp class ( basis_set ), intent ( INOUT ) :: basis real ( KIND = dp ), intent ( IN ) :: mLogTol real ( KIND = dp ) :: tmpLogs ( 1 : BAS_MXANG ), logLogTol integer :: ish , i if ( allocated ( basis % at_mx_dist2 )) deallocate ( basis % at_mx_dist2 ) allocate ( basis % at_mx_dist2 ( ubound ( basis % atoms % zn , 1 )), source =- 1.0_dp ) if ( allocated ( basis % prim_mx_dist2 )) deallocate ( basis % prim_mx_dist2 ) allocate ( basis % prim_mx_dist2 ( basis % nPrim )) if ( allocated ( basis % shell_mx_dist2 )) deallocate ( basis % shell_mx_dist2 ) allocate ( basis % shell_mx_dist2 ( basis % nShell )) logLogTol = log ( mLogTol ) tmpLogs = [( logLogTol + 2.0 * mLogTol / i , i = 1 , BAS_MXANG )] do ish = 1 , basis % nShell basis % shell_mx_dist2 ( ish ) = 0.0 do i = basis % g_offset ( ish ), basis % g_offset ( ish ) + basis % ncontr ( ish ) - 1 associate ( n => basis % am ( ish ), & a => basis % ex ( i ), & r2 => basis % prim_mx_dist2 ( i ), & r2sh => basis % shell_mx_dist2 ( ish )) if ( n == 0 ) then !                   Explicit solution: r2 = mLogTol / a else if ( n < 5 ) then !                   Approximate result: r2 = 0.5d0 * n / a * ( tmpLogs ( n ) - log ( a )) !                   One NR step: r2 = r2 * ( 1 - 2 * ( 0.5d0 * n * log ( r2 ) - a * r2 + mLogTol ) / ( n - 2 * a * r2 )) else !                   Approximate result: r2 = 0.5d0 * n / a * ( tmplogs ( n ) - log ( a )) !                   Two NR steps: r2 = r2 * ( 1 - 2 * ( 0.5d0 * n * log ( r2 ) - a * r2 + mLogTol ) / ( n - 2 * a * r2 )) r2 = r2 * ( 1 - 2 * ( 0.5d0 * n * log ( r2 ) - a * r2 + mLogTol ) / ( n - 2 * a * r2 )) end if r2sh = max ( r2 , r2sh ) end associate end do end do do ish = 1 , basis % nShell associate ( iat => basis % origin ( ish ) ) basis % at_mx_dist2 ( iat ) = & max ( basis % at_mx_dist2 ( iat ), basis % shell_mx_dist2 ( ish )) end associate end do end subroutine !> @brief Initialize array of shell centers used in electronic integral code subroutine init_shell_centers ( basis ) class ( basis_set ), intent ( inout ) :: basis if ( allocated ( basis % shell_centers )) deallocate ( basis % shell_centers ) allocate ( basis % shell_centers ( basis % nshell , 3 )) basis % shell_centers ( 1 : basis % nshell , 1 ) = basis % atoms % xyz ( 1 , basis % origin ( 1 : basis % nshell )) basis % shell_centers ( 1 : basis % nshell , 2 ) = basis % atoms % xyz ( 2 , basis % origin ( 1 : basis % nshell )) basis % shell_centers ( 1 : basis % nshell , 3 ) = basis % atoms % xyz ( 3 , basis % origin ( 1 : basis % nshell )) end subroutine !> @brief   Apply selected basis set library to the molecule !> @param[inout]   basis        applied basis set to system !> @param[in]      basis_file   path to basis set in OQP basis set format !> @param[in]      atoms        atoms in systems (pointer to this variable will be set) !> @param[out]      err        err flag subroutine from_file ( basis , basis_file , atoms , err ) use constants , only : bf_names use elements , only : ELEMENTS_ATOMNAME , MAX_ELEMENT_Z use messages , only : show_message use atomic_structure_m , only : atomic_structure use basis_library , only : basis_library_t implicit none class ( basis_set ), intent ( inout ) :: basis character ( len =* ), intent ( in ) :: basis_file type ( atomic_structure ), target , intent ( in ) :: atoms logical , intent ( out ) :: err type ( basis_library_t ) :: basis_lib integer :: i , nshell , nbasis , ngauss , n character ( len = 4 ) :: bfl character ( len = 2 ) :: label integer :: num , zn , iatshort integer , allocatable :: atom_numbers (:) ! err = . false . basis % atoms => atoms call basis_lib % from_file ( basis_file ) atom_numbers = int ( atoms % zn ) !   Compute requried memory space for basis call basis_lib % calc_req_storage ( atom_numbers , & nshell , ngauss , nbasis ) !   Allocate basis call basis % reserve ( nshell , ngauss , nbasis ) !   Add atoms one by one nbasis = 0 do i = 1 , size ( atom_numbers ) associate ( atom => basis_lib % atoms ( atom_numbers ( i ))) call basis % append ( atom , i , atom_numbers ( i ), err ) !   ...... Remove after cleanup ...... nbasis = nbasis + atom % nbfs !   &#94;&#94;&#94;&#94;&#94;&#94; Remove after cleanup &#94;&#94;&#94;&#94;&#94;&#94; end associate end do !   Set primitive norms call basis % normalize_primitives call basis % normalize_contracted !   Set BF norms call basis % set_bfnorms end subroutine from_file function bf_label ( basis , bf ) result ( label ) use constants , only : bf_names use elements , only : ELEMENTS_ATOMNAME , MAX_ELEMENT_Z implicit none class ( basis_set ), intent ( in ) :: basis integer , intent ( in ) :: bf character ( len = 8 ) :: label character ( len = 2 ) :: atname character ( len = 2 ) :: atshort integer :: i , zn i = bf_to_shell ( basis , bf ) associate ( iat => basis % origin ( i ) & , ao => basis % ao_offset ( i ) & , am => basis % am ( i ) & , nbf => basis % naos ( i ) & ) zn = min ( int ( basis % atoms % zn ( iat )), MAX_ELEMENT_Z ) atname = \"\" if ( zn > 0 ) atname = ELEMENTS_ATOMNAME ( zn ) write ( unit = atshort , fmt = '(i2)' ) mod ( iat , 100 ) label = atname // atshort // bf_names ( bf - ao + 1 , am ) end associate end function function bf_to_shell ( basis , bf ) result ( res ) class ( basis_set ), intent ( in ) :: basis integer , intent ( in ) :: bf integer :: res integer , parameter :: mxloop = 100 integer :: i , h , l res = 0 l = 1 h = basis % nshell if ( bf < 1 . or . bf > basis % nbf ) return if ( basis % ao_offset ( h ) <= bf ) then res = h return end if do i = 1 , mxloop res = ( l + h ) / 2 if ( l == h - 1 ) exit if ( basis % ao_offset ( res ) > bf ) then h = res else l = res end if end do if ( i > mxloop ) res = 0 end function subroutine basis_broadcast ( basis , comm , usempi ) use iso_c_binding , only : c_bool class ( basis_set ), intent ( inout ) :: basis type ( par_env_t ) :: pe integer , parameter :: int32 = selected_int_kind ( 9 ) integer ( kind = int32 ) :: comm integer :: length integer :: i , j logical ( c_bool ), intent ( in ) :: usempi ! Initialize MPI call pe % init ( comm , usempi ) length = 1 ! Broadcast the scalar integers call pe % bcast ( basis % nshell , length ) call pe % bcast ( basis % nprim , length ) call pe % bcast ( basis % nbf , length ) call pe % bcast ( basis % mxcontr , length ) call pe % bcast ( basis % mxam , length ) if ( pe % rank /= 0 ) then ! Allocate arrays based on the received sizes (on all processes) if (. not . allocated ( basis % ex )) allocate ( basis % ex ( basis % nprim )) if (. not . allocated ( basis % cc )) allocate ( basis % cc ( basis % nprim )) if (. not . allocated ( basis % bfnrm )) allocate ( basis % bfnrm ( basis % nbf )) if (. not . allocated ( basis % g_offset )) allocate ( basis % g_offset ( basis % nshell )) if (. not . allocated ( basis % origin )) allocate ( basis % origin ( basis % nshell )) if (. not . allocated ( basis % am )) allocate ( basis % am ( basis % nshell )) if (. not . allocated ( basis % harmonic )) allocate ( basis % harmonic ( basis % nshell ), source = 0 ) if (. not . allocated ( basis % ncontr )) allocate ( basis % ncontr ( basis % nshell )) if (. not . allocated ( basis % ao_offset )) allocate ( basis % ao_offset ( basis % nshell )) if (. not . allocated ( basis % naos )) allocate ( basis % naos ( basis % nshell )) if (. not . allocated ( basis % at_mx_dist2 )) allocate ( basis % at_mx_dist2 ( basis % nbf )) if (. not . allocated ( basis % prim_mx_dist2 )) allocate ( basis % prim_mx_dist2 ( basis % nprim )) if (. not . allocated ( basis % shell_mx_dist2 )) allocate ( basis % shell_mx_dist2 ( basis % nshell )) if (. not . allocated ( basis % shell_centers )) allocate ( basis % shell_centers ( basis % nshell , 3 )) endif ! Broadcast the arrays call pe % bcast ( basis % ex , basis % nprim ) call pe % bcast ( basis % cc , basis % nprim ) call pe % bcast ( basis % bfnrm , basis % nbf ) call pe % bcast ( basis % g_offset , basis % nshell ) call pe % bcast ( basis % origin , basis % nshell ) call pe % bcast ( basis % am , basis % nshell ) call pe % bcast ( basis % harmonic , basis % nshell ) call pe % bcast ( basis % ncontr , basis % nshell ) call pe % bcast ( basis % ao_offset , basis % nshell ) call pe % bcast ( basis % naos , basis % nshell ) if (. not . allocated ( basis % ecp_zn_num )) allocate ( basis % ecp_zn_num ( maxval ( basis % origin ))) call pe % bcast ( basis % ecp_zn_num , maxval ( basis % origin )) end subroutine basis_broadcast end module","tags":"","url":"sourcefile/basis_tools.f90.html"},{"title":"printing.F90 – OpenQP Fortran API","text":"Source Code module printing use precision , only : dp implicit none character ( len =* ), parameter :: module_name = \"printing\" private public :: print_module_info public :: print_sym_labeled public :: print_mo_range public :: print_eigvec_vals_labeled public :: print_square public :: print_sympack public :: print_sym public :: print_ev_sol contains !> @brief Print MODULE information !> @detail Printout the information of each MODULES of OQP subroutine print_module_info ( module_title , module_info ) use io_constants , only : iw implicit none character ( len =* ), intent ( in ) :: module_title , module_info write ( iw , '(/20x,40(\"+\")/& &23X,\"MODULE: \",A/& &23X,A/& &20X,40(\"+\"))' ) module_title , module_info end subroutine print_module_info !> @brief Print symmetric packed matrix `d` of dimension `n` !> @detail The rows will be labeled with basis function tags subroutine print_sym_labeled ( d , n , basis ) use precision , only : dp use io_constants , only : iw use basis_tools , only : basis_set implicit none real ( kind = dp ), intent ( in ) :: d ( * ) integer , intent ( in ) :: n type ( basis_set ), intent ( in ) :: basis integer , parameter :: maxcolumns = 5 integer :: i0 , ila , i , j0 , j1 do i0 = 1 , n , maxcolumns write ( iw , '(/,15x,*(4x,i4,3x))' ) ( i , i = i0 , min ( n , i0 + maxcolumns - 1 )) write ( iw , '(G0)' ) ila = 0 do i = i0 , n j0 = i0 + i * ( i - 1 ) / 2 j1 = j0 + min ( ila , maxcolumns - 1 ) write ( iw , '(i5,2x,a8,*(f11.6))' ) i , basis % bf_label ( i ), d ( j0 : j1 ) ila = ila + 1 end do end do end subroutine print_sym_labeled !> @brief Printing out MOs subroutine print_mo_range ( basis , infos , mostart , moend ) use io_constants , only : iw use types , only : information use basis_tools , only : basis_set implicit none type ( basis_set ), intent ( in ) :: basis type ( information ), intent ( inout ) :: infos integer , intent ( in ) :: mostart , moend integer :: mo0 , mo1 if (. not . infos % mol_energy % SCF_converged & . and . infos % control % verbose < 2 ) return write ( iw , fmt = \"(/& &10x, 31('=')/& &10x, 'Molecular Orbitals and Energies'/& &10x, 31('='))\" ) mo0 = max ( mostart , 1 ) mo1 = min ( moend , basis % nbf ) call print_eigvec_vals_labeled ( basis , infos , mo0 , mo1 ) end subroutine print_mo_range !> !>    @brief    print eigenvector/values, with MO symmetry labels subroutine print_eigvec_vals_labeled ( basis , infos , mostart , moend ) use io_constants , only : iw use oqp_tagarray_driver use types , only : information use basis_tools , only : basis_set use messages , only : show_message , with_abort implicit none character ( len =* ), parameter :: subroutine_name = \"print_eigvec_vals_labeled\" type ( basis_set ), intent ( in ) :: basis type ( information ), intent ( inout ) :: infos integer , intent ( in ) :: mostart , moend integer :: i , imax , imin , j , nmax character ( len =* ), parameter :: fmt1 = '(/15x,10(8x,i4,5x))' character ( len =* ), parameter :: fmt2 = '(15x,10f17.10)' character ( len =* ), parameter :: fmt4 = '(i5,2x,a8,10f17.10)' ! tagarray real ( kind = dp ), contiguous , pointer :: & mo_energy_a (:), mo_energy_b (:), mo_a (:,:), mo_b (:,:) character ( len =* ), parameter :: tags_alpha ( 2 ) = ( / character ( len = 80 ) :: & OQP_E_MO_A , OQP_VEC_MO_A / ) character ( len =* ), parameter :: tags_beta ( 2 ) = ( / character ( len = 80 ) :: & OQP_E_MO_B , OQP_VEC_MO_B / ) !Print out eigendata, with mo symmetry labels !The rows are labeled with the basis function names. nmax = 5 call data_has_tags ( infos % dat , tags_alpha , module_name , subroutine_name , WITH_ABORT ) call tagarray_get_data ( infos % dat , OQP_E_MO_A , mo_energy_a ) call tagarray_get_data ( infos % dat , OQP_VEC_MO_A , mo_a ) write ( iw , '(/,A)' ) '   -------------- Alpha Orbitals -------------' do imin = mostart , moend , nmax imax = min ( imin + nmax - 1 , moend ) write ( iw , fmt1 ) ( i , i = imin , imax ) write ( iw , fmt2 ) ( mo_energy_a ( i ), i = imin , imax ) do j = 1 , basis % nbf write ( iw , fmt4 ) j , basis % bf_label ( j ), mo_a ( j , imin : imax ) end do end do if (( infos % mol_prop % nelec_b /= 0 ) . and . ( infos % control % scftype == 2 )) then call data_has_tags ( infos % dat , tags_beta , module_name , subroutine_name , WITH_ABORT ) call tagarray_get_data ( infos % dat , OQP_E_MO_B , mo_energy_b ) call tagarray_get_data ( infos % dat , OQP_VEC_MO_B , mo_b ) write ( iw , '(/,A)' ) '   -------------- Beta Orbitals -------------' do imin = mostart , moend , nmax imax = min ( imin + nmax - 1 , moend ) write ( iw , fmt1 ) ( i , i = imin , imax ) write ( iw , fmt2 ) ( mo_energy_b ( i ), i = imin , imax ) do j = 1 , basis % nbf write ( iw , fmt4 ) j , basis % bf_label ( j ), mo_b ( j , imin : imax ) end do end do end if end subroutine print_eigvec_vals_labeled !> @brief Print out a square matrix !> @param[in] v           rectanbular matrix !> @param[in] m           number of columns in `V` !> @param[in] n           number of rows in `V` !> @param[in] ndim        leading dimension of `V` !> @param[in] tag         optional, will be printed at the beginning of each line !> @param[in] maxcolumns  optional, number of columns to wrap printing subroutine print_square ( v , m , n , ndim , tag , maxcolumns ) use io_constants , only : iw implicit none real ( kind = dp ), intent ( in ) :: V ( NDIM , M ) integer , intent ( in ) :: m , n , ndim integer , optional , intent ( in ) :: maxcolumns character ( * ), optional , intent ( in ) :: tag character (:), allocatable :: ttag integer :: imin , imax , i , j , mxlen mxlen = m if ( present ( maxcolumns )) mxlen = maxcolumns if ( present ( tag )) then ttag = trim ( tag ) else ttag = \"\" end if do imin = 1 , m , mxlen imax = min ( imin + mxlen - 1 , m ) write ( iw , '(a)' ) ttag write ( iw , '(a,6x, *(4x, i4, 4x))' ) ttag , ( i , i = imin , imax ) write ( iw , '(a)' ) ttag do j = 1 , n write ( iw , '(a,i5, 1x, *(f12.7))' ) ttag , j , ( v ( j , i ), i = imin , imax ) end do end do end subroutine !> @brief Print out a symmetric matrix in packed format !> @param[in] d           symmetric matrix in packed format !> @param[in] n           matric dimension subroutine print_sympack ( d , n ) use io_constants , only : iw implicit none real ( kind = dp ), intent ( in ) :: d ( * ) integer , intent ( in ) :: n integer , parameter :: mxlen = 5 integer :: i , j , i0 , il , j0 , jl do i0 = 1 , n , mxlen write ( iw , '(/,6x,*(4x,I4,4x))' ) ( i , i = i0 , min ( n , i0 + mxlen - 1 )) write ( iw , * ) do i = i0 , n il = i - i0 j0 = i0 + ( i * i - i ) / 2 jl = j0 + min ( il , mxlen - 1 ) write ( iw , '(i5,1x,*(f12.7))' ) i , ( d ( j ), j = j0 , jl ) end do end do end subroutine !> @brief Print symmetric matrix `D` in square format !> @param[in]   d   matrix to print, only lower triangle is referenced !> @param[in]   n   rank of matrix `D` !> @param[in]   ld  leading dimension of matrix `D` subroutine print_sym ( d , n , ld ) use io_constants , only : iw implicit none real ( kind = dp ), intent ( in ) :: d ( ld , * ) integer , intent ( in ) :: n , ld integer , parameter :: mxlen = 5 integer :: j , i , i0 do i0 = 1 , n , mxlen write ( iw , fmt = '(/,6x,*(4x,i4,4x))' ) ( i , i = i0 , min ( n , i0 + mxlen - 1 )) write ( iw , * ) do i = i0 , n write ( iw , fmt = '(i5,x,*(f12.7))' ) i , ( d ( j , i ), j = i0 , min ( n , i0 + min ( i - i0 , mxlen - 1 ))) end do end do end subroutine !> @brief Print the solution of the eigenvalue problem !> @param[in]   v    matrix of eigenvectors, v(ldv,m) !> @param[in]   e    array of eigenvectors, e(m) !> @param[in]   m    dimension of column space !> @param[in]   n    dimension of row space !> @param[in]   ldv  leading dimension of `V` subroutine print_ev_sol ( v , e , m , n , ldv ) use io_constants , only : iw implicit none real ( kind = dp ), intent ( in ) :: v ( ldv , m ), e ( m ) integer , intent ( in ) :: m , n , ldv integer , parameter :: mxlen = 5 integer :: i , j , i0 , i1 do i0 = 1 , m , mxlen i1 = min ( m , i0 + mxlen - 1 ) write ( iw , '(/,15x,*(4x,i4,3x))' ) ( i , i = i0 , i1 ) write ( iw , '(/,15x,*(f11.6))' ) ( e ( i ), i = i0 , i1 ) write ( iw , * ) do j = 1 , n write ( iw , '(i5,10x,*(f11.6))' ) j , ( v ( j , i ), i = i0 , i1 ) end do end do end subroutine end module printing","tags":"","url":"sourcefile/printing.f90.html"},{"title":"rys_deriv.F90 – OpenQP Fortran API","text":"Source Code module rys_deriv ! Analytic X-derivatives of the closed-form Rys roots/weights ! rys_rt1..rys_rt5, via complex-step differentiation of type-substituted ! clones of the value routines in rys.F90. Gate 1 of the native ! nuclear-attraction Hessian. Generated mechanically (no hand transcription). use precision , only : dp use constants , only : pi implicit none real ( dp ), parameter :: pio4 = pi / 4.0_dp private public :: rys_rt1_d , rys_rt2_d , rys_rt3_d , rys_rt4_d , rys_rt5_d contains subroutine rys_rt1_d ( x , dr , dw ) ! Complex-step analytic derivatives du/dX, dw/dX of rys_rt1 (1 root). real ( KIND = dp ), intent ( IN ) :: x real ( KIND = dp ), intent ( OUT ) :: dr ( 1 ), dw ( 1 ) complex ( KIND = dp ) :: xc , rc , wc real ( KIND = dp ), parameter :: hcs = 1.0e-20_dp xc = cmplx ( x , hcs , KIND = dp ) call rys_rt1_csval ( xc , rc , wc ) dr ( 1 ) = aimag ( rc ) / hcs dw ( 1 ) = aimag ( wc ) / hcs end subroutine rys_rt1_d subroutine rys_rt1_csval ( x , r , w ) complex ( KIND = dp ), intent ( IN ) :: & x complex ( KIND = dp ), intent ( OUT ) :: & r complex ( KIND = dp ), intent ( OUT ) :: & w complex ( KIND = dp ) :: & f1 , y , recx , e if ( real ( x ) <= 3.0e-07_dp ) then r = ( 2.5e+00_dp - x ) / ( 7.5e+00_dp - x ) w = 1.0e+00_dp - x / 3.0e+00_dp elseif ( real ( x ) <= 1.0e+00_dp ) then f1 = (((((((( - 8.36313918003957e-08_dp * x + & 1.21222603512827e-06_dp ) * x - & 1.15662609053481e-05_dp ) * x + & 9.25197374512647e-05_dp ) * x - & 6.40994113129432e-04_dp ) * x + & 3.78787044215009e-03_dp ) * x - & 1.85185172458485e-02_dp ) * x + & 7.14285713298222e-02_dp ) * x - & 1.99999999997023e-01_dp ) * x + & 3.33333333333318e-01_dp w = 2 * x * f1 + exp ( - x ) r = f1 / w elseif ( real ( x ) <= 3.0e+00_dp ) then y = x - 2.0e+00_dp f1 = (((((((((( - 1.61702782425558e-10_dp * y + & 1.96215250865776e-09_dp ) * y - & 2.14234468198419e-08_dp ) * y + & 2.17216556336318e-07_dp ) * y - & 1.98850171329371e-06_dp ) * y + & 1.62429321438911e-05_dp ) * y - & 1.16740298039895e-04_dp ) * y + & 7.24888732052332e-04_dp ) * y - & 3.79490003707156e-03_dp ) * y + & 1.61723488664661e-02_dp ) * y - & 5.29428148329736e-02_dp ) * y + & 1.15702180856167e-01_dp w = 2 * x * f1 + exp ( - x ) r = f1 / w elseif ( real ( x ) <= 5.0e+00_dp ) then y = x - 4.0e+00_dp f1 = (((((((((( - 2.62453564772299e-11_dp * y + & 3.24031041623823e-10_dp ) * y - & 3.614965656163e-09_dp ) * y + & 3.760256799971e-08_dp ) * y - & 3.553558319675e-07_dp ) * y + & 3.022556449731e-06_dp ) * y - & 2.290098979647e-05_dp ) * y + & 1.526537461148e-04_dp ) * y - & 8.81947375894379e-04_dp ) * y + & 4.33207949514611e-03_dp ) * y - & 1.75257821619926e-02_dp ) * y + & 5.28406320615584e-02_dp w = 2 * x * f1 + exp ( - x ) r = f1 / w elseif ( real ( x ) <= 1 0.0e+00_dp ) then e = exp ( - x ) recx = 1.0e+00_dp / x w = (((((( 4.6897511375022e-01_dp * recx - & 6.9955602298985e-01_dp ) * recx + & 5.3689283271887e-01_dp ) * recx - & 3.2883030418398e-01_dp ) * recx + & 2.4645596956002e-01_dp ) * recx - & 4.9984072848436e-01_dp ) * recx - & 3.1501078774085e-06_dp ) * e + sqrt ( PIo4 * recx ) f1 = recx * ( w - e ) / 2 r = f1 / w elseif ( real ( x ) <= 1 5.0e+00_dp ) then e = exp ( - x ) recx = 1.0e+00_dp / x w = ((( - 1.8784686463512e-01_dp * recx + & 2.2991849164985e-01_dp ) * recx - & 4.9893752514047e-01_dp ) * recx - & 2.1916512131607e-05_dp ) * e + sqrt ( PIo4 * recx ) f1 = recx * ( w - e ) / 2 r = f1 / w elseif ( real ( x ) <= 3 3.0e+00_dp ) then e = exp ( - x ) recx = 1.0e+00_dp / x w = (( 1.9623264149430e-01_dp * recx - & 4.9695241464490e-01_dp ) * recx - & 6.0156581186481e-05_dp ) * e + sqrt ( PIo4 * recx ) f1 = recx * ( w - e ) / 2 r = f1 / w else recx = 1.0e+00_dp / x w = sqrt ( PIo4 * recx ) r = 0.5e+00_dp * recx end if r = r / ( 1.0e00_dp - r ) end subroutine rys_rt1_csval subroutine rys_rt2_d ( x , dr , dw ) ! Complex-step analytic derivatives du_t/dX, dw_t/dX of rys_rt2. ! dr(t)=du_t/dX, dw(t)=dw_t/dX, to machine precision (no cancellation). real ( KIND = dp ), intent ( IN ) :: x real ( KIND = dp ), intent ( OUT ) :: dr ( 2 ), dw ( 2 ) complex ( KIND = dp ) :: xc , rc ( 2 ), wc ( 2 ) real ( KIND = dp ), parameter :: hcs = 1.0e-20_dp xc = cmplx ( x , hcs , KIND = dp ) call rys_rt2_csval ( xc , rc , wc ) dr = aimag ( rc ) / hcs dw = aimag ( wc ) / hcs end subroutine rys_rt2_d subroutine rys_rt2_csval ( x , r , w ) complex ( KIND = dp ), intent ( IN ) :: & x complex ( KIND = dp ), intent ( OUT ) :: & r ( 2 ), w ( 2 ) real ( KIND = dp ), parameter :: & r12 = 2.75255128608411e-01_dp , & r22 = 2.72474487139158e+00_dp , & w22 = 9.17517095361369e-02_dp complex ( KIND = dp ) :: & f1 , y , recx , e , r1 , r2 , w1 , w2 if ( real ( x ) <= 3.0e-07_dp ) then r1 = 1.30693606237085e-01_dp - 2.90430236082028e-02_dp * x r2 = 2.86930639376291e+00_dp - 6.37623643058102e-01_dp * x w1 = 6.52145154862545e-01_dp - 1.22713621927067e-01_dp * x w2 = 3.47854845137453e-01_dp - 2.10619711404725e-01_dp * x elseif ( real ( x ) <= 1.0e+00_dp ) then f1 = (((((((( - 8.36313918003957e-08_dp * x + & 1.21222603512827e-06_dp ) * x - & 1.15662609053481e-05_dp ) * x + & 9.25197374512647e-05_dp ) * x - & 6.40994113129432e-04_dp ) * x + & 3.78787044215009e-03_dp ) * x - & 1.85185172458485e-02_dp ) * x + & 7.14285713298222e-02_dp ) * x - & 1.99999999997023e-01_dp ) * x + & 3.33333333333318e-01_dp w1 = 2 * x * f1 + exp ( - x ) r1 = ((((((( - 2.35234358048491e-09_dp * x + & 2.49173650389842e-08_dp ) * x - & 4.558315364581e-08_dp ) * x - & 2.447252174587e-06_dp ) * x + & 4.743292959463e-05_dp ) * x - & 5.33184749432408e-04_dp ) * x + & 4.44654947116579e-03_dp ) * x - & 2.90430236084697e-02_dp ) * x + & 1.30693606237085e-01_dp r2 = ((((((( - 2.47404902329170e-08_dp * x + & 2.36809910635906e-07_dp ) * x + & 1.835367736310e-06_dp ) * x - & 2.066168802076e-05_dp ) * x - & 1.345693393936e-04_dp ) * x - & 5.88154362858038e-05_dp ) * x + & 5.32735082098139e-02_dp ) * x - & 6.37623643056745e-01_dp ) * x + & 2.86930639376289e+00_dp w2 = (( f1 - w1 ) * r1 + f1 ) * ( 1.0e+00_dp + r2 ) / ( r2 - r1 ) w1 = w1 - w2 elseif ( real ( x ) <= 3.0e+00_dp ) then y = x - 2.0e+00_dp f1 = (((((((((( - 1.61702782425558e-10_dp * y + & 1.96215250865776e-09_dp ) * y - & 2.14234468198419e-08_dp ) * y + & 2.17216556336318e-07_dp ) * y - & 1.98850171329371e-06_dp ) * y + & 1.62429321438911e-05_dp ) * y - & 1.16740298039895e-04_dp ) * y + & 7.24888732052332e-04_dp ) * y - & 3.79490003707156e-03_dp ) * y + & 1.61723488664661e-02_dp ) * y - & 5.29428148329736e-02_dp ) * y + & 1.15702180856167e-01_dp w1 = 2 * x * f1 + exp ( - x ) r1 = ((((((((( - 6.36859636616415e-12_dp * y + & 8.47417064776270e-11_dp ) * y - & 5.152207846962e-10_dp ) * y - & 3.846389873308e-10_dp ) * y + & 8.472253388380e-08_dp ) * y - & 1.85306035634293e-06_dp ) * y + & 2.47191693238413e-05_dp ) * y - & 2.49018321709815e-04_dp ) * y + & 2.19173220020161e-03_dp ) * y - & 1.63329339286794e-02_dp ) * y + & 8.68085688285261e-02_dp r2 = ((((((((( 1.45331350488343e-10_dp * y + & 2.07111465297976e-09_dp ) * y - & 1.878920917404e-08_dp ) * y - & 1.725838516261e-07_dp ) * y + & 2.247389642339e-06_dp ) * y + & 9.76783813082564e-06_dp ) * y - & 1.93160765581969e-04_dp ) * y - & 1.58064140671893e-03_dp ) * y + & 4.85928174507904e-02_dp ) * y - & 4.30761584997596e-01_dp ) * y + & 1.80400974537950e+00_dp w2 = (( f1 - w1 ) * r1 + f1 ) * ( 1.0e+00_dp + r2 ) / ( r2 - r1 ) w1 = w1 - w2 elseif ( real ( x ) <= 5.0e+00_dp ) then y = x - 4.0e+00_dp f1 = (((((((((( - 2.62453564772299e-11_dp * y + & 3.24031041623823e-10_dp ) * y - & 3.614965656163e-09_dp ) * y + & 3.760256799971e-08_dp ) * y - & 3.553558319675e-07_dp ) * y + & 3.022556449731e-06_dp ) * y - & 2.290098979647e-05_dp ) * y + & 1.526537461148e-04_dp ) * y - & 8.81947375894379e-04_dp ) * y + & 4.33207949514611e-03_dp ) * y - & 1.75257821619926e-02_dp ) * y + & 5.28406320615584e-02_dp w1 = 2 * x * f1 + exp ( - x ) r1 = (((((((( - 4.11560117487296e-12_dp * y + & 7.10910223886747e-11_dp ) * y - & 1.73508862390291e-09_dp ) * y + & 5.93066856324744e-08_dp ) * y - & 9.76085576741771e-07_dp ) * y + & 1.08484384385679e-05_dp ) * y - & 1.12608004981982e-04_dp ) * y + & 1.16210907653515e-03_dp ) * y - & 9.89572595720351e-03_dp ) * y + & 6.12589701086408e-02_dp r2 = ((((((((( - 1.80555625241001e-10_dp * y + & 5.44072475994123e-10_dp ) * y + & 1.603498045240e-08_dp ) * y - & 1.497986283037e-07_dp ) * y - & 7.017002532106e-07_dp ) * y + & 1.85882653064034e-05_dp ) * y - & 2.04685420150802e-05_dp ) * y - & 2.49327728643089e-03_dp ) * y + & 3.56550690684281e-02_dp ) * y - & 2.60417417692375e-01_dp ) * y + & 1.12155283108289e+00_dp w2 = (( f1 - w1 ) * r1 + f1 ) * ( 1.0e+00_dp + r2 ) / ( r2 - r1 ) w1 = w1 - w2 elseif ( real ( x ) <= 1 0.0e+00_dp ) then e = exp ( - x ) recx = 1.0e+00_dp / x w1 = (((((( 4.6897511375022e-01_dp * recx - & 6.9955602298985e-01_dp ) * recx + & 5.3689283271887e-01_dp ) * recx - & 3.2883030418398e-01_dp ) * recx + & 2.4645596956002e-01_dp ) * recx - & 4.9984072848436e-01_dp ) * recx - & 3.1501078774085e-06_dp ) * e + sqrt ( PIo4 * recx ) f1 = recx * ( w1 - e ) / 2 y = x - 7.5e+00_dp r1 = ((((((((((((( - 1.43632730148572e-16_dp * y + & 2.38198922570405e-16_dp ) * y + & 1.358319618800e-14_dp ) * y - & 7.064522786879e-14_dp ) * y - & 7.719300212748e-13_dp ) * y + & 7.802544789997e-12_dp ) * y + & 6.628721099436e-11_dp ) * y - & 1.775564159743e-09_dp ) * y + & 1.713828823990e-08_dp ) * y - & 1.497500187053e-07_dp ) * y + & 2.283485114279e-06_dp ) * y - & 3.76953869614706e-05_dp ) * y + & 4.74791204651451e-04_dp ) * y - & 4.60448960876139e-03_dp ) * y + & 3.72458587837249e-02_dp r2 = (((((((((((( 2.48791622798900e-14_dp * y - & 1.36113510175724e-13_dp ) * y - & 2.224334349799e-12_dp ) * y + & 4.190559455515e-11_dp ) * y - & 2.222722579924e-10_dp ) * y - & 2.624183464275e-09_dp ) * y + & 6.128153450169e-08_dp ) * y - & 4.383376014528e-07_dp ) * y - & 2.49952200232910e-06_dp ) * y + & 1.03236647888320e-04_dp ) * y - & 1.44614664924989e-03_dp ) * y + & 1.35094294917224e-02_dp ) * y - & 9.53478510453887e-02_dp ) * y + & 5.44765245686790e-01_dp w2 = (( f1 - w1 ) * r1 + f1 ) * ( 1.0e+00_dp + r2 ) / ( r2 - r1 ) w1 = w1 - w2 elseif ( real ( x ) <= 1 5.0e+00_dp ) then e = exp ( - x ) recx = 1.0e+00_dp / x w1 = ((( - 1.8784686463512e-01_dp * recx + & 2.2991849164985e-01_dp ) * recx - & 4.9893752514047e-01_dp ) * recx - & 2.1916512131607e-05_dp ) * e + & sqrt ( PIo4 * recx ) f1 = recx * ( w1 - e ) / 2 r1 = (((( - 1.01041157064226e-05_dp * x + & 1.19483054115173e-03_dp ) * x - & 6.73760231824074e-02_dp ) * x + & 1.25705571069895e+00_dp ) * x + & ((( - 8.57609422987199e+03_dp * recx + & 5.91005939591842e+03_dp ) * recx - & 1.70807677109425e+03_dp ) * recx + & 2.64536689959503e+02_dp ) * recx - & 2.38570496490846e+01_dp ) * e + r12 / ( x - r12 ) r2 = ((( 3.39024225137123e-04_dp * x - & 9.34976436343509e-02_dp ) * x - & 4.22216483306320e+00_dp ) * x + & ((( - 2.08457050986847e+03_dp * recx - & 1.04999071905664e+03_dp ) * recx + & 3.39891508992661e+02_dp ) * recx - & 1.56184800325063e+02_dp ) * recx + & 8.00839033297501e+00_dp ) * e + & r22 / ( x - r22 ) w2 = (( f1 - w1 ) * r1 + f1 ) * & ( 1.0e+00_dp + r2 ) / ( r2 - r1 ) w1 = w1 - w2 elseif ( real ( x ) <= 3 3.0e+00_dp ) then e = exp ( - x ) recx = 1.0e+00_dp / x w1 = (( 1.9623264149430e-01_dp * recx - & 4.9695241464490e-01_dp ) * recx - & 6.0156581186481e-05_dp ) * e + sqrt ( PIo4 * recx ) f1 = recx * ( w1 - e ) / 2 r1 = (((( - 1.14906395546354e-06_dp * x + & 1.76003409708332e-04_dp ) * x - & 1.71984023644904e-02_dp ) * x - & 1.37292644149838e-01_dp ) * x + & ( - 4.75742064274859e+01_dp * recx + & 9.21005186542857e+00_dp ) * recx - & 2.31080873898939e-02_dp ) * e + r12 / ( x - r12 ) r2 = ((( 3.64921633404158e-04_dp * x - & 9.71850973831558e-02_dp ) * x - & 4.02886174850252e+00_dp ) * x + & ( - 1.35831002139173e+02_dp * recx - & 8.66891724287962e+01_dp ) * recx + & 2.98011277766958e+00_dp ) * e + r22 / ( x - r22 ) w2 = (( f1 - w1 ) * r1 + f1 ) * & ( 1.0e+00_dp + r2 ) / ( r2 - r1 ) w1 = w1 - w2 elseif ( real ( x ) <= 4 0.0e+00_dp ) then w1 = sqrt ( PIo4 / x ) e = exp ( - x ) r1 = ( - 8.78947307498880e-01_dp * x + & 1.09243702330261e+01_dp ) * e + r12 / ( x - r12 ) r2 = ( - 9.28903924275977e+00_dp * x + & 8.10642367843811e+01_dp ) * e + r22 / ( x - r22 ) w2 = ( 4.46857389308400e+00_dp * x - & 7.79250653461045e+01_dp ) * e + w22 * w1 w1 = w1 - w2 else r1 = r12 / ( x - r12 ) r2 = r22 / ( x - r22 ) w1 = sqrt ( PIo4 / x ) w2 = w22 * w1 w1 = w1 - w2 end if r = ( / r1 , r2 / ) w = ( / w1 , w2 / ) end subroutine rys_rt2_csval subroutine rys_rt3_d ( x , dr , dw ) ! Complex-step analytic derivatives du_t/dX, dw_t/dX of rys_rt3. ! dr(t)=du_t/dX, dw(t)=dw_t/dX, to machine precision (no cancellation). real ( KIND = dp ), intent ( IN ) :: x real ( KIND = dp ), intent ( OUT ) :: dr ( 3 ), dw ( 3 ) complex ( KIND = dp ) :: xc , rc ( 3 ), wc ( 3 ) real ( KIND = dp ), parameter :: hcs = 1.0e-20_dp xc = cmplx ( x , hcs , KIND = dp ) call rys_rt3_csval ( xc , rc , wc ) dr = aimag ( rc ) / hcs dw = aimag ( wc ) / hcs end subroutine rys_rt3_d subroutine rys_rt3_csval ( x , r , w ) complex ( KIND = dp ), intent ( IN ) :: & x complex ( KIND = dp ), intent ( OUT ) :: & r ( 3 ), w ( 3 ) real ( KIND = dp ), parameter :: & r13 = 1.90163509193487e-01_dp , & r23 = 1.78449274854325e+00_dp , & w23 = 1.77231492083829e-01_dp , & r33 = 5.52534374226326e+00_dp , & w33 = 5.11156880411248e-03_dp complex ( KIND = dp ) :: & f1 , f2 , y , recx , e , & a1 , a2 , t1 , t2 , t3 , r1 , r2 , r3 , w1 , w2 , w3 if ( real ( x ) <= 3.0e-07_dp ) then r1 = 6.03769246832797e-02_dp - & 9.28875764357368e-03_dp * x r2 = 7.76823355931043e-01_dp - & 1.19511285527878e-01_dp * x r3 = 6.66279971938567e+00_dp - & 1.02504611068957e+00_dp * x w1 = 4.67913934572691e-01_dp - & 5.64876917232519e-02_dp * x w2 = 3.60761573048137e-01_dp - & 1.49077186455208e-01_dp * x w3 = 1.71324492379169e-01_dp - & 1.27768455150979e-01_dp * x elseif ( real ( x ) <= 1.0e+00_dp ) then r1 = (((((( - 5.10186691538870e-10_dp * x + & 2.40134415703450e-08_dp ) * x - & 5.01081057744427e-07_dp ) * x + & 7.58291285499256e-06_dp ) * x - & 9.55085533670919e-05_dp ) * x + & 1.02893039315878e-03_dp ) * x - & 9.28875764374337e-03_dp ) * x + & 6.03769246832810e-02_dp r2 = (((((( - 1.29646524960555e-08_dp * x + & 7.74602292865683e-08_dp ) * x + & 1.56022811158727e-06_dp ) * x - & 1.58051990661661e-05_dp ) * x - & 3.30447806384059e-04_dp ) * x + & 9.74266885190267e-03_dp ) * x - & 1.19511285526388e-01_dp ) * x + & 7.76823355931033e-01_dp r3 = (((((( - 9.28536484109606e-09_dp * x - & 3.02786290067014e-07_dp ) * x - & 2.50734477064200e-06_dp ) * x - & 7.32728109752881e-06_dp ) * x + & 2.44217481700129e-04_dp ) * x + & 4.94758452357327e-02_dp ) * x - & 1.02504611065774e+00_dp ) * x + & 6.66279971938553e+00_dp f2 = (((((((( - 7.60911486098850e-08_dp * x + & 1.09552870123182e-06_dp ) * x - & 1.03463270693454e-05_dp ) * x + & 8.16324851790106e-05_dp ) * x - & 5.55526624875562e-04_dp ) * x + & 3.20512054753924e-03_dp ) * x - & 1.51515139838540e-02_dp ) * x + & 5.55555554649585e-02_dp ) * x - & 1.42857142854412e-01_dp ) * x + & 1.99999999999986e-01_dp e = exp ( - x ) f1 = ( 2 * x * f2 + e ) / 3.0e+00_dp w1 = 2 * x * f1 + e t1 = r1 / ( r1 + 1.0e+00_dp ) t2 = r2 / ( r2 + 1.0e+00_dp ) t3 = r3 / ( r3 + 1.0e+00_dp ) a2 = f2 - t1 * f1 a1 = f1 - t1 * w1 w3 = ( a2 - t2 * a1 ) / (( t3 - t2 ) * ( t3 - t1 )) w2 = ( t3 * a1 - a2 ) / (( t3 - t2 ) * ( t2 - t1 )) w1 = w1 - w2 - w3 elseif ( real ( x ) <= 3.0e+00_dp ) then y = x - 2.0e+00_dp r1 = (((((((( 1.44687969563318e-12_dp * y + & 4.85300143926755e-12_dp ) * y - & 6.55098264095516e-10_dp ) * y + & 1.56592951656828e-08_dp ) * y - & 2.60122498274734e-07_dp ) * y + & 3.86118485517386e-06_dp ) * y - & 5.13430986707889e-05_dp ) * y + & 6.03194524398109e-04_dp ) * y - & 6.11219349825090e-03_dp ) * y + & 4.52578254679079e-02_dp r2 = ((((((( 6.95964248788138e-10_dp * y - & 5.35281831445517e-09_dp ) * y - & 6.745205954533e-08_dp ) * y + & 1.502366784525e-06_dp ) * y + & 9.923326947376e-07_dp ) * y - & 3.89147469249594e-04_dp ) * y + & 7.51549330892401e-03_dp ) * y - & 8.48778120363400e-02_dp ) * y + & 5.73928229597613e-01_dp r3 = (((((((( - 2.81496588401439e-10_dp * y + & 3.61058041895031e-09_dp ) * y + & 4.53631789436255e-08_dp ) * y - & 1.40971837780847e-07_dp ) * y - & 6.05865557561067e-06_dp ) * y - & 5.15964042227127e-05_dp ) * y + & 3.34761560498171e-05_dp ) * y + & 5.04871005319119e-02_dp ) * y - & 8.24708946991557e-01_dp ) * y + & 4.81234667357205e+00_dp f2 = (((((((((( - 1.48044231072140e-10_dp * y + & 1.78157031325097e-09_dp ) * y - & 1.92514145088973e-08_dp ) * y + & 1.92804632038796e-07_dp ) * y - & 1.73806555021045e-06_dp ) * y + & 1.39195169625425e-05_dp ) * y - & 9.74574633246452e-05_dp ) * y + & 5.83701488646511e-04_dp ) * y - & 2.89955494844975e-03_dp ) * y + & 1.13847001113810e-02_dp ) * y - & 3.23446977320647e-02_dp ) * y + & 5.29428148329709e-02_dp e = exp ( - x ) f1 = ( 2 * x * f2 + e ) / 3.0e+00_dp w1 = 2 * x * f1 + e t1 = r1 / ( r1 + 1.0e+00_dp ) t2 = r2 / ( r2 + 1.0e+00_dp ) t3 = r3 / ( r3 + 1.0e+00_dp ) a2 = f2 - t1 * f1 a1 = f1 - t1 * w1 w3 = ( a2 - t2 * a1 ) / (( t3 - t2 ) * ( t3 - t1 )) w2 = ( t3 * a1 - a2 ) / (( t3 - t2 ) * ( t2 - t1 )) w1 = w1 - w2 - w3 elseif ( real ( x ) <= 5.0e+00_dp ) then y = x - 4.0e+00_dp r1 = ((((((( 1.44265709189601e-11_dp * y - & 4.66622033006074e-10_dp ) * y + & 7.649155832025e-09_dp ) * y - & 1.229940017368e-07_dp ) * y + & 2.026002142457e-06_dp ) * y - & 2.87048671521677e-05_dp ) * y + & 3.70326938096287e-04_dp ) * y - & 4.21006346373634e-03_dp ) * y + & 3.50898470729044e-02_dp r2 = (((((((( - 2.65526039155651e-11_dp * y + & 1.97549041402552e-10_dp ) * y + & 2.15971131403034e-09_dp ) * y - & 7.95045680685193e-08_dp ) * y + & 5.15021914287057e-07_dp ) * y + & 1.11788717230514e-05_dp ) * y - & 3.33739312603632e-04_dp ) * y + & 5.30601428208358e-03_dp ) * y - & 5.93483267268959e-02_dp ) * y + & 4.31180523260239e-01_dp r3 = (((((((( - 3.92833750584041e-10_dp * y - & 4.16423229782280e-09_dp ) * y + & 4.42413039572867e-08_dp ) * y + & 6.40574545989551e-07_dp ) * y - & 3.05512456576552e-06_dp ) * y - & 1.05296443527943e-04_dp ) * y - & 6.14120969315617e-04_dp ) * y + & 4.89665802767005e-02_dp ) * y - & 6.24498381002855e-01_dp ) * y + & 3.36412312243724e+00_dp f2 = (((((((((( - 2.36788772599074e-11_dp * y + & 2.89147476459092e-10_dp ) * y - & 3.18111322308846e-09_dp ) * y + & 3.25336816562485e-08_dp ) * y - & 3.00873821471489e-07_dp ) * y + & 2.48749160874431e-06_dp ) * y - & 1.81353179793672e-05_dp ) * y + & 1.14504948737066e-04_dp ) * y - & 6.10614987696677e-04_dp ) * y + & 2.64584212770942e-03_dp ) * y - & 8.66415899015349e-03_dp ) * y + & 1.75257821619922e-02_dp e = exp ( - x ) f1 = (( x + x ) * f2 + e ) / 3.0e+00_dp w1 = ( x + x ) * f1 + e t1 = r1 / ( r1 + 1.0e+00_dp ) t2 = r2 / ( r2 + 1.0e+00_dp ) t3 = r3 / ( r3 + 1.0e+00_dp ) a2 = f2 - t1 * f1 a1 = f1 - t1 * w1 w3 = ( a2 - t2 * a1 ) / (( t3 - t2 ) * ( t3 - t1 )) w2 = ( t3 * a1 - a2 ) / (( t3 - t2 ) * ( t2 - t1 )) w1 = w1 - w2 - w3 elseif ( real ( x ) <= 1 0.0e+00_dp ) then e = exp ( - x ) recx = 1.0e+00_dp / x w1 = (((((( 4.6897511375022e-01_dp * recx - & 6.9955602298985e-01_dp ) * recx + & 5.3689283271887e-01_dp ) * recx - & 3.2883030418398e-01_dp ) * recx + & 2.4645596956002e-01_dp ) * recx - & 4.9984072848436e-01_dp ) * recx - & 3.1501078774085e-06_dp ) * e + sqrt ( PIo4 * recx ) f1 = recx * ( w1 - e ) / 2 f2 = recx * ( f1 + f1 + f1 - e ) / 2 y = x - 7.5e+00_dp r1 = ((((((((((( 5.74429401360115e-16_dp * y + & 7.11884203790984e-16_dp ) * y - & 6.736701449826e-14_dp ) * y - & 6.264613873998e-13_dp ) * y + & 1.315418927040e-11_dp ) * y - & 4.23879635610964e-11_dp ) * y + & 1.39032379769474e-09_dp ) * y - & 4.65449552856856e-08_dp ) * y + & 7.34609900170759e-07_dp ) * y - & 1.08656008854077e-05_dp ) * y + & 1.77930381549953e-04_dp ) * y - & 2.39864911618015e-03_dp ) * y + & 2.39112249488821e-02_dp r2 = ((((((((((( 1.13464096209120e-14_dp * y + & 6.99375313934242e-15_dp ) * y - & 8.595618132088e-13_dp ) * y - & 5.293620408757e-12_dp ) * y - & 2.492175211635e-11_dp ) * y + & 2.73681574882729e-09_dp ) * y - & 1.06656985608482e-08_dp ) * y - & 4.40252529648056e-07_dp ) * y + & 9.68100917793911e-06_dp ) * y - & 1.68211091755327e-04_dp ) * y + & 2.69443611274173e-03_dp ) * y - & 3.23845035189063e-02_dp ) * y + & 2.75969447451882e-01_dp r3 = (((((((((((( 6.66339416996191e-15_dp * y + & 1.84955640200794e-13_dp ) * y - & 1.985141104444e-12_dp ) * y - & 2.309293727603e-11_dp ) * y + & 3.917984522103e-10_dp ) * y + & 1.663165279876e-09_dp ) * y - & 6.205591993923e-08_dp ) * y + & 8.769581622041e-09_dp ) * y + & 8.97224398620038e-06_dp ) * y - & 3.14232666170796e-05_dp ) * y - & 1.83917335649633e-03_dp ) * y + & 3.51246831672571e-02_dp ) * y - & 3.22335051270860e-01_dp ) * y + & 1.73582831755430e+00_dp t1 = r1 / ( r1 + 1.0e+00_dp ) t2 = r2 / ( r2 + 1.0e+00_dp ) t3 = r3 / ( r3 + 1.0e+00_dp ) a2 = f2 - t1 * f1 a1 = f1 - t1 * w1 w3 = ( a2 - t2 * a1 ) / (( t3 - t2 ) * ( t3 - t1 )) w2 = ( t3 * a1 - a2 ) / (( t3 - t2 ) * ( t2 - t1 )) w1 = w1 - w2 - w3 elseif ( real ( x ) <= 1 5.0e+00_dp ) then e = exp ( - x ) recx = 1.0e+00_dp / x w1 = ((( - 1.8784686463512e-01_dp * recx + & 2.2991849164985e-01_dp ) * recx - & 4.9893752514047e-01_dp ) * recx - & 2.1916512131607e-05_dp ) * e + sqrt ( PIo4 * recx ) f1 = recx * ( w1 - e ) / 2 f2 = recx * ( f1 + f1 + f1 - e ) / 2 y = x - 1 2.5e+00_dp r1 = ((((((((((( 4.42133001283090e-16_dp * y - & 2.77189767070441e-15_dp ) * y - & 4.084026087887e-14_dp ) * y + & 5.379885121517e-13_dp ) * y + & 1.882093066702e-12_dp ) * y - & 8.67286219861085e-11_dp ) * y + & 7.11372337079797e-10_dp ) * y - & 3.55578027040563e-09_dp ) * y + & 1.29454702851936e-07_dp ) * y - & 4.14222202791434e-06_dp ) * y + & 8.04427643593792e-05_dp ) * y - & 1.18587782909876e-03_dp ) * y + & 1.53435577063174e-02_dp r2 = ((((((((((( 6.85146742119357e-15_dp * y - & 1.08257654410279e-14_dp ) * y - & 8.579165965128e-13_dp ) * y + & 6.642452485783e-12_dp ) * y + & 4.798806828724e-11_dp ) * y - & 1.13413908163831e-09_dp ) * y + & 7.08558457182751e-09_dp ) * y - & 5.59678576054633e-08_dp ) * y + & 2.51020389884249e-06_dp ) * y - & 6.63678914608681e-05_dp ) * y + & 1.11888323089714e-03_dp ) * y - & 1.45361636398178e-02_dp ) * y + & 1.65077877454402e-01_dp r3 = (((((((((((( 3.20622388697743e-15_dp * y - & 2.73458804864628e-14_dp ) * y - & 3.157134329361e-13_dp ) * y + & 8.654129268056e-12_dp ) * y - & 5.625235879301e-11_dp ) * y - & 7.718080513708e-10_dp ) * y + & 2.064664199164e-08_dp ) * y - & 1.567725007761e-07_dp ) * y - & 1.57938204115055e-06_dp ) * y + & 6.27436306915967e-05_dp ) * y - & 1.01308723606946e-03_dp ) * y + & 1.13901881430697e-02_dp ) * y - & 1.01449652899450e-01_dp ) * y + & 7.77203937334739e-01_dp t1 = r1 / ( r1 + 1.0e+00_dp ) t2 = r2 / ( r2 + 1.0e+00_dp ) t3 = r3 / ( r3 + 1.0e+00_dp ) a2 = f2 - t1 * f1 a1 = f1 - t1 * w1 w3 = ( a2 - t2 * a1 ) / (( t3 - t2 ) * ( t3 - t1 )) w2 = ( t3 * a1 - a2 ) / (( t3 - t2 ) * ( t2 - t1 )) w1 = w1 - w2 - w3 elseif ( real ( x ) <= 2 0.0e+00_dp ) then e = exp ( - x ) recx = 1.0e+00_dp / x w1 = (( 1.9623264149430e-01_dp * recx - & 4.9695241464490e-01_dp ) * recx - & 6.0156581186481e-05_dp ) * e + sqrt ( PIo4 * recx ) f1 = recx * ( w1 - e ) / 2 f2 = recx * ( f1 + f1 + f1 - e ) / 2 r1 = (((((( - 2.43270989903742e-06_dp * x + & 3.57901398988359e-04_dp ) * x - & 2.34112415981143e-02_dp ) * x + & 7.81425144913975e-01_dp ) * x - & 1.73209218219175e+01_dp ) * x + & 2.43517435690398e+02_dp ) * x + & ( - 1.97611541576986e+04_dp * recx + & 9.82441363463929e+03_dp ) * recx - & 2.07970687843258e+03_dp ) * e + r13 / ( x - r13 ) r2 = ((((( - 2.62627010965435e-04_dp * x + & 3.49187925428138e-02_dp ) * x - & 3.09337618731880e+00_dp ) * x + & 1.07037141010778e+02_dp ) * x - & 2.36659637247087e+03_dp ) * x + & (( - 2.91669113681020e+06_dp * recx + & 1.41129505262758e+06_dp ) * recx - & 2.91532335433779e+05_dp ) * recx + & 3.35202872835409e+04_dp ) * e + r23 / ( x - r23 ) r3 = ((((( 9.31856404738601e-05_dp * x - & 2.87029400759565e-02_dp ) * x - & 7.83503697918455e-01_dp ) * x - & 1.84338896480695e+01_dp ) * x + & 4.04996712650414e+02_dp ) * x + & ( - 1.89829509315154e+05_dp * recx + & 5.11498390849158e+04_dp ) * recx - & 6.88145821789955e+03_dp ) * e + r33 / ( x - r33 ) t1 = r1 / ( r1 + 1.0e+00_dp ) t2 = r2 / ( r2 + 1.0e+00_dp ) t3 = r3 / ( r3 + 1.0e+00_dp ) a2 = f2 - t1 * f1 a1 = f1 - t1 * w1 w3 = ( a2 - t2 * a1 ) / (( t3 - t2 ) * ( t3 - t1 )) w2 = ( t3 * a1 - a2 ) / (( t3 - t2 ) * ( t2 - t1 )) w1 = w1 - w2 - w3 elseif ( real ( x ) <= 3 3.0e+00_dp ) then e = exp ( - x ) recx = 1.0e+00_dp / x w1 = (( 1.9623264149430e-01_dp * recx - & 4.9695241464490e-01_dp ) * recx - & 6.0156581186481e-05_dp ) * e + sqrt ( PIo4 * recx ) f1 = recx * ( w1 - e ) / 2 f2 = recx * ( f1 + f1 + f1 - e ) / 2 r1 = (((( - 4.97561537069643e-04_dp * x - & 5.00929599665316e-02_dp ) * x + & 1.31099142238996e+00_dp ) * x - & 1.88336409225481e+01_dp ) * x - & 6.60344754467191e+02_dp * recx + & 1.64931462413877e+02_dp ) * e + r13 / ( x - r13 ) r2 = (((( - 4.48218898474906e-03_dp * x - & 5.17373211334924e-01_dp ) * x + & 1.13691058739678e+01_dp ) * x - & 1.65426392885291e+02_dp ) * x - & 6.30909125686731e+03_dp * recx + & 1.52231757709236e+03_dp ) * e + r23 / ( x - r23 ) r3 = (((( - 1.38368602394293e-02_dp * x - & 1.77293428863008e+00_dp ) * x + & 1.73639054044562e+01_dp ) * x - & 3.57615122086961e+02_dp ) * x - & 1.45734701095912e+04_dp * recx + & 2.69831813951849e+03_dp ) * e + r33 / ( x - r33 ) t1 = r1 / ( r1 + 1.0e+00_dp ) t2 = r2 / ( r2 + 1.0e+00_dp ) t3 = r3 / ( r3 + 1.0e+00_dp ) a2 = f2 - t1 * f1 a1 = f1 - t1 * w1 w3 = ( a2 - t2 * a1 ) / (( t3 - t2 ) * ( t3 - t1 )) w2 = ( t3 * a1 - a2 ) / (( t3 - t2 ) * ( t2 - t1 )) w1 = w1 - w2 - w3 elseif ( real ( x ) <= 4 7.0e+00_dp ) then w1 = sqrt ( PIo4 / x ) e = exp ( - x ) r1 = (( - 7.39058467995275e+00_dp * x + & 3.21318352526305e+02_dp ) * x - & 3.99433696473658e+03_dp ) * e + r13 / ( x - r13 ) r2 = (( - 7.38726243906513e+01_dp * x + & 3.13569966333873e+03_dp ) * x - & 3.86862867311321e+04_dp ) * e + r23 / ( x - r23 ) r3 = (( - 2.63750565461336e+02_dp * x + & 1.04412168692352e+04_dp ) * x - & 1.28094577915394e+05_dp ) * e + r33 / ( x - r33 ) w3 = ((( 1.52258947224714e-01_dp * x - & 8.30661900042651e+00_dp ) * x + & 1.92977367967984e+02_dp ) * x - & 1.67787926005344e+03_dp ) * e + w33 * w1 w2 = (( 6.15072615497811e+01_dp * x - & 2.91980647450269e+03_dp ) * x + & 3.80794303087338e+04_dp ) * e + w23 * w1 w1 = w1 - w2 - w3 else r1 = r13 / ( x - r13 ) r2 = r23 / ( x - r23 ) r3 = r33 / ( x - r33 ) w1 = sqrt ( PIo4 / x ) w2 = w23 * w1 w3 = w33 * w1 w1 = w1 - w2 - w3 end if r = ( / r1 , r2 , r3 / ) w = ( / w1 , w2 , w3 / ) end subroutine rys_rt3_csval subroutine rys_rt4_d ( x , dr , dw ) ! Complex-step analytic derivatives du_t/dX, dw_t/dX of rys_rt4. ! dr(t)=du_t/dX, dw(t)=dw_t/dX, to machine precision (no cancellation). real ( KIND = dp ), intent ( IN ) :: x real ( KIND = dp ), intent ( OUT ) :: dr ( 4 ), dw ( 4 ) complex ( KIND = dp ) :: xc , rc ( 4 ), wc ( 4 ) real ( KIND = dp ), parameter :: hcs = 1.0e-20_dp xc = cmplx ( x , hcs , KIND = dp ) call rys_rt4_csval ( xc , rc , wc ) dr = aimag ( rc ) / hcs dw = aimag ( wc ) / hcs end subroutine rys_rt4_d subroutine rys_rt4_csval ( x , r , w ) complex ( KIND = dp ), intent ( IN ) :: & x complex ( KIND = dp ), intent ( OUT ) :: & r ( 4 ), w ( 4 ) real ( KIND = dp ), parameter :: & r14 = 1.45303521503316e-01_dp , & r24 = 1.33909728812636e+00_dp , & w24 = 2.34479815323517e-01_dp , & r34 = 3.92696350135829e+00_dp , & w34 = 1.92704402415764e-02_dp , & r44 = 8.58863568901199e+00_dp , & w44 = 2.25229076750736e-04_dp complex ( KIND = dp ) :: & y , recx , e , r1 , r2 , r3 , r4 , w1 , w2 , w3 , w4 if ( real ( x ) <= 3.0e-07_dp ) then r1 = 3.48198973061471e-02_dp - 4.09645850660395e-03_dp * x r2 = 3.81567185080042e-01_dp - 4.48902570656719e-02_dp * x r3 = 1.73730726945891e+00_dp - 2.04389090547327e-01_dp * x r4 = 1.18463056481549e+01_dp - 1.39368301742312e+00_dp * x w1 = 3.62683783378362e-01_dp - 3.13844305713928e-02_dp * x w2 = 3.13706645877886e-01_dp - 8.98046242557724e-02_dp * x w3 = 2.22381034453372e-01_dp - 1.29314370958973e-01_dp * x w4 = 1.01228536290376e-01_dp - 8.28299075414321e-02_dp * x elseif ( real ( x ) <= 1.0e+00_dp ) then r1 = (((((( - 1.95309614628539e-10_dp * x + & 5.19765728707592e-09_dp ) * x - & 1.01756452250573e-07_dp ) * x + & 1.72365935872131e-06_dp ) * x - & 2.61203523522184e-05_dp ) * x + & 3.52921308769880e-04_dp ) * x - & 4.09645850658433e-03_dp ) * x + & 3.48198973061469e-02_dp r2 = ((((( - 1.89554881382342e-08_dp * x + & 3.07583114342365e-07_dp ) * x + & 1.270981734393e-06_dp ) * x - & 1.417298563884e-04_dp ) * x + & 3.226979163176e-03_dp ) * x - & 4.48902570678178e-02_dp ) * x + & 3.81567185080039e-01_dp r3 = (((((( 1.77280535300416e-09_dp * x + & 3.36524958870615e-08_dp ) * x - & 2.58341529013893e-07_dp ) * x - & 1.13644895662320e-05_dp ) * x - & 7.91549618884063e-05_dp ) * x + & 1.03825827346828e-02_dp ) * x - & 2.04389090525137e-01_dp ) * x + & 1.73730726945889e+00_dp r4 = ((((( - 5.61188882415248e-08_dp * x - & 2.49480733072460e-07_dp ) * x + & 3.428685057114e-06_dp ) * x + & 1.679007454539e-04_dp ) * x + & 4.722855585715e-02_dp ) * x - & 1.39368301737828e+00_dp ) * x + & 1.18463056481543e+01_dp w1 = (((((( - 1.14649303201279e-08_dp * x + & 1.88015570196787e-07_dp ) * x - & 2.33305875372323e-06_dp ) * x + & 2.68880044371597e-05_dp ) * x - & 2.94268428977387e-04_dp ) * x + & 3.06548909776613e-03_dp ) * x - & 3.13844305680096e-02_dp ) * x + & 3.62683783378335e-01_dp w2 = (((((((( - 4.11720483772634e-09_dp * x + & 6.54963481852134e-08_dp ) * x - & 7.20045285129626e-07_dp ) * x + & 6.93779646721723e-06_dp ) * x - & 6.05367572016373e-05_dp ) * x + & 4.74241566251899e-04_dp ) * x - & 3.26956188125316e-03_dp ) * x + & 1.91883866626681e-02_dp ) * x - & 8.98046242565811e-02_dp ) * x + & 3.13706645877886e-01_dp w3 = (((((((( - 3.41688436990215e-08_dp * x + & 5.07238960340773e-07_dp ) * x - & 5.01675628408220e-06_dp ) * x + & 4.20363420922845e-05_dp ) * x - & 3.08040221166823e-04_dp ) * x + & 1.94431864731239e-03_dp ) * x - & 1.02477820460278e-02_dp ) * x + & 4.28670143840073e-02_dp ) * x - & 1.29314370962569e-01_dp ) * x + & 2.22381034453369e-01_dp w4 = ((((((((( 4.99660550769508e-09_dp * x - & 7.94585963310120e-08_dp ) * x + & 8.359072409485e-07_dp ) * x - & 7.422369210610e-06_dp ) * x + & 5.763374308160e-05_dp ) * x - & 3.86645606718233e-04_dp ) * x + & 2.18417516259781e-03_dp ) * x - & 9.99791027771119e-03_dp ) * x + & 3.48791097377370e-02_dp ) * x - & 8.28299075413889e-02_dp ) * x + & 1.01228536290376e-01_dp elseif ( real ( x ) <= 5.0e+00_dp ) then y = x - 3.0e+00_dp r1 = ((((((((( - 1.48570633747284e-15_dp * y - & 1.33273068108777e-13_dp ) * y + & 4.068543696670e-12_dp ) * y - & 9.163164161821e-11_dp ) * y + & 2.046819017845e-09_dp ) * y - & 4.03076426299031e-08_dp ) * y + & 7.29407420660149e-07_dp ) * y - & 1.23118059980833e-05_dp ) * y + & 1.88796581246938e-04_dp ) * y - & 2.53262912046853e-03_dp ) * y + & 2.51198234505021e-02_dp r2 = ((((((((( 1.35830583483312e-13_dp * y - & 2.29772605964836e-12_dp ) * y - & 3.821500128045e-12_dp ) * y + & 6.844424214735e-10_dp ) * y - & 1.048063352259e-08_dp ) * y + & 1.50083186233363e-08_dp ) * y + & 3.48848942324454e-06_dp ) * y - & 1.08694174399193e-04_dp ) * y + & 2.08048885251999e-03_dp ) * y - & 2.91205805373793e-02_dp ) * y + & 2.72276489515713e-01_dp r3 = ((((((((( 5.02799392850289e-13_dp * y + & 1.07461812944084e-11_dp ) * y - & 1.482277886411e-10_dp ) * y - & 2.153585661215e-09_dp ) * y + & 3.654087802817e-08_dp ) * y + & 5.15929575830120e-07_dp ) * y - & 9.52388379435709e-06_dp ) * y - & 2.16552440036426e-04_dp ) * y + & 9.03551469568320e-03_dp ) * y - & 1.45505469175613e-01_dp ) * y + & 1.21449092319186e+00_dp r4 = ((((((((( - 1.08510370291979e-12_dp * y + & 6.41492397277798e-11_dp ) * y + & 7.542387436125e-10_dp ) * y - & 2.213111836647e-09_dp ) * y - & 1.448228963549e-07_dp ) * y - & 1.95670833237101e-06_dp ) * y - & 1.07481314670844e-05_dp ) * y + & 1.49335941252765e-04_dp ) * y + & 4.87791531990593e-02_dp ) * y - & 1.10559909038653e+00_dp ) * y + & 8.09502028611780e+00_dp w1 = (((((((((( - 4.65801912689961e-14_dp * y + & 7.58669507106800e-13_dp ) * y - & 1.186387548048e-11_dp ) * y + & 1.862334710665e-10_dp ) * y - & 2.799399389539e-09_dp ) * y + & 4.148972684255e-08_dp ) * y - & 5.933568079600e-07_dp ) * y + & 8.168349266115e-06_dp ) * y - & 1.08989176177409e-04_dp ) * y + & 1.41357961729531e-03_dp ) * y - & 1.87588361833659e-02_dp ) * y + & 2.89898651436026e-01_dp w2 = (((((((((((( - 1.46345073267549e-14_dp * y + & 2.25644205432182e-13_dp ) * y - & 3.116258693847e-12_dp ) * y + & 4.321908756610e-11_dp ) * y - & 5.673270062669e-10_dp ) * y + & 7.006295962960e-09_dp ) * y - & 8.120186517000e-08_dp ) * y + & 8.775294645770e-07_dp ) * y - & 8.77829235749024e-06_dp ) * y + & 8.04372147732379e-05_dp ) * y - & 6.64149238804153e-04_dp ) * y + & 4.81181506827225e-03_dp ) * y - & 2.88982669486183e-02_dp ) * y + & 1.56247249979288e-01_dp w3 = ((((((((((((( 9.06812118895365e-15_dp * y - & 1.40541322766087e-13_dp ) * y + & 1.919270015269e-12_dp ) * y - & 2.605135739010e-11_dp ) * y + & 3.299685839012e-10_dp ) * y - & 3.86354139348735e-09_dp ) * y + & 4.16265847927498e-08_dp ) * y - & 4.09462835471470e-07_dp ) * y + & 3.64018881086111e-06_dp ) * y - & 2.88665153269386e-05_dp ) * y + & 2.00515819789028e-04_dp ) * y - & 1.18791896897934e-03_dp ) * y + & 5.75223633388589e-03_dp ) * y - & 2.09400418772687e-02_dp ) * y + & 4.85368861938873e-02_dp w4 = (((((((((((((( - 9.74835552342257e-16_dp * y + & 1.57857099317175e-14_dp ) * y - & 2.249993780112e-13_dp ) * y + & 3.173422008953e-12_dp ) * y - & 4.161159459680e-11_dp ) * y + & 5.021343560166e-10_dp ) * y - & 5.545047534808e-09_dp ) * y + & 5.554146993491e-08_dp ) * y - & 4.99048696190133e-07_dp ) * y + & 3.96650392371311e-06_dp ) * y - & 2.73816413291214e-05_dp ) * y + & 1.60106988333186e-04_dp ) * y - & 7.64560567879592e-04_dp ) * y + & 2.81330044426892e-03_dp ) * y - & 7.16227030134947e-03_dp ) * y + & 9.66077262223353e-03_dp elseif ( real ( x ) <= 1 0.0e+00_dp ) then y = x - 7.5e+00_dp r1 = ((((((((( 4.64217329776215e-15_dp * y - & 6.27892383644164e-15_dp ) * y + & 3.462236347446e-13_dp ) * y - & 2.927229355350e-11_dp ) * y + & 5.090355371676e-10_dp ) * y - & 9.97272656345253e-09_dp ) * y + & 2.37835295639281e-07_dp ) * y - & 4.60301761310921e-06_dp ) * y + & 8.42824204233222e-05_dp ) * y - & 1.37983082233081e-03_dp ) * y + & 1.66630865869375e-02_dp r2 = ((((((((( 2.93981127919047e-14_dp * y + & 8.47635639065744e-13_dp ) * y - & 1.446314544774e-11_dp ) * y - & 6.149155555753e-12_dp ) * y + & 8.484275604612e-10_dp ) * y - & 6.10898827887652e-08_dp ) * y + & 2.39156093611106e-06_dp ) * y - & 5.35837089462592e-05_dp ) * y + & 1.00967602595557e-03_dp ) * y - & 1.57769317127372e-02_dp ) * y + & 1.74853819464285e-01_dp r3 = (((((((((( 2.93523563363000e-14_dp * y - & 6.40041776667020e-14_dp ) * y - & 2.695740446312e-12_dp ) * y + & 1.027082960169e-10_dp ) * y - & 5.822038656780e-10_dp ) * y - & 3.159991002539e-08_dp ) * y + & 4.327249251331e-07_dp ) * y + & 4.856768455119e-06_dp ) * y - & 2.54617989427762e-04_dp ) * y + & 5.54843378106589e-03_dp ) * y - & 7.95013029486684e-02_dp ) * y + & 7.20206142703162e-01_dp r4 = ((((((((((( - 1.62212382394553e-14_dp * y + & 7.68943641360593e-13_dp ) * y + & 5.764015756615e-12_dp ) * y - & 1.380635298784e-10_dp ) * y - & 1.476849808675e-09_dp ) * y + & 1.84347052385605e-08_dp ) * y + & 3.34382940759405e-07_dp ) * y - & 1.39428366421645e-06_dp ) * y - & 7.50249313713996e-05_dp ) * y - & 6.26495899187507e-04_dp ) * y + & 4.69716410901162e-02_dp ) * y - & 6.66871297428209e-01_dp ) * y + & 4.11207530217806e+00_dp w1 = (((((((((( - 1.65995045235997e-15_dp * y + & 6.91838935879598e-14_dp ) * y - & 9.131223418888e-13_dp ) * y + & 1.403341829454e-11_dp ) * y - & 3.672235069444e-10_dp ) * y + & 6.366962546990e-09_dp ) * y - & 1.039220021671e-07_dp ) * y + & 1.959098751715e-06_dp ) * y - & 3.33474893152939e-05_dp ) * y + & 5.72164211151013e-04_dp ) * y - & 1.05583210553392e-02_dp ) * y + & 2.26696066029591e-01_dp w2 = (((((((((((( - 3.57248951192047e-16_dp * y + & 6.25708409149331e-15_dp ) * y - & 9.657033089714e-14_dp ) * y + & 1.507864898748e-12_dp ) * y - & 2.332522256110e-11_dp ) * y + & 3.428545616603e-10_dp ) * y - & 4.698730937661e-09_dp ) * y + & 6.219977635130e-08_dp ) * y - & 7.83008889613661e-07_dp ) * y + & 9.08621687041567e-06_dp ) * y - & 9.86368311253873e-05_dp ) * y + & 9.69632496710088e-04_dp ) * y - & 8.14594214284187e-03_dp ) * y + & 8.50218447733457e-02_dp w3 = ((((((((((((( 1.64742458534277e-16_dp * y - & 2.68512265928410e-15_dp ) * y + & 3.788890667676e-14_dp ) * y - & 5.508918529823e-13_dp ) * y + & 7.555896810069e-12_dp ) * y - & 9.69039768312637e-11_dp ) * y + & 1.16034263529672e-09_dp ) * y - & 1.28771698573873e-08_dp ) * y + & 1.31949431805798e-07_dp ) * y - & 1.23673915616005e-06_dp ) * y + & 1.04189803544936e-05_dp ) * y - & 7.79566003744742e-05_dp ) * y + & 5.03162624754434e-04_dp ) * y - & 2.55138844587555e-03_dp ) * y + & 1.13250730954014e-02_dp w4 = (((((((((((((( - 1.55714130075679e-17_dp * y + & 2.57193722698891e-16_dp ) * y - & 3.626606654097e-15_dp ) * y + & 5.234734676175e-14_dp ) * y - & 7.067105402134e-13_dp ) * y + & 8.793512664890e-12_dp ) * y - & 1.006088923498e-10_dp ) * y + & 1.050565098393e-09_dp ) * y - & 9.91517881772662e-09_dp ) * y + & 8.35835975882941e-08_dp ) * y - & 6.19785782240693e-07_dp ) * y + & 3.95841149373135e-06_dp ) * y - & 2.11366761402403e-05_dp ) * y + & 9.00474771229507e-05_dp ) * y - & 2.78777909813289e-04_dp ) * y + & 5.26543779837487e-04_dp elseif ( real ( x ) <= 1 5.0e+00_dp ) then y = x - 1 2.5e+00_dp r1 = ((((((((((( 4.94869622744119e-17_dp * y + & 8.03568805739160e-16_dp ) * y - & 5.599125915431e-15_dp ) * y - & 1.378685560217e-13_dp ) * y + & 7.006511663249e-13_dp ) * y + & 1.30391406991118e-11_dp ) * y + & 8.06987313467541e-11_dp ) * y - & 5.20644072732933e-09_dp ) * y + & 7.72794187755457e-08_dp ) * y - & 1.61512612564194e-06_dp ) * y + & 4.15083811185831e-05_dp ) * y - & 7.87855975560199e-04_dp ) * y + & 1.14189319050009e-02_dp r2 = ((((((((((( 4.89224285522336e-16_dp * y + & 1.06390248099712e-14_dp ) * y - & 5.446260182933e-14_dp ) * y - & 1.613630106295e-12_dp ) * y + & 3.910179118937e-12_dp ) * y + & 1.90712434258806e-10_dp ) * y + & 8.78470199094761e-10_dp ) * y - & 5.97332993206797e-08_dp ) * y + & 9.25750831481589e-07_dp ) * y - & 2.02362185197088e-05_dp ) * y + & 4.92341968336776e-04_dp ) * y - & 8.68438439874703e-03_dp ) * y + & 1.15825965127958e-01_dp r3 = (((((((((( 6.12419396208408e-14_dp * y + & 1.12328861406073e-13_dp ) * y - & 9.051094103059e-12_dp ) * y - & 4.781797525341e-11_dp ) * y + & 1.660828868694e-09_dp ) * y + & 4.499058798868e-10_dp ) * y - & 2.519549641933e-07_dp ) * y + & 4.977444040180e-06_dp ) * y - & 1.25858350034589e-04_dp ) * y + & 2.70279176970044e-03_dp ) * y - & 3.99327850801083e-02_dp ) * y + & 4.33467200855434e-01_dp r4 = ((((((((((( 4.63414725924048e-14_dp * y - & 4.72757262693062e-14_dp ) * y - & 1.001926833832e-11_dp ) * y + & 6.074107718414e-11_dp ) * y + & 1.576976911942e-09_dp ) * y - & 2.01186401974027e-08_dp ) * y - & 1.84530195217118e-07_dp ) * y + & 5.02333087806827e-06_dp ) * y + & 9.66961790843006e-06_dp ) * y - & 1.58522208889528e-03_dp ) * y + & 2.80539673938339e-02_dp ) * y - & 2.78953904330072e-01_dp ) * y + & 1.82835655238235e+00_dp w4 = ((((((((((((( 2.90401781000996e-18_dp * y - & 4.63389683098251e-17_dp ) * y + & 6.274018198326e-16_dp ) * y - & 8.936002188168e-15_dp ) * y + & 1.194719074934e-13_dp ) * y - & 1.45501321259466e-12_dp ) * y + & 1.64090830181013e-11_dp ) * y - & 1.71987745310181e-10_dp ) * y + & 1.63738403295718e-09_dp ) * y - & 1.39237504892842e-08_dp ) * y + & 1.06527318142151e-07_dp ) * y - & 7.27634957230524e-07_dp ) * y + & 4.12159381310339e-06_dp ) * y - & 1.74648169719173e-05_dp ) * y + & 8.50290130067818e-05_dp w3 = (((((((((((( - 4.19569145459480e-17_dp * y + & 5.94344180261644e-16_dp ) * y - & 1.148797566469e-14_dp ) * y + & 1.881303962576e-13_dp ) * y - & 2.413554618391e-12_dp ) * y + & 3.372127423047e-11_dp ) * y - & 4.933988617784e-10_dp ) * y + & 6.116545396281e-09_dp ) * y - & 6.69965691739299e-08_dp ) * y + & 7.52380085447161e-07_dp ) * y - & 8.08708393262321e-06_dp ) * y + & 6.88603417296672e-05_dp ) * y - & 4.67067112993427e-04_dp ) * y + & 5.42313365864597e-03_dp w2 = (((((((((( - 6.22272689880615e-15_dp * y + & 1.04126809657554e-13_dp ) * y - & 6.842418230913e-13_dp ) * y + & 1.576841731919e-11_dp ) * y - & 4.203948834175e-10_dp ) * y + & 6.287255934781e-09_dp ) * y - & 8.307159819228e-08_dp ) * y + & 1.356478091922e-06_dp ) * y - & 2.08065576105639e-05_dp ) * y + & 2.52396730332340e-04_dp ) * y - & 2.94484050194539e-03_dp ) * y + & 6.01396183129168e-02_dp recx = 1.0e+00_dp / x w1 = ((( - 1.8784686463512e-01_dp * recx + & 2.2991849164985e-01_dp ) * recx - & 4.9893752514047e-01_dp ) * recx - & 2.1916512131607e-05_dp ) * exp ( - x ) + & sqrt ( PIo4 * recx ) - w4 - w3 - w2 elseif ( real ( x ) <= 2 0.0e+00_dp ) then w1 = sqrt ( PIo4 / x ) y = x - 1 7.5e+00_dp r1 = ((((((((((( 4.36701759531398e-17_dp * y - & 1.12860600219889e-16_dp ) * y - & 6.149849164164e-15_dp ) * y + & 5.820231579541e-14_dp ) * y + & 4.396602872143e-13_dp ) * y - & 1.24330365320172e-11_dp ) * y + & 6.71083474044549e-11_dp ) * y + & 2.43865205376067e-10_dp ) * y + & 1.67559587099969e-08_dp ) * y - & 9.32738632357572e-07_dp ) * y + & 2.39030487004977e-05_dp ) * y - & 4.68648206591515e-04_dp ) * y + & 8.34977776583956e-03_dp r2 = ((((((((((( 4.98913142288158e-16_dp * y - & 2.60732537093612e-16_dp ) * y - & 7.775156445127e-14_dp ) * y + & 5.766105220086e-13_dp ) * y + & 6.432696729600e-12_dp ) * y - & 1.39571683725792e-10_dp ) * y + & 5.95451479522191e-10_dp ) * y + & 2.42471442836205e-09_dp ) * y + & 2.47485710143120e-07_dp ) * y - & 1.14710398652091e-05_dp ) * y + & 2.71252453754519e-04_dp ) * y - & 4.96812745851408e-03_dp ) * y + & 8.26020602026780e-02_dp r3 = ((((((((((( 1.91498302509009e-15_dp * y + & 1.48840394311115e-14_dp ) * y - & 4.316925145767e-13_dp ) * y + & 1.186495793471e-12_dp ) * y + & 4.615806713055e-11_dp ) * y - & 5.54336148667141e-10_dp ) * y + & 3.48789978951367e-10_dp ) * y - & 2.79188977451042e-09_dp ) * y + & 2.09563208958551e-06_dp ) * y - & 6.76512715080324e-05_dp ) * y + & 1.32129867629062e-03_dp ) * y - & 2.05062147771513e-02_dp ) * y + & 2.88068671894324e-01_dp r4 = ((((((((((( - 5.43697691672942e-15_dp * y - & 1.12483395714468e-13_dp ) * y + & 2.826607936174e-12_dp ) * y - & 1.266734493280e-11_dp ) * y - & 4.258722866437e-10_dp ) * y + & 9.45486578503261e-09_dp ) * y - & 5.86635622821309e-08_dp ) * y - & 1.28835028104639e-06_dp ) * y + & 4.41413815691885e-05_dp ) * y - & 7.61738385590776e-04_dp ) * y + & 9.66090902985550e-03_dp ) * y - & 1.01410568057649e-01_dp ) * y + & 9.54714798156712e-01_dp w4 = (((((((((((( - 7.56882223582704e-19_dp * y + & 7.53541779268175e-18_dp ) * y - & 1.157318032236e-16_dp ) * y + & 2.411195002314e-15_dp ) * y - & 3.601794386996e-14_dp ) * y + & 4.082150659615e-13_dp ) * y - & 4.289542980767e-12_dp ) * y + & 5.086829642731e-11_dp ) * y - & 6.35435561050807e-10_dp ) * y + & 6.82309323251123e-09_dp ) * y - & 5.63374555753167e-08_dp ) * y + & 3.57005361100431e-07_dp ) * y - & 2.40050045173721e-06_dp ) * y + & 4.94171300536397e-05_dp w3 = ((((((((((( - 5.54451040921657e-17_dp * y + & 2.68748367250999e-16_dp ) * y + & 1.349020069254e-14_dp ) * y - & 2.507452792892e-13_dp ) * y + & 1.944339743818e-12_dp ) * y - & 1.29816917658823e-11_dp ) * y + & 3.49977768819641e-10_dp ) * y - & 8.67270669346398e-09_dp ) * y + & 1.31381116840118e-07_dp ) * y - & 1.36790720600822e-06_dp ) * y + & 1.19210697673160e-05_dp ) * y - & 1.42181943986587e-04_dp ) * y + & 4.12615396191829e-03_dp w2 = ((((((((((( - 1.86506057729700e-16_dp * y + & 1.16661114435809e-15_dp ) * y + & 2.563712856363e-14_dp ) * y - & 4.498350984631e-13_dp ) * y + & 1.765194089338e-12_dp ) * y + & 9.04483676345625e-12_dp ) * y + & 4.98930345609785e-10_dp ) * y - & 2.11964170928181e-08_dp ) * y + & 3.98295476005614e-07_dp ) * y - & 5.49390160829409e-06_dp ) * y + & 7.74065155353262e-05_dp ) * y - & 1.48201933009105e-03_dp ) * y + & 4.97836392625268e-02_dp w1 = (( 1.9623264149430e-01_dp / x - & 4.9695241464490e-01_dp ) / x - & 6.0156581186481e-05_dp ) * exp ( - x ) + & w1 - w2 - w3 - w4 elseif ( real ( x ) <= 2 5.0e+00_dp ) then w1 = sqrt ( PIo4 / x ) e = exp ( - x ) recx = 1.0e+00_dp / x r1 = (((((( - 4.45711399441838e-05_dp * x + & 1.27267770241379e-03_dp ) * x - & 2.36954961381262e-01_dp ) * x + & 1.54330657903756e+01_dp ) * x - & 5.22799159267808e+02_dp ) * x + & 1.05951216669313e+04_dp ) * x + & ( - 2.51177235556236e+06_dp * recx + & 8.72975373557709e+05_dp ) * recx - & 1.29194382386499e+05_dp ) * e + r14 / ( x - r14 ) r2 = ((((( - 7.85617372254488e-02_dp * x + & 6.35653573484868e+00_dp ) * x - & 3.38296938763990e+02_dp ) * x + & 1.25120495802096e+04_dp ) * x - & 3.16847570511637e+05_dp ) * x + & (( - 1.02427466127427e+09_dp * recx + & 3.70104713293016e+08_dp ) * recx - & 5.87119005093822e+07_dp ) * recx + & 5.38614211391604e+06_dp ) * e + r24 / ( x - r24 ) r3 = ((((( - 2.37900485051067e-01_dp * x + & 1.84122184400896e+01_dp ) * x - & 1.00200731304146e+03_dp ) * x + & 3.75151841595736e+04_dp ) * x - & 9.50626663390130e+05_dp ) * x + & (( - 2.88139014651985e+09_dp * recx + & 1.06625915044526e+09_dp ) * recx - & 1.72465289687396e+08_dp ) * recx + & 1.60419390230055e+07_dp ) * e + r34 / ( x - r34 ) r4 = (((((( - 6.00691586407385e-04_dp * x - & 3.64479545338439e-01_dp ) * x + & 1.57496131755179e+01_dp ) * x - & 6.54944248734901e+02_dp ) * x + & 1.70830039597097e+04_dp ) * x - & 2.90517939780207e+05_dp ) * x + & ( + 3.49059698304732e+07_dp * recx - & 1.64944522586065e+07_dp ) * recx + & 2.96817940164703e+06_dp ) * e + r44 / ( x - r44 ) w4 = ((((((( 2.33766206773151e-07_dp * x - & 3.81542906607063e-05_dp ) * x + & 3.51416601267000e-03_dp ) * x - & 1.66538571864728e-01_dp ) * x + & 4.80006136831847e+00_dp ) * x - & 8.73165934223603e+01_dp ) * x + & 9.77683627474638e+02_dp ) * x + & 1.66000945117640e+04_dp * recx - & 6.14479071209961e+03_dp ) * e + w44 * w1 w3 = (((((( 2.36392855180768e-04_dp * x - & 9.16785337967013e-03_dp ) * x + & 4.62186525041313e-01_dp ) * x - & 1.96943786006540e+01_dp ) * x + & 4.99169195295559e+02_dp ) * x - & 6.21419845845090e+03_dp ) * x + & (( + 5.21445053212414e+07_dp * recx - & 1.34113464389309e+07_dp ) * recx + & 1.13673298305631e+06_dp ) * recx - & 2.81501182042707e+03_dp ) * e + w34 * w1 w2 = (((((( 7.29841848989391e-04_dp * x - & 3.53899555749875e-02_dp ) * x + & 2.07797425718513e+00_dp ) * x - & 1.00464709786287e+02_dp ) * x + & 3.15206108877819e+03_dp ) * x - & 6.27054715090012e+04_dp ) * x + & ( + 1.54721246264919e+07_dp * recx - & 5.26074391316381e+06_dp ) * recx + & 7.67135400969617e+05_dp ) * e + w24 * w1 w1 = (( 1.9623264149430e-01_dp * recx - & 4.9695241464490e-01_dp ) * recx - & 6.0156581186481e-05_dp ) * e + & w1 - w2 - w3 - w4 elseif ( real ( x ) <= 3 5.0e+00_dp ) then w1 = sqrt ( PIo4 / x ) e = exp ( - x ) recx = 1.0e+00_dp / x r1 = (((((( - 4.45711399441838e-05_dp * x + & 1.27267770241379e-03_dp ) * x - & 2.36954961381262e-01_dp ) * x + & 1.54330657903756e+01_dp ) * x - & 5.22799159267808e+02_dp ) * x + & 1.05951216669313e+04_dp ) * x + & ( - 2.51177235556236e+06_dp * recx + & 8.72975373557709e+05_dp ) * recx - & 1.29194382386499e+05_dp ) * e + r14 / ( x - r14 ) r2 = ((((( - 7.85617372254488e-02_dp * x + & 6.35653573484868e+00_dp ) * x - & 3.38296938763990e+02_dp ) * x + & 1.25120495802096e+04_dp ) * x - & 3.16847570511637e+05_dp ) * x + & (( - 1.02427466127427e+09_dp * recx + & 3.70104713293016e+08_dp ) * recx - & 5.87119005093822e+07_dp ) * recx + & 5.38614211391604e+06_dp ) * e + r24 / ( x - r24 ) r3 = ((((( - 2.37900485051067e-01_dp * x + & 1.84122184400896e+01_dp ) * x - & 1.00200731304146e+03_dp ) * x + & 3.75151841595736e+04_dp ) * x - & 9.50626663390130e+05_dp ) * x + & (( - 2.88139014651985e+09_dp * recx + & 1.06625915044526e+09_dp ) * recx - & 1.72465289687396e+08_dp ) * recx + & 1.60419390230055e+07_dp ) * e + r34 / ( x - r34 ) r4 = (((((( - 6.00691586407385e-04_dp * x - & 3.64479545338439e-01_dp ) * x + & 1.57496131755179e+01_dp ) * x - & 6.54944248734901e+02_dp ) * x + & 1.70830039597097e+04_dp ) * x - & 2.90517939780207e+05_dp ) * x + & ( + 3.49059698304732e+07_dp * recx - & 1.64944522586065e+07_dp ) * recx + & 2.96817940164703e+06_dp ) * e + r44 / ( x - r44 ) w4 = (((((( 5.74245945342286e-06_dp * x - & 7.58735928102351e-05_dp ) * x + & 2.35072857922892e-04_dp ) * x - & 3.78812134013125e-03_dp ) * x + & 3.09871652785805e-01_dp ) * x - & 7.11108633061306e+00_dp ) * x + & 5.55297573149528e+01_dp ) * e + w44 * w1 w3 = (((((( 2.36392855180768e-04_dp * x - & 9.16785337967013e-03_dp ) * x + & 4.62186525041313e-01_dp ) * x - & 1.96943786006540e+01_dp ) * x + & 4.99169195295559e+02_dp ) * x - & 6.21419845845090e+03_dp ) * x + & (( + 5.21445053212414e+07_dp * recx - & 1.34113464389309e+07_dp ) * recx + & 1.13673298305631e+06_dp ) * recx - & 2.81501182042707e+03_dp ) * e + w34 * w1 w2 = (((((( 7.29841848989391e-04_dp * x - & 3.53899555749875e-02_dp ) * x + & 2.07797425718513e+00_dp ) * x - & 1.00464709786287e+02_dp ) * x + & 3.15206108877819e+03_dp ) * x - & 6.27054715090012e+04_dp ) * x + & ( + 1.54721246264919e+07_dp * recx - & 5.26074391316381e+06_dp ) * recx + & 7.67135400969617e+05_dp ) * e + w24 * w1 w1 = (( 1.9623264149430e-01_dp * recx - & 4.9695241464490e-01_dp ) * recx - & 6.0156581186481e-05_dp ) * e + & w1 - w2 - w3 - w4 elseif ( real ( x ) <= 5 3.0e+00_dp ) then w1 = sqrt ( PIo4 / x ) e = exp ( - x ) * ( x * x ) ** 2 r4 = (( - 2.19135070169653e-03_dp * x - & 1.19108256987623e-01_dp ) * x - & 7.50238795695573e-01_dp ) * e + r44 / ( x - r44 ) r3 = (( - 9.65842534508637e-04_dp * x - & 4.49822013469279e-02_dp ) * x + & 6.08784033347757e-01_dp ) * e + r34 / ( x - r34 ) r2 = (( - 3.62569791162153e-04_dp * x - & 9.09231717268466e-03_dp ) * x + & 1.84336760556262e-01_dp ) * e + r24 / ( x - r24 ) r1 = (( - 4.07557525914600e-05_dp * x - & 6.88846864931685e-04_dp ) * x + & 1.74725309199384e-02_dp ) * e + r14 / ( x - r14 ) w4 = (( 5.76631982000990e-06_dp * x - & 7.89187283804890e-05_dp ) * x + & 3.28297971853126e-04_dp ) * e + w44 * w1 w3 = (( 2.08294969857230e-04_dp * x - & 3.77489954837361e-03_dp ) * x + & 2.09857151617436e-02_dp ) * e + w34 * w1 w2 = (( 6.16374517326469e-04_dp * x - & 1.26711744680092e-02_dp ) * x + & 8.14504890732155e-02_dp ) * e + w24 * w1 w1 = w1 - w2 - w3 - w4 else r1 = r14 / ( x - r14 ) r2 = r24 / ( x - r24 ) r3 = r34 / ( x - r34 ) r4 = r44 / ( x - r44 ) w1 = sqrt ( PIo4 / x ) w2 = w24 * w1 w3 = w34 * w1 w4 = w44 * w1 w1 = w1 - w2 - w3 - w4 end if r = ( / r1 , r2 , r3 , r4 / ) w = ( / w1 , w2 , w3 , w4 / ) end subroutine rys_rt4_csval subroutine rys_rt5_d ( x , dr , dw ) ! Complex-step analytic derivatives du_t/dX, dw_t/dX of rys_rt5. ! dr(t)=du_t/dX, dw(t)=dw_t/dX, to machine precision (no cancellation). real ( KIND = dp ), intent ( IN ) :: x real ( KIND = dp ), intent ( OUT ) :: dr ( 5 ), dw ( 5 ) complex ( KIND = dp ) :: xc , rc ( 5 ), wc ( 5 ) real ( KIND = dp ), parameter :: hcs = 1.0e-20_dp xc = cmplx ( x , hcs , KIND = dp ) call rys_rt5_csval ( xc , rc , wc ) dr = aimag ( rc ) / hcs dw = aimag ( wc ) / hcs end subroutine rys_rt5_d subroutine rys_rt5_csval ( x , r , w ) complex ( KIND = dp ), intent ( IN ) :: & x complex ( KIND = dp ), intent ( OUT ) :: & r ( 5 ), w ( 5 ) real ( KIND = dp ), parameter :: & r15 = 1.17581320211778e-01_dp , & r25 = 1.07456201243690e+00_dp , & w25 = 2.70967405960535e-01_dp , & r35 = 3.08593744371754e+00_dp , & w35 = 3.82231610015404e-02_dp , & r45 = 6.41472973366203e+00_dp , & w45 = 1.51614186862443e-03_dp , & r55 = 1.18071894899717e+01_dp , & w55 = 8.62130526143657e-06_dp complex ( KIND = dp ) :: y , e , r1 , r2 , r3 , r4 , r5 , w1 , w2 , w3 , w4 , w5 if ( real ( x ) <= 3.0e-07_dp ) then r1 = 2.26659266316985e-02_dp - 2.15865967920897e-03_dp * x r2 = 2.31271692140903e-01_dp - 2.20258754389745e-02_dp * x r3 = 8.57346024118836e-01_dp - 8.16520023025515e-02_dp * x r4 = 2.97353038120346e+00_dp - 2.83193369647137e-01_dp * x r5 = 1.84151859759051e+01_dp - 1.75382723579439e+00_dp * x w1 = 2.95524224714752e-01_dp - 1.96867576909777e-02_dp * x w2 = 2.69266719309995e-01_dp - 5.61737590184721e-02_dp * x w3 = 2.19086362515981e-01_dp - 9.71152726793658e-02_dp * x w4 = 1.49451349150580e-01_dp - 1.02979262193565e-01_dp * x w5 = 6.66713443086877e-02_dp - 5.73782817488315e-02_dp * x elseif ( real ( x ) <= 1.0e+00_dp ) then r1 = (((((( - 4.46679165328413e-11_dp * x + & 1.21879111988031e-09_dp ) * x - & 2.62975022612104e-08_dp ) * x + & 5.15106194905897e-07_dp ) * x - & 9.27933625824749e-06_dp ) * x + & 1.51794097682482e-04_dp ) * x - & 2.15865967920301e-03_dp ) * x + & 2.26659266316985e-02_dp r2 = (((((( 1.93117331714174e-10_dp * x - & 4.57267589660699e-09_dp ) * x + & 2.48339908218932e-08_dp ) * x + & 1.50716729438474e-06_dp ) * x - & 6.07268757707381e-05_dp ) * x + & 1.37506939145643e-03_dp ) * x - & 2.20258754419939e-02_dp ) * x + & 2.31271692140905e-01_dp r3 = ((((( 4.84989776180094e-09_dp * x + & 1.31538893944284e-07_dp ) * x - & 2.766753852879e-06_dp ) * x - & 7.651163510626e-05_dp ) * x + & 4.033058545972e-03_dp ) * x - & 8.16520022916145e-02_dp ) * x + & 8.57346024118779e-01_dp r4 = (((( - 2.48581772214623e-07_dp * x - & 4.34482635782585e-06_dp ) * x - & 7.46018257987630e-07_dp ) * x + & 1.01210776517279e-02_dp ) * x - & 2.83193369640005e-01_dp ) * x + & 2.97353038120345e+00_dp r5 = ((((( - 8.92432153868554e-09_dp * x + & 1.77288899268988e-08_dp ) * x + & 3.040754680666e-06_dp ) * x + & 1.058229325071e-04_dp ) * x + & 4.596379534985e-02_dp ) * x - & 1.75382723579114e+00_dp ) * x + & 1.84151859759049e+01_dp w1 = (((((( - 2.03822632771791e-09_dp * x + & 3.89110229133810e-08_dp ) * x - & 5.84914787904823e-07_dp ) * x + & 8.30316168666696e-06_dp ) * x - & 1.13218402310546e-04_dp ) * x + & 1.49128888586790e-03_dp ) * x - & 1.96867576904816e-02_dp ) * x + & 2.95524224714749e-01_dp w2 = ((((((( 8.62848118397570e-09_dp * x - & 1.38975551148989e-07_dp ) * x + & 1.602894068228e-06_dp ) * x - & 1.646364300836e-05_dp ) * x + & 1.538445806778e-04_dp ) * x - & 1.28848868034502e-03_dp ) * x + & 9.38866933338584e-03_dp ) * x - & 5.61737590178812e-02_dp ) * x + & 2.69266719309991e-01_dp w3 = (((((((( - 9.41953204205665e-09_dp * x + & 1.47452251067755e-07_dp ) * x - & 1.57456991199322e-06_dp ) * x + & 1.45098401798393e-05_dp ) * x - & 1.18858834181513e-04_dp ) * x + & 8.53697675984210e-04_dp ) * x - & 5.22877807397165e-03_dp ) * x + & 2.60854524809786e-02_dp ) * x - & 9.71152726809059e-02_dp ) * x + & 2.19086362515979e-01_dp w4 = (((((((( - 3.84961617022042e-08_dp * x + & 5.66595396544470e-07_dp ) * x - & 5.52351805403748e-06_dp ) * x + & 4.53160377546073e-05_dp ) * x - & 3.22542784865557e-04_dp ) * x + & 1.95682017370967e-03_dp ) * x - & 9.77232537679229e-03_dp ) * x + & 3.79455945268632e-02_dp ) * x - & 1.02979262192227e-01_dp ) * x + & 1.49451349150573e-01_dp w5 = ((((((((( 4.09594812521430e-09_dp * x - & 6.47097874264417e-08_dp ) * x + & 6.743541482689e-07_dp ) * x - & 5.917993920224e-06_dp ) * x + & 4.531969237381e-05_dp ) * x - & 2.99102856679638e-04_dp ) * x + & 1.65695765202643e-03_dp ) * x - & 7.40671222520653e-03_dp ) * x + & 2.50889946832192e-02_dp ) * x - & 5.73782817487958e-02_dp ) * x + & 6.66713443086877e-02_dp elseif ( real ( x ) <= 5.0e+00_dp ) then y = x - 3.0e+00_dp r1 = (((((((( - 2.58163897135138e-14_dp * y + & 8.14127461488273e-13_dp ) * y - & 2.11414838976129e-11_dp ) * y + & 5.09822003260014e-10_dp ) * y - & 1.16002134438663e-08_dp ) * y + & 2.46810694414540e-07_dp ) * y - & 4.92556826124502e-06_dp ) * y + & 9.02580687971053e-05_dp ) * y - & 1.45190025120726e-03_dp ) * y + & 1.73416786387475e-02_dp r2 = ((((((((( 1.04525287289788e-14_dp * y + & 5.44611782010773e-14_dp ) * y - & 4.831059411392e-12_dp ) * y + & 1.136643908832e-10_dp ) * y - & 1.104373076913e-09_dp ) * y - & 2.35346740649916e-08_dp ) * y + & 1.43772622028764e-06_dp ) * y - & 4.23405023015273e-05_dp ) * y + & 9.12034574793379e-04_dp ) * y - & 1.52479441718739e-02_dp ) * y + & 1.76055265928744e-01_dp r3 = ((((((((( - 6.89693150857911e-14_dp * y + & 5.92064260918861e-13_dp ) * y + & 1.847170956043e-11_dp ) * y - & 3.390752744265e-10_dp ) * y - & 2.995532064116e-09_dp ) * y + & 1.57456141058535e-07_dp ) * y - & 3.95859409711346e-07_dp ) * y - & 9.58924580919747e-05_dp ) * y + & 3.23551502557785e-03_dp ) * y - & 5.97587007636479e-02_dp ) * y + & 6.46432853383057e-01_dp r4 = (((((((( - 3.61293809667763e-12_dp * y - & 2.70803518291085e-11_dp ) * y + & 8.83758848468769e-10_dp ) * y + & 1.59166632851267e-08_dp ) * y - & 1.32581997983422e-07_dp ) * y - & 7.60223407443995e-06_dp ) * y - & 7.41019244900952e-05_dp ) * y + & 9.81432631743423e-03_dp ) * y - & 2.23055570487771e-01_dp ) * y + & 2.21460798080643e+00_dp r5 = ((((((((( 7.12332088345321e-13_dp * y + & 3.16578501501894e-12_dp ) * y - & 8.776668218053e-11_dp ) * y - & 2.342817613343e-09_dp ) * y - & 3.496962018025e-08_dp ) * y - & 3.03172870136802e-07_dp ) * y + & 1.50511293969805e-06_dp ) * y + & 1.37704919387696e-04_dp ) * y + & 4.70723869619745e-02_dp ) * y - & 1.47486623003693e+00_dp ) * y + & 1.35704792175847e+01_dp w1 = ((((((((( 1.04348658616398e-13_dp * y - & 1.94147461891055e-12_dp ) * y + & 3.485512360993e-11_dp ) * y - & 6.277497362235e-10_dp ) * y + & 1.100758247388e-08_dp ) * y - & 1.88329804969573e-07_dp ) * y + & 3.12338120839468e-06_dp ) * y - & 5.04404167403568e-05_dp ) * y + & 8.00338056610995e-04_dp ) * y - & 1.30892406559521e-02_dp ) * y + & 2.47383140241103e-01_dp w2 = ((((((((((( 3.23496149760478e-14_dp * y - & 5.24314473469311e-13_dp ) * y + & 7.743219385056e-12_dp ) * y - & 1.146022750992e-10_dp ) * y + & 1.615238462197e-09_dp ) * y - & 2.15479017572233e-08_dp ) * y + & 2.70933462557631e-07_dp ) * y - & 3.18750295288531e-06_dp ) * y + & 3.47425221210099e-05_dp ) * y - & 3.45558237388223e-04_dp ) * y + & 3.05779768191621e-03_dp ) * y - & 2.29118251223003e-02_dp ) * y + & 1.59834227924213e-01_dp w3 = (((((((((((( - 3.42790561802876e-14_dp * y + & 5.26475736681542e-13_dp ) * y - & 7.184330797139e-12_dp ) * y + & 9.763932908544e-11_dp ) * y - & 1.244014559219e-09_dp ) * y + & 1.472744068942e-08_dp ) * y - & 1.611749975234e-07_dp ) * y + & 1.616487851917e-06_dp ) * y - & 1.46852359124154e-05_dp ) * y + & 1.18900349101069e-04_dp ) * y - & 8.37562373221756e-04_dp ) * y + & 4.93752683045845e-03_dp ) * y - & 2.25514728915673e-02_dp ) * y + & 6.95211812453929e-02_dp w4 = ((((((((((((( 1.04072340345039e-14_dp * y - & 1.60808044529211e-13_dp ) * y + & 2.183534866798e-12_dp ) * y - & 2.939403008391e-11_dp ) * y + & 3.679254029085e-10_dp ) * y - & 4.23775673047899e-09_dp ) * y + & 4.46559231067006e-08_dp ) * y - & 4.26488836563267e-07_dp ) * y + & 3.64721335274973e-06_dp ) * y - & 2.74868382777722e-05_dp ) * y + & 1.78586118867488e-04_dp ) * y - & 9.68428981886534e-04_dp ) * y + & 4.16002324339929e-03_dp ) * y - & 1.28290192663141e-02_dp ) * y + & 2.22353727685016e-02_dp w5 = (((((((((((((( - 8.16770412525963e-16_dp * y + & 1.31376515047977e-14_dp ) * y - & 1.856950818865e-13_dp ) * y + & 2.596836515749e-12_dp ) * y - & 3.372639523006e-11_dp ) * y + & 4.025371849467e-10_dp ) * y - & 4.389453269417e-09_dp ) * y + & 4.332753856271e-08_dp ) * y - & 3.82673275931962e-07_dp ) * y + & 2.98006900751543e-06_dp ) * y - & 2.00718990300052e-05_dp ) * y + & 1.13876001386361e-04_dp ) * y - & 5.23627942443563e-04_dp ) * y + & 1.83524565118203e-03_dp ) * y - & 4.37785737450783e-03_dp ) * y + & 5.36963805223095e-03_dp elseif ( real ( x ) <= 1 0.0e+00_dp ) then y = x - 7.5e+00_dp r1 = (((((((( - 1.13825201010775e-14_dp * y + & 1.89737681670375e-13_dp ) * y - & 4.81561201185876e-12_dp ) * y + & 1.56666512163407e-10_dp ) * y - & 3.73782213255083e-09_dp ) * y + & 9.15858355075147e-08_dp ) * y - & 2.13775073585629e-06_dp ) * y + & 4.56547356365536e-05_dp ) * y - & 8.68003909323740e-04_dp ) * y + & 1.22703754069176e-02_dp r2 = ((((((((( - 3.67160504428358e-15_dp * y + & 1.27876280158297e-14_dp ) * y - & 1.296476623788e-12_dp ) * y + & 1.477175434354e-11_dp ) * y + & 5.464102147892e-10_dp ) * y - & 2.42538340602723e-08_dp ) * y + & 8.20460740637617e-07_dp ) * y - & 2.20379304598661e-05_dp ) * y + & 4.90295372978785e-04_dp ) * y - & 9.14294111576119e-03_dp ) * y + & 1.22590403403690e-01_dp r3 = ((((((((( 1.39017367502123e-14_dp * y - & 6.96391385426890e-13_dp ) * y + & 1.176946020731e-12_dp ) * y + & 1.725627235645e-10_dp ) * y - & 3.686383856300e-09_dp ) * y + & 2.87495324207095e-08_dp ) * y + & 1.71307311000282e-06_dp ) * y - & 7.94273603184629e-05_dp ) * y + & 2.00938064965897e-03_dp ) * y - & 3.63329491677178e-02_dp ) * y + & 4.34393683888443e-01_dp r4 = (((((((((( - 1.27815158195209e-14_dp * y + & 1.99910415869821e-14_dp ) * y + & 3.753542914426e-12_dp ) * y - & 2.708018219579e-11_dp ) * y - & 1.190574776587e-09_dp ) * y + & 1.106696436509e-08_dp ) * y + & 3.954955671326e-07_dp ) * y - & 4.398596059588e-06_dp ) * y - & 2.01087998907735e-04_dp ) * y + & 7.89092425542937e-03_dp ) * y - & 1.42056749162695e-01_dp ) * y + & 1.39964149420683e+00_dp r5 = (((((((((( - 1.19442341030461e-13_dp * y - & 2.34074833275956e-12_dp ) * y + & 6.861649627426e-12_dp ) * y + & 6.082671496226e-10_dp ) * y + & 5.381160105420e-09_dp ) * y - & 6.253297138700e-08_dp ) * y - & 2.135966835050e-06_dp ) * y - & 2.373394341886e-05_dp ) * y + & 2.88711171412814e-06_dp ) * y + & 4.85221195290753e-02_dp ) * y - & 1.04346091985269e+00_dp ) * y + & 7.89901551676692e+00_dp w1 = ((((((((( 7.95526040108997e-15_dp * y - & 2.48593096128045e-13_dp ) * y + & 4.761246208720e-12_dp ) * y - & 9.535763686605e-11_dp ) * y + & 2.225273630974e-09_dp ) * y - & 4.49796778054865e-08_dp ) * y + & 9.17812870287386e-07_dp ) * y - & 1.86764236490502e-05_dp ) * y + & 3.76807779068053e-04_dp ) * y - & 8.10456360143408e-03_dp ) * y + & 2.01097936411496e-01_dp w2 = ((((((((((( 1.25678686624734e-15_dp * y - & 2.34266248891173e-14_dp ) * y + & 3.973252415832e-13_dp ) * y - & 6.830539401049e-12_dp ) * y + & 1.140771033372e-10_dp ) * y - & 1.82546185762009e-09_dp ) * y + & 2.77209637550134e-08_dp ) * y - & 4.01726946190383e-07_dp ) * y + & 5.48227244014763e-06_dp ) * y - & 6.95676245982121e-05_dp ) * y + & 8.05193921815776e-04_dp ) * y - & 8.15528438784469e-03_dp ) * y + & 9.71769901268114e-02_dp w3 = (((((((((((( - 8.20929494859896e-16_dp * y + & 1.37356038393016e-14_dp ) * y - & 2.022863065220e-13_dp ) * y + & 3.058055403795e-12_dp ) * y - & 4.387890955243e-11_dp ) * y + & 5.923946274445e-10_dp ) * y - & 7.503659964159e-09_dp ) * y + & 8.851599803902e-08_dp ) * y - & 9.65561998415038e-07_dp ) * y + & 9.60884622778092e-06_dp ) * y - & 8.56551787594404e-05_dp ) * y + & 6.66057194311179e-04_dp ) * y - & 4.17753183902198e-03_dp ) * y + & 2.25443826852447e-02_dp w4 = (((((((((((((( - 1.08764612488790e-17_dp * y + & 1.85299909689937e-16_dp ) * y - & 2.730195628655e-15_dp ) * y + & 4.127368817265e-14_dp ) * y - & 5.881379088074e-13_dp ) * y + & 7.805245193391e-12_dp ) * y - & 9.632707991704e-11_dp ) * y + & 1.099047050624e-09_dp ) * y - & 1.15042731790748e-08_dp ) * y + & 1.09415155268932e-07_dp ) * y - & 9.33687124875935e-07_dp ) * y + & 7.02338477986218e-06_dp ) * y - & 4.53759748787756e-05_dp ) * y + & 2.41722511389146e-04_dp ) * y - & 9.75935943447037e-04_dp ) * y + & 2.57520532789644e-03_dp w5 = ((((((((((((((( 7.28996979748849e-19_dp * y - & 1.26518146195173e-17_dp ) * y + & 1.886145834486e-16_dp ) * y - & 2.876728287383e-15_dp ) * y + & 4.114588668138e-14_dp ) * y - & 5.44436631413933e-13_dp ) * y + & 6.64976446790959e-12_dp ) * y - & 7.44560069974940e-11_dp ) * y + & 7.57553198166848e-10_dp ) * y - & 6.92956101109829e-09_dp ) * y + & 5.62222859033624e-08_dp ) * y - & 3.97500114084351e-07_dp ) * y + & 2.39039126138140e-06_dp ) * y - & 1.18023950002105e-05_dp ) * y + & 4.52254031046244e-05_dp ) * y - & 1.21113782150370e-04_dp ) * y + & 1.75013126731224e-04_dp elseif ( real ( x ) <= 1 5.0e+00_dp ) then y = x - 1 2.5e+00_dp r1 = (((((((((( - 4.16387977337393e-17_dp * y + & 7.20872997373860e-16_dp ) * y + & 1.395993802064e-14_dp ) * y + & 3.660484641252e-14_dp ) * y - & 4.154857548139e-12_dp ) * y + & 2.301379846544e-11_dp ) * y - & 1.033307012866e-09_dp ) * y + & 3.997777641049e-08_dp ) * y - & 9.35118186333939e-07_dp ) * y + & 2.38589932752937e-05_dp ) * y - & 5.35185183652937e-04_dp ) * y + & 8.85218988709735e-03_dp r2 = (((((((((( - 4.56279214732217e-16_dp * y + & 6.24941647247927e-15_dp ) * y + & 1.737896339191e-13_dp ) * y + & 8.964205979517e-14_dp ) * y - & 3.538906780633e-11_dp ) * y + & 9.561341254948e-11_dp ) * y - & 9.772831891310e-09_dp ) * y + & 4.240340194620e-07_dp ) * y - & 1.02384302866534e-05_dp ) * y + & 2.57987709704822e-04_dp ) * y - & 5.54735977651677e-03_dp ) * y + & 8.68245143991948e-02_dp r3 = (((((((((( - 2.52879337929239e-15_dp * y + & 2.13925810087833e-14_dp ) * y + & 7.884307667104e-13_dp ) * y - & 9.023398159510e-13_dp ) * y - & 5.814101544957e-11_dp ) * y - & 1.333480437968e-09_dp ) * y - & 2.217064940373e-08_dp ) * y + & 1.643290788086e-06_dp ) * y - & 4.39602147345028e-05_dp ) * y + & 1.08648982748911e-03_dp ) * y - & 2.13014521653498e-02_dp ) * y + & 2.94150684465425e-01_dp r4 = (((((((((( - 6.42391438038888e-15_dp * y + & 5.37848223438815e-15_dp ) * y + & 8.960828117859e-13_dp ) * y + & 5.214153461337e-11_dp ) * y - & 1.106601744067e-10_dp ) * y - & 2.007890743962e-08_dp ) * y + & 1.543764346501e-07_dp ) * y + & 4.520749076914e-06_dp ) * y - & 1.88893338587047e-04_dp ) * y + & 4.73264487389288e-03_dp ) * y - & 7.91197893350253e-02_dp ) * y + & 8.60057928514554e-01_dp r5 = ((((((((((( - 2.24366166957225e-14_dp * y + & 4.87224967526081e-14_dp ) * y + & 5.587369053655e-12_dp ) * y - & 3.045253104617e-12_dp ) * y - & 1.223983883080e-09_dp ) * y - & 2.05603889396319e-09_dp ) * y + & 2.58604071603561e-07_dp ) * y + & 1.34240904266268e-06_dp ) * y - & 5.72877569731162e-05_dp ) * y - & 9.56275105032191e-04_dp ) * y + & 4.23367010370921e-02_dp ) * y - & 5.76800927133412e-01_dp ) * y + & 3.87328263873381e+00_dp w1 = ((((((((( 8.98007931950169e-15_dp * y + & 7.25673623859497e-14_dp ) * y + & 5.851494250405e-14_dp ) * y - & 4.234204823846e-11_dp ) * y + & 3.911507312679e-10_dp ) * y - & 9.65094802088511e-09_dp ) * y + & 3.42197444235714e-07_dp ) * y - & 7.51821178144509e-06_dp ) * y + & 1.94218051498662e-04_dp ) * y - & 5.38533819142287e-03_dp ) * y + & 1.68122596736809e-01_dp w2 = (((((((((( - 1.05490525395105e-15_dp * y + & 1.96855386549388e-14_dp ) * y - & 5.500330153548e-13_dp ) * y + & 1.003849567976e-11_dp ) * y - & 1.720997242621e-10_dp ) * y + & 3.533277061402e-09_dp ) * y - & 6.389171736029e-08_dp ) * y + & 1.046236652393e-06_dp ) * y - & 1.73148206795827e-05_dp ) * y + & 2.57820531617185e-04_dp ) * y - & 3.46188265338350e-03_dp ) * y + & 7.03302497508176e-02_dp w3 = ((((((((((( 3.60020423754545e-16_dp * y - & 6.24245825017148e-15_dp ) * y + & 9.945311467434e-14_dp ) * y - & 1.749051512721e-12_dp ) * y + & 2.768503957853e-11_dp ) * y - & 4.08688551136506e-10_dp ) * y + & 6.04189063303610e-09_dp ) * y - & 8.23540111024147e-08_dp ) * y + & 1.01503783870262e-06_dp ) * y - & 1.20490761741576e-05_dp ) * y + & 1.26928442448148e-04_dp ) * y - & 1.05539461930597e-03_dp ) * y + & 1.15543698537013e-02_dp w4 = ((((((((((((( 2.51163533058925e-18_dp * y - & 4.31723745510697e-17_dp ) * y + & 6.557620865832e-16_dp ) * y - & 1.016528519495e-14_dp ) * y + & 1.491302084832e-13_dp ) * y - & 2.06638666222265e-12_dp ) * y + & 2.67958697789258e-11_dp ) * y - & 3.23322654638336e-10_dp ) * y + & 3.63722952167779e-09_dp ) * y - & 3.75484943783021e-08_dp ) * y + & 3.49164261987184e-07_dp ) * y - & 2.92658670674908e-06_dp ) * y + & 2.12937256719543e-05_dp ) * y - & 1.19434130620929e-04_dp ) * y + & 6.45524336158384e-04_dp w5 = (((((((((((((( - 1.29043630202811e-19_dp * y + & 2.16234952241296e-18_dp ) * y - & 3.107631557965e-17_dp ) * y + & 4.570804313173e-16_dp ) * y - & 6.301348858104e-15_dp ) * y + & 8.031304476153e-14_dp ) * y - & 9.446196472547e-13_dp ) * y + & 1.018245804339e-11_dp ) * y - & 9.96995451348129e-11_dp ) * y + & 8.77489010276305e-10_dp ) * y - & 6.84655877575364e-09_dp ) * y + & 4.64460857084983e-08_dp ) * y - & 2.66924538268397e-07_dp ) * y + & 1.24621276265907e-06_dp ) * y - & 4.30868944351523e-06_dp ) * y + & 9.94307982432868e-06_dp elseif ( real ( x ) <= 2 0.0e+00_dp ) then y = x - 1 7.5e+00_dp r1 = (((((((((( 1.91875764545740e-16_dp * y + & 7.8357401095707e-16_dp ) * y - & 3.260875931644e-14_dp ) * y - & 1.186752035569e-13_dp ) * y + & 4.275180095653e-12_dp ) * y + & 3.357056136731e-11_dp ) * y - & 1.123776903884e-09_dp ) * y + & 1.231203269887e-08_dp ) * y - & 3.99851421361031e-07_dp ) * y + & 1.45418822817771e-05_dp ) * y - & 3.49912254976317e-04_dp ) * y + & 6.67768703938812e-03_dp r2 = (((((((((( 2.02778478673555e-15_dp * y + & 1.01640716785099e-14_dp ) * y - & 3.385363492036e-13_dp ) * y - & 1.615655871159e-12_dp ) * y + & 4.527419140333e-11_dp ) * y + & 3.853670706486e-10_dp ) * y - & 1.184607130107e-08_dp ) * y + & 1.347873288827e-07_dp ) * y - & 4.47788241748377e-06_dp ) * y + & 1.54942754358273e-04_dp ) * y - & 3.55524254280266e-03_dp ) * y + & 6.44912219301603e-02_dp r3 = (((((((((( 7.79850771456444e-15_dp * y + & 6.00464406395001e-14_dp ) * y - & 1.249779730869e-12_dp ) * y - & 1.020720636353e-11_dp ) * y + & 1.814709816693e-10_dp ) * y + & 1.766397336977e-09_dp ) * y - & 4.603559449010e-08_dp ) * y + & 5.863956443581e-07_dp ) * y - & 2.03797212506691e-05_dp ) * y + & 6.31405161185185e-04_dp ) * y - & 1.30102750145071e-02_dp ) * y + & 2.10244289044705e-01_dp r4 = ((((((((((( - 2.92397030777912e-15_dp * y + & 1.94152129078465e-14_dp ) * y + & 4.859447665850e-13_dp ) * y - & 3.217227223463e-12_dp ) * y - & 7.484522135512e-11_dp ) * y + & 7.19101516047753e-10_dp ) * y + & 6.88409355245582e-09_dp ) * y - & 1.44374545515769e-07_dp ) * y + & 2.74941013315834e-06_dp ) * y - & 1.02790452049013e-04_dp ) * y + & 2.59924221372643e-03_dp ) * y - & 4.35712368303551e-02_dp ) * y + & 5.62170709585029e-01_dp r5 = ((((((((((( 1.17976126840060e-14_dp * y + & 1.24156229350669e-13_dp ) * y - & 3.892741622280e-12_dp ) * y - & 7.755793199043e-12_dp ) * y + & 9.492190032313e-10_dp ) * y - & 4.98680128123353e-09_dp ) * y - & 1.81502268782664e-07_dp ) * y + & 2.69463269394888e-06_dp ) * y + & 2.50032154421640e-05_dp ) * y - & 1.33684303917681e-03_dp ) * y + & 2.29121951862538e-02_dp ) * y - & 2.45653725061323e-01_dp ) * y + & 1.89999883453047e+00_dp w1 = (((((((((( 1.74841995087592e-15_dp * y - & 6.95671892641256e-16_dp ) * y - & 3.000659497257e-13_dp ) * y + & 2.021279817961e-13_dp ) * y + & 3.853596935400e-11_dp ) * y + & 1.461418533652e-10_dp ) * y - & 1.014517563435e-08_dp ) * y + & 1.132736008979e-07_dp ) * y - & 2.86605475073259e-06_dp ) * y + & 1.21958354908768e-04_dp ) * y - & 3.86293751153466e-03_dp ) * y + & 1.45298342081522e-01_dp w2 = (((((((((( - 1.11199320525573e-15_dp * y + & 1.85007587796671e-15_dp ) * y + & 1.220613939709e-13_dp ) * y + & 1.275068098526e-12_dp ) * y - & 5.341838883262e-11_dp ) * y + & 6.161037256669e-10_dp ) * y - & 1.009147879750e-08_dp ) * y + & 2.907862965346e-07_dp ) * y - & 6.12300038720919e-06_dp ) * y + & 1.00104454489518e-04_dp ) * y - & 1.80677298502757e-03_dp ) * y + & 5.78009914536630e-02_dp w3 = (((((((((( - 9.49816486853687e-16_dp * y + & 6.67922080354234e-15_dp ) * y + & 2.606163540537e-15_dp ) * y + & 1.983799950150e-12_dp ) * y - & 5.400548574357e-11_dp ) * y + & 6.638043374114e-10_dp ) * y - & 8.799518866802e-09_dp ) * y + & 1.791418482685e-07_dp ) * y - & 2.96075397351101e-06_dp ) * y + & 3.38028206156144e-05_dp ) * y - & 3.58426847857878e-04_dp ) * y + & 8.39213709428516e-03_dp w4 = ((((((((((( 1.33829971060180e-17_dp * y - & 3.44841877844140e-16_dp ) * y + & 4.745009557656e-15_dp ) * y - & 6.033814209875e-14_dp ) * y + & 1.049256040808e-12_dp ) * y - & 1.70859789556117e-11_dp ) * y + & 2.15219425727959e-10_dp ) * y - & 2.52746574206884e-09_dp ) * y + & 3.27761714422960e-08_dp ) * y - & 3.90387662925193e-07_dp ) * y + & 3.46340204593870e-06_dp ) * y - & 2.43236345136782e-05_dp ) * y + & 3.54846978585226e-04_dp w5 = ((((((((((((( 2.69412277020887e-20_dp * y - & 4.24837886165685e-19_dp ) * y + & 6.030500065438e-18_dp ) * y - & 9.069722758289e-17_dp ) * y + & 1.246599177672e-15_dp ) * y - & 1.56872999797549e-14_dp ) * y + & 1.87305099552692e-13_dp ) * y - & 2.09498886675861e-12_dp ) * y + & 2.11630022068394e-11_dp ) * y - & 1.92566242323525e-10_dp ) * y + & 1.62012436344069e-09_dp ) * y - & 1.23621614171556e-08_dp ) * y + & 7.72165684563049e-08_dp ) * y - & 3.59858901591047e-07_dp ) * y + & 2.43682618601000e-06_dp elseif ( real ( x ) <= 2 5.0e+00_dp ) then y = x - 2 2.5e+00_dp r1 = ((((((((( - 1.13927848238726e-15_dp * y + & 7.39404133595713e-15_dp ) * y + & 1.445982921243e-13_dp ) * y - & 2.676703245252e-12_dp ) * y + & 5.823521627177e-12_dp ) * y + & 2.17264723874381e-10_dp ) * y + & 3.56242145897468e-09_dp ) * y - & 3.03763737404491e-07_dp ) * y + & 9.46859114120901e-06_dp ) * y - & 2.30896753853196e-04_dp ) * y + & 5.24663913001114e-03_dp r2 = (((((((((( 2.89872355524581e-16_dp * y - & 1.22296292045864e-14_dp ) * y + & 6.184065097200e-14_dp ) * y + & 1.649846591230e-12_dp ) * y - & 2.729713905266e-11_dp ) * y + & 3.709913790650e-11_dp ) * y + & 2.216486288382e-09_dp ) * y + & 4.616160236414e-08_dp ) * y - & 3.32380270861364e-06_dp ) * y + & 9.84635072633776e-05_dp ) * y - & 2.30092118015697e-03_dp ) * y + & 5.00845183695073e-02_dp r3 = (((((((((( 1.97068646590923e-15_dp * y - & 4.89419270626800e-14_dp ) * y + & 1.136466605916e-13_dp ) * y + & 7.546203883874e-12_dp ) * y - & 9.635646767455e-11_dp ) * y - & 8.295965491209e-11_dp ) * y + & 7.534109114453e-09_dp ) * y + & 2.699970652707e-07_dp ) * y - & 1.42982334217081e-05_dp ) * y + & 3.78290946669264e-04_dp ) * y - & 8.03133015084373e-03_dp ) * y + & 1.58689469640791e-01_dp r4 = (((((((((( 1.33642069941389e-14_dp * y - & 1.55850612605745e-13_dp ) * y - & 7.522712577474e-13_dp ) * y + & 3.209520801187e-11_dp ) * y - & 2.075594313618e-10_dp ) * y - & 2.070575894402e-09_dp ) * y + & 7.323046997451e-09_dp ) * y + & 1.851491550417e-06_dp ) * y - & 6.37524802411383e-05_dp ) * y + & 1.36795464918785e-03_dp ) * y - & 2.42051126993146e-02_dp ) * y + & 3.97847167557815e-01_dp r5 = (((((((((( - 6.07053986130526e-14_dp * y + & 1.04447493138843e-12_dp ) * y - & 4.286617818951e-13_dp ) * y - & 2.632066100073e-10_dp ) * y + & 4.804518986559e-09_dp ) * y - & 1.835675889421e-08_dp ) * y - & 1.068175391334e-06_dp ) * y + & 3.292234974141e-05_dp ) * y - & 5.94805357558251e-04_dp ) * y + & 8.29382168612791e-03_dp ) * y - & 9.93122509049447e-02_dp ) * y + & 1.09857804755042e+00_dp w1 = ((((((((( - 9.10338640266542e-15_dp * y + & 1.00438927627833e-13_dp ) * y + & 7.817349237071e-13_dp ) * y - & 2.547619474232e-11_dp ) * y + & 1.479321506529e-10_dp ) * y + & 1.52314028857627e-09_dp ) * y + & 9.20072040917242e-09_dp ) * y - & 2.19427111221848e-06_dp ) * y + & 8.65797782880311e-05_dp ) * y - & 2.82718629312875e-03_dp ) * y + & 1.28718310443295e-01_dp w2 = ((((((((( 5.52380927618760e-15_dp * y - & 6.43424400204124e-14_dp ) * y - & 2.358734508092e-13_dp ) * y + & 8.261326648131e-12_dp ) * y + & 9.229645304956e-11_dp ) * y - & 5.68108973828949e-09_dp ) * y + & 1.22477891136278e-07_dp ) * y - & 2.11919643127927e-06_dp ) * y + & 4.23605032368922e-05_dp ) * y - & 1.14423444576221e-03_dp ) * y + & 5.06607252890186e-02_dp w3 = ((((((((( 3.99457454087556e-15_dp * y - & 5.11826702824182e-14_dp ) * y - & 4.157593182747e-14_dp ) * y + & 4.214670817758e-12_dp ) * y + & 6.705582751532e-11_dp ) * y - & 3.36086411698418e-09_dp ) * y + & 6.07453633298986e-08_dp ) * y - & 7.40736211041247e-07_dp ) * y + & 8.84176371665149e-06_dp ) * y - & 1.72559275066834e-04_dp ) * y + & 7.16639814253567e-03_dp w4 = ((((((((((( - 2.14649508112234e-18_dp * y - & 2.45525846412281e-18_dp ) * y + & 6.126212599772e-16_dp ) * y - & 8.526651626939e-15_dp ) * y + & 4.826636065733e-14_dp ) * y - & 3.39554163649740e-13_dp ) * y + & 1.67070784862985e-11_dp ) * y - & 4.42671979311163e-10_dp ) * y + & 6.77368055908400e-09_dp ) * y - & 7.03520999708859e-08_dp ) * y + & 6.04993294708874e-07_dp ) * y - & 7.80555094280483e-06_dp ) * y + & 2.85954806605017e-04_dp w5 = (((((((((((( - 5.63938733073804e-21_dp * y + & 6.92182516324628e-20_dp ) * y - & 1.586937691507e-18_dp ) * y + & 3.357639744582e-17_dp ) * y - & 4.810285046442e-16_dp ) * y + & 5.386312669975e-15_dp ) * y - & 6.117895297439e-14_dp ) * y + & 8.441808227634e-13_dp ) * y - & 1.18527596836592e-11_dp ) * y + & 1.36296870441445e-10_dp ) * y - & 1.17842611094141e-09_dp ) * y + & 7.80430641995926e-09_dp ) * y - & 5.97767417400540e-08_dp ) * y + & 1.65186146094969e-06_dp elseif ( real ( x ) <= 4 0.0e+00_dp ) then w1 = sqrt ( PIo4 / x ) e = exp ( - x ) r1 = (((((((( - 1.73363958895356e-06_dp * x + & 1.19921331441483e-04_dp ) * x - & 1.59437614121125e-02_dp ) * x + & 1.13467897349442e+00_dp ) * x - & 4.47216460864586e+01_dp ) * x + & 1.06251216612604e+03_dp ) * x - & 1.52073917378512e+04_dp ) * x + & 1.20662887111273e+05_dp ) * x - & 4.07186366852475e+05_dp ) * e + r15 / ( x - r15 ) r2 = (((((((( - 1.60102542621710e-05_dp * x + & 1.10331262112395e-03_dp ) * x - & 1.50043662589017e-01_dp ) * x + & 1.05563640866077e+01_dp ) * x - & 4.10468817024806e+02_dp ) * x + & 9.62604416506819e+03_dp ) * x - & 1.35888069838270e+05_dp ) * x + & 1.06107577038340e+06_dp ) * x - & 3.51190792816119e+06_dp ) * e + r25 / ( x - r25 ) r3 = (((((((( - 4.48880032128422e-05_dp * x + & 2.69025112122177e-03_dp ) * x - & 4.01048115525954e-01_dp ) * x + & 2.78360021977405e+01_dp ) * x - & 1.04891729356965e+03_dp ) * x + & 2.36985942687423e+04_dp ) * x - & 3.19504627257548e+05_dp ) * x + & 2.34879693563358e+06_dp ) * x - & 7.16341568174085e+06_dp ) * e + r35 / ( x - r35 ) r4 = (((((((( - 6.38526371092582e-05_dp * x - & 2.29263585792626e-03_dp ) * x - & 7.65735935499627e-02_dp ) * x + & 9.12692349152792e+00_dp ) * x - & 2.32077034386717e+02_dp ) * x + & 2.81839578728845e+02_dp ) * x + & 9.59529683876419e+04_dp ) * x - & 1.77638956809518e+06_dp ) * x + & 1.02489759645410e+07_dp ) * e + r45 / ( x - r45 ) r5 = (((((((( - 3.59049364231569e-05_dp * x - & 2.25963977930044e-02_dp ) * x + & 1.12594870794668e+00_dp ) * x - & 4.56752462103909e+01_dp ) * x + & 1.05804526830637e+03_dp ) * x - & 1.16003199605875e+04_dp ) * x - & 4.07297627297272e+04_dp ) * x + & 2.22215528319857e+06_dp ) * x - & 1.61196455032613e+07_dp ) * e + r55 / ( x - r55 ) w5 = ((((((((( - 4.61100906133970e-10_dp * x + & 1.43069932644286e-07_dp ) * x - & 1.63960915431080e-05_dp ) * x + & 1.15791154612838e-03_dp ) * x - & 5.30573476742071e-02_dp ) * x + & 1.61156533367153e+00_dp ) * x - & 3.23248143316007e+01_dp ) * x + & 4.12007318109157e+02_dp ) * x - & 3.02260070158372e+03_dp ) * x + & 9.71575094154768e+03_dp ) * e + w55 * w1 w4 = ((((((((( - 2.40799435809950e-08_dp * x + & 8.12621667601546e-06_dp ) * x - & 9.04491430884113e-04_dp ) * x + & 6.37686375770059e-02_dp ) * x - & 2.96135703135647e+00_dp ) * x + & 9.15142356996330e+01_dp ) * x - & 1.86971865249111e+03_dp ) * x + & 2.42945528916947e+04_dp ) * x - & 1.81852473229081e+05_dp ) * x + & 5.96854758661427e+05_dp ) * e + w45 * w1 w3 = (((((((( 1.83574464457207e-05_dp * x - & 1.54837969489927e-03_dp ) * x + & 1.18520453711586e-01_dp ) * x - & 6.69649981309161e+00_dp ) * x + & 2.44789386487321e+02_dp ) * x - & 5.68832664556359e+03_dp ) * x + & 8.14507604229357e+04_dp ) * x - & 6.55181056671474e+05_dp ) * x + & 2.26410896607237e+06_dp ) * e + w35 * w1 w2 = (((((((( 2.77778345870650e-05_dp * x - & 2.22835017655890e-03_dp ) * x + & 1.61077633475573e-01_dp ) * x - & 8.96743743396132e+00_dp ) * x + & 3.28062687293374e+02_dp ) * x - & 7.65722701219557e+03_dp ) * x + & 1.10255055017664e+05_dp ) * x - & 8.92528122219324e+05_dp ) * x + & 3.10638627744347e+06_dp ) * e + w25 * w1 w1 = w1 - 0.01962e+00_dp * e - w2 - w3 - w4 - w5 elseif ( real ( x ) <= 5 9.0e+00_dp ) then w1 = sqrt ( PIo4 / x ) y = x ** 3 e = y * exp ( - x ) r1 = ((( - 2.43758528330205e-02_dp * x + & 2.07301567989771e+00_dp ) * x - & 6.45964225381113e+01_dp ) * x + & 7.14160088655470e+02_dp ) * e + r15 / ( x - r15 ) r2 = ((( - 2.28861955413636e-01_dp * x + & 1.93190784733691e+01_dp ) * x - & 5.99774730340912e+02_dp ) * x + & 6.61844165304871e+03_dp ) * e + r25 / ( x - r25 ) r3 = ((( - 6.95053039285586e-01_dp * x + & 5.76874090316016e+01_dp ) * x - & 1.77704143225520e+03_dp ) * x + & 1.95366082947811e+04_dp ) * e + r35 / ( x - r35 ) r4 = ((( - 1.58072809087018e+00_dp * x + & 1.27050801091948e+02_dp ) * x - & 3.86687350914280e+03_dp ) * x + & 4.23024828121420e+04_dp ) * e + r45 / ( x - r45 ) r5 = ((( - 3.33963830405396e+00_dp * x + & 2.51830424600204e+02_dp ) * x - & 7.57728527654961e+03_dp ) * x + & 8.21966816595690e+04_dp ) * e + r55 / ( x - r55 ) e = y * e w5 = (( 1.35482430510942e-08_dp * x - & 3.27722199212781e-07_dp ) * x + & 2.41522703684296e-06_dp ) * e + w55 * w1 w4 = (( 1.23464092261605e-06_dp * x - & 3.55224564275590e-05_dp ) * x + & 3.03274662192286e-04_dp ) * e + w45 * w1 w3 = (( 1.34547929260279e-05_dp * x - & 4.19389884772726e-04_dp ) * x + & 3.87706687610809e-03_dp ) * e + w35 * w1 w2 = (( 2.09539509123135e-05_dp * x - & 6.87646614786982e-04_dp ) * x + & 6.68743788585688e-03_dp ) * e + w25 * w1 w1 = w1 - w2 - w3 - w4 - w5 else w1 = sqrt ( PIo4 / x ) r1 = r15 / ( x - r15 ) r2 = r25 / ( x - r25 ) r3 = r35 / ( x - r35 ) r4 = r45 / ( x - r45 ) r5 = r55 / ( x - r55 ) w2 = w25 * w1 w3 = w35 * w1 w4 = w45 * w1 w5 = w55 * w1 w1 = w1 - w2 - w3 - w4 - w5 end if r = ( / r1 , r2 , r3 , r4 , r5 / ) w = ( / w1 , w2 , w3 , w4 , w5 / ) end subroutine rys_rt5_csval end module rys_deriv","tags":"","url":"sourcefile/rys_deriv.f90.html"},{"title":"errcode.F90 – OpenQP Fortran API","text":"Source Code module errcode implicit none private public assignment ( = ), operator ( == ) public errcode_t integer , parameter , private :: & OQP_TOPIC_MASK = int ( z 'FF00' ), & OQP_VALUE_MASK = int ( z '00FF' ) type :: errcode_t integer :: topic integer :: code contains procedure :: getcode => errcode_t_getcode procedure :: explain => errcode_t_explain procedure , private :: errcode_t_set end type interface errcode_t module procedure errcode_t_init end interface interface assignment ( = ) module procedure errcode_t_set , errcode_t_set_i end interface interface operator ( == ) module procedure errcode_t_compare_ee , & errcode_t_compare_ie , errcode_t_compare_ei end interface contains !############################################################### ! error codes !############################################################### function errcode_t_init ( val ) result ( res ) integer , intent ( in ) :: val type ( errcode_t ) :: res res = val end function subroutine errcode_t_explain ( this ) class ( errcode_t ), intent ( in ) :: this write ( * , '(2(A,I0.4))' ) & \"ErrMsg topic=\" , this % topic , & \", code=\" , this % code end subroutine subroutine errcode_t_set ( this , val ) class ( errcode_t ), intent ( inout ) :: this integer , intent ( in ) :: val this % topic = ishft ( val , - 8 ) this % code = iand ( val , OQP_VALUE_MASK ) end subroutine function errcode_t_getcode ( this ) result ( res ) class ( errcode_t ), intent ( in ) :: this integer :: res res = ishft ( this % topic , 8 ) + this % code end function subroutine errcode_t_set_i ( val , this ) integer , intent ( out ) :: val class ( errcode_t ), intent ( in ) :: this val = this % getcode () end subroutine function errcode_t_compare_ee ( this , another ) result ( res ) class ( errcode_t ), intent ( in ) :: this class ( errcode_t ), intent ( in ) :: another logical :: res res = this % getcode () == another % getcode () end function function errcode_t_compare_ei ( this , another ) result ( res ) class ( errcode_t ), intent ( in ) :: this integer , intent ( in ) :: another logical :: res res = this % getcode () == another end function function errcode_t_compare_ie ( this , another ) result ( res ) integer , intent ( in ) :: this class ( errcode_t ), intent ( in ) :: another logical :: res res = this == another % getcode () end function end module","tags":"","url":"sourcefile/errcode.f90.html"},{"title":"cphf.F90 – OpenQP Fortran API","text":"Source Code module cphf_mod !> @brief Native coupled-perturbed Hartree-Fock / Kohn-Sham (CPHF/CPKS) solver !>   for closed-shell (RHF/RKS) references. !> !>   The static CPHF A-matrix is the orbital Hessian (A+B)_{ia,jb}, the same !>   operator the TDDFT Z-vector solver applies. This module reuses that exact !>   operator -- built from the native Rys 2e engine via int2_td_data_t plus the !>   DFT XC kernel (tddft_fxc) -- so it has no libint dependency. It drives the !>   existing pcg solver with: !>     update  : U(MO,occ-vir) -> AO density (iatogen) -> response Fock (A+B) !>               -> MO occ-vir (mntoia) + orbital-energy diagonal (e_a-e_i) U !>     precond : diagonal 1/(e_a-e_i) !>   to solve  A U = B  for an arbitrary occ-vir right-hand side B. !> !>   cphf_solve is the reusable entry point (used by the analytic Hessian for the !>   nuclear-perturbation response). cphf_polarizability_selftest validates the !>   solver end to end against a known property: it solves with the dipole !>   right-hand side and forms the static dipole polarizability, written to a file !>   for comparison against an external reference (no geometry derivatives required). use precision , only : dp use iso_c_binding , only : c_ptr , c_loc , c_f_pointer use types , only : information use basis_tools , only : basis_set use int2_compute , only : int2_compute_t , int2_fock_data_t use tdhf_lib , only : int2_td_data_t , iatogen , mntoia use mod_dft_molgrid , only : dft_grid_t use pcg_mod , only : pcg_t , PCG_OK , PCG_CONVERGED use io_constants , only : iw implicit none character ( len =* ), parameter :: module_name = \"cphf_mod\" !> Opaque data passed to the PCG callbacks (the A-matrix action). type :: cphf_cg_data type ( information ), pointer :: infos => null () type ( int2_compute_t ), pointer :: int2_driver => null () class ( int2_fock_data_t ), pointer :: int2_data => null () type ( dft_grid_t ), pointer :: molgrid => null () real ( kind = dp ), pointer :: wrk (:,:) => null () real ( kind = dp ), pointer :: mo (:,:) => null () real ( kind = dp ), pointer :: pa (:,:,:) => null () real ( kind = dp ), pointer :: xm (:) => null () ! (e_a - e_i), length nocc*nvir real ( kind = dp ), pointer :: xminv (:) => null () ! 1/(e_a - e_i) integer :: nbf = 0 integer :: nocc = 0 logical :: dft = . false . end type !> Opaque data for the open-shell (UHF) A-matrix action.  The rotation vector !> is the concatenation of the alpha occ-vir block (length la = nocca*nvira) !> and the beta occ-vir block (length lb = noccb*nvirb). type :: cphf_cg_data_uhf type ( information ), pointer :: infos => null () type ( basis_set ), pointer :: basis => null () type ( dft_grid_t ), pointer :: molgrid => null () real ( kind = dp ), pointer :: moa (:,:) => null () real ( kind = dp ), pointer :: mob (:,:) => null () real ( kind = dp ), pointer :: xm (:) => null () ! (e_a - e_i) for [alpha; beta] real ( kind = dp ), pointer :: xminv (:) => null () ! 1/(e_a - e_i) real ( kind = dp ), pointer :: wrka (:,:) => null () ! nbf x nbf scratch (alpha) real ( kind = dp ), pointer :: wrkb (:,:) => null () ! nbf x nbf scratch (beta) integer :: nbf = 0 integer :: nocca = 0 integer :: noccb = 0 integer :: la = 0 integer :: lb = 0 real ( kind = dp ) :: scale_exch = 1.0_dp logical :: dft = . false . end type !> Opaque data for the open-shell (ROHF) orbital-Hessian action.  ROHF uses a !> SINGLE MO set with a docc / socc / virt partition, so the rotation vector is !> laid out over the three non-redundant blocks (socc-docc, virt-docc, !> virt-socc) exactly as scf_converger::pack_rohf_trial.  The action is the !> EXACT ROHF orbital Hessian: the Fock-transform part is the full commutator !>   y = pack( [F&#94;a_MO, K]_vo + [C&#94;T G&#94;a C]_vo ,  [F&#94;b_MO, K]_vo + [C&#94;T G&#94;b C]_vo ) !> where K is the antisymmetric MO rotation built from the packed trial vector !> (vir-occ blocks plus the socc-docc occ-occ block), F&#94;s_MO the converged spin !> Fock in the MO basis (full matrix), and G&#94;s the response Fock from !> get_response_packed.  The commutator [F_MO,K] (not the canonical Fvv K - K !> Foo) is required because the raw spin-Fock vir-occ blocks are nonzero for the !> non-canonical ROHF orbitals; their coupling to the socc-docc/virt-socc !> rotations is exactly the term the canonical form drops. type :: cphf_cg_data_rohf type ( information ), pointer :: infos => null () type ( basis_set ), pointer :: basis => null () type ( dft_grid_t ), pointer :: molgrid => null () real ( kind = dp ), pointer :: mo (:,:) => null () real ( kind = dp ), pointer :: famo (:,:) => null () ! alpha Fock (full, MO basis) real ( kind = dp ), pointer :: fbmo (:,:) => null () ! beta  Fock (full, MO basis) real ( kind = dp ), pointer :: xminv (:) => null () ! diagonal preconditioner integer :: nbf = 0 integer :: nocca = 0 , noccb = 0 , nvira = 0 , nvirb = 0 , offset = 0 , ltot = 0 real ( kind = dp ) :: scale_exch = 1.0_dp logical :: dft = . false . end type private public :: cphf_solve public :: cphf_solve_uhf public :: cphf_solve_rohf public :: rohf_pack_trial , rohf_unpack_trial public :: cphf_static_polarizability public :: cphf_static_polarizability_C public :: cphf_uhf_static_polarizability public :: cphf_rohf_static_polarizability public :: cphf_polarizability_selftest public :: cphf_polarizability_selftest_C public :: cphf_uhf_polarizability_selftest public :: cphf_uhf_polarizability_selftest_C public :: cphf_rohf_polarizability_selftest public :: cphf_rohf_polarizability_selftest_C contains !############################################################################### !> @brief Solve A U = B for closed-shell CPHF, B and U in MO occ-vir layout !>   (nocc*nvir, nrhs), matching the iatogen/mntoia convention. !> @param[in]    infos   system/control information (must have a converged RHF/RKS) !> @param[in]    nrhs    number of right-hand sides !> @param[in]    bvec    (nocc*nvir, nrhs) right-hand sides !> @param[out]   uvec    (nocc*nvir, nrhs) solutions !> @param[in]    tol     CG tolerance (optional) !> @param[in]    maxit   max CG iterations (optional) subroutine cphf_solve ( infos , nrhs , bvec , uvec , tol , maxit ) use oqp_tagarray_driver , only : tagarray_get_data , OQP_E_MO_A , OQP_VEC_MO_A use dft , only : dft_initialize real ( kind = dp ), parameter :: default_tol = 1.0d-9 type ( information ), target , intent ( inout ) :: infos integer , intent ( in ) :: nrhs real ( kind = dp ), intent ( in ) :: bvec (:,:) real ( kind = dp ), intent ( out ) :: uvec (:,:) real ( kind = dp ), intent ( in ), optional :: tol integer , intent ( in ), optional :: maxit type ( basis_set ), pointer :: basis type ( dft_grid_t ), target :: molgrid type ( int2_compute_t ), target :: int2_driver type ( int2_td_data_t ), target :: int2_data type ( cphf_cg_data ), target :: cgdata type ( pcg_t ) :: pcg real ( kind = dp ), contiguous , pointer :: mo_a (:,:), mo_energy_a (:) real ( kind = dp ), allocatable , target :: wrk1 (:,:), pa (:,:,:), xm (:), xminv (:) real ( kind = dp ), pointer :: pxm (:,:) integer :: nbf , nocc , nvir , lexc , i , j , irhs , iter , mxit integer :: clock_rate , clock_start , clock_stop , rhs_clock_start , rhs_clock_stop logical :: dft real ( kind = dp ) :: cnv , scale_exch real ( kind = dp ) :: cpu_start , cpu_stop , rhs_cpu_start , rhs_cpu_stop , rhs_wall basis => infos % basis basis % atoms => infos % atoms nbf = basis % nbf nocc = infos % mol_prop % nocc nvir = nbf - nocc lexc = nocc * nvir dft = infos % control % hamilton == 20 cnv = default_tol ; if ( present ( tol )) cnv = tol mxit = 100 ; if ( present ( maxit )) mxit = maxit if ( mxit < lexc + 5 ) mxit = lexc + 5 call tagarray_get_data ( infos % dat , OQP_E_MO_A , mo_energy_a ) call tagarray_get_data ( infos % dat , OQP_VEC_MO_A , mo_a ) if ( dft ) call dft_initialize ( infos , basis , molGrid ) allocate ( wrk1 ( nbf , nbf ), pa ( nbf , nbf , 1 ), xm ( lexc ), xminv ( lexc ), source = 0.0_dp ) ! orbital-energy difference diagonal (e_a - e_i), occ-vir layout pxm ( 1 : nocc , 1 : nvir ) => xm ( 1 :) do i = 1 , nvir do j = 1 , nocc pxm ( j , i ) = mo_energy_a ( nocc + i ) - mo_energy_a ( j ) end do end do ! clamp near-degenerate occ-vir gaps so the diagonal preconditioner ! stays finite (same guard as the ROHF solver) xminv = 1.0_dp / sign ( max ( abs ( xm ), 1.0d-8 ), xm ) scale_exch = 1.0_dp if ( dft ) scale_exch = infos % dft % HFscale call int2_driver % init ( basis , infos ) call int2_driver % set_screening () int2_data = int2_td_data_t ( d2 = pa , & int_apb = . true ., int_amb = . false ., & tamm_dancoff = . false ., scale_exchange = scale_exch ) cgdata % infos => infos cgdata % int2_driver => int2_driver cgdata % int2_data => int2_data cgdata % molgrid => molgrid cgdata % wrk => wrk1 cgdata % mo => mo_a cgdata % pa => pa cgdata % xm => xm cgdata % xminv => xminv cgdata % nbf = nbf cgdata % nocc = nocc cgdata % dft = dft call system_clock ( count_rate = clock_rate ) call system_clock ( clock_start ) call cpu_time ( cpu_start ) write ( iw , '(/3x,60(\"-\"))' ) write ( iw , '(6x,\"CPHF/CPKS iterative solver\")' ) write ( iw , '(6x,\"right-hand sides =\",I5,3x,\"nocc =\",I5,3x,\"nvir =\",I5)' ) & nrhs , nocc , nvir write ( iw , '(6x,\"tolerance =\",1P,E10.3,3x,\"max iterations =\",I6)' ) cnv , mxit write ( iw , '(3x,60(\"-\"))' ) do irhs = 1 , nrhs call system_clock ( rhs_clock_start ) call cpu_time ( rhs_cpu_start ) call pcg % init ( b = bvec (:, irhs ), update = cphf_apbx , precond = cphf_precond , & dat = cgdata , tol = sqrt ( abs ( cnv ))) write ( iw , '(\" INITIAL CPHF ERROR RHS\",I5,\" =\",3X,' // & '1P,E10.3,1X,\"/\",1P,E10.3)' ) & irhs , pcg % error ** 2 , cnv do iter = 1 , mxit if ( pcg % errcode /= PCG_OK ) exit call pcg % step () write ( iw , '(\" CPHF ITER RHS\",I5,\" ITER#\",I4,\" ERROR =\",3X,' // & '1P,E10.3,1X,\"/\",1P,E10.3)' ) & irhs , iter , pcg % error ** 2 , cnv call flush ( iw ) end do call system_clock ( rhs_clock_stop ) call cpu_time ( rhs_cpu_stop ) rhs_wall = real ( rhs_clock_stop - rhs_clock_start , kind = dp ) / real ( clock_rate , kind = dp ) write ( iw , '(\" CPHF RHS\",I5,\" completed in\",I5,\" iterations;\",' // & '\" CPU time =\",F10.3,\" s; wall time =\",F10.3,\" s\")' ) & irhs , iter - 1 , rhs_cpu_stop - rhs_cpu_start , rhs_wall call flush ( iw ) uvec (:, irhs ) = pcg % x call pcg % clean () end do call system_clock ( clock_stop ) call cpu_time ( cpu_stop ) write ( iw , '(6x,\"CPHF wall time =\",F10.3,\" s; CPU time =\",F10.3,\" s\"/)' ) & real ( clock_stop - clock_start , kind = dp ) / real ( clock_rate , kind = dp ), cpu_stop - cpu_start call flush ( iw ) call int2_driver % clean () deallocate ( wrk1 , pa , xm , xminv ) end subroutine cphf_solve !############################################################################### !> @brief A-matrix action y = (A+B) x, mirroring tdhf_z_vector::compute_apbx. subroutine cphf_apbx ( y , x , dat ) use mathlib , only : symmetrize_matrix , orthogonal_transform use mod_dft_gridint_fxc , only : tddft_fxc real ( kind = dp ) :: x (:) real ( kind = dp ) :: y (:) type ( c_ptr ) :: dat type ( cphf_cg_data ), pointer :: p real ( kind = dp ), pointer :: apb (:,:,:) call c_f_pointer ( dat , p ) associate ( wrk => p % wrk , nocc => p % nocc , nbf => p % nbf , mo => p % mo , & pa => p % pa , int2_driver => p % int2_driver , int2_data => p % int2_data , & infos => p % infos , molgrid => p % molgrid , dft => p % dft , xm => p % xm ) call iatogen ( x , wrk , nocc , nocc ) call symmetrize_matrix ( wrk , nbf ) call orthogonal_transform ( 't' , nbf , mo , wrk , pa (:,:, 1 )) call int2_driver % run ( int2_data , & cam = dft . and . infos % dft % cam_flag , & alpha = infos % dft % cam_alpha , beta = infos % dft % cam_beta , mu = infos % dft % cam_mu ) select type ( int2_data ) type is ( int2_td_data_t ) apb => int2_data % apb (:,:,:, 1 ) end select apb = apb * 0.5_dp if ( dft ) then call tddft_fxc ( basis = infos % basis , molGrid = molGrid , isVecs = . true ., wf = mo , & fx = apb (:,:, 1 : 1 ), dx = pa (:,:, 1 : 1 ), nmtx = 1 , threshold = 0.0d0 , infos = infos ) end if call mntoia ( apb (:,:, 1 ), y , mo , mo , nocc , nocc ) y = y + xm * x end associate end subroutine cphf_apbx !############################################################################### subroutine cphf_precond ( y , x , dat ) real ( kind = dp ) :: x (:) real ( kind = dp ) :: y (:) type ( c_ptr ) :: dat type ( cphf_cg_data ), pointer :: p call c_f_pointer ( dat , p ) y = p % xminv * x end subroutine cphf_precond !############################################################################### subroutine cphf_polarizability_selftest_C ( c_handle ) bind ( C , name = \"cphf_polarizability_selftest\" ) use c_interop , only : oqp_handle_t , oqp_handle_get_info type ( oqp_handle_t ) :: c_handle type ( information ), pointer :: inf inf => oqp_handle_get_info ( c_handle ) call cphf_polarizability_selftest ( inf ) end subroutine cphf_polarizability_selftest_C subroutine cphf_static_polarizability_C ( c_handle , alpha ) bind ( C , name = \"cphf_static_polarizability\" ) use iso_c_binding , only : c_double use c_interop , only : oqp_handle_t , oqp_handle_get_info type ( oqp_handle_t ) :: c_handle real ( c_double ), intent ( out ) :: alpha ( 3 , 3 ) type ( information ), pointer :: inf inf => oqp_handle_get_info ( c_handle ) ! Dispatch on the SCF reference so every caller (in particular the ! vibrational Raman-activity path) gets the correct response kernel: ! 1 = RHF/RKS, 2 = UHF/UKS, 3 = ROHF/ROKS. select case ( inf % control % scftype ) case ( 2 ) call cphf_uhf_static_polarizability ( inf , alpha ) case ( 3 ) call cphf_rohf_static_polarizability ( inf , alpha ) case default call cphf_static_polarizability ( inf , alpha ) end select end subroutine cphf_static_polarizability_C !> @brief Compute native closed-shell static dipole polarizability. !>   For each Cartesian q, the perturbation is the dipole operator; the MO !>   occ-vir RHS is B&#94;q_{ia} = -<i|q|a> (in MO basis). Solving A U&#94;q = B&#94;q gives !>   the orbital response, and alpha_pq = -4 sum_{ia} mu&#94;p_{ia} U&#94;q_{ia}. subroutine cphf_static_polarizability ( infos , alpha ) use oqp_tagarray_driver , only : tagarray_get_data , OQP_VEC_MO_A use int1 , only : multipole_integrals use mathlib , only : unpack_matrix type ( information ), target , intent ( inout ) :: infos real ( kind = dp ), intent ( out ) :: alpha ( 3 , 3 ) type ( basis_set ), pointer :: basis real ( kind = dp ), contiguous , pointer :: mo_a (:,:) real ( kind = dp ), allocatable :: mints (:,:), dipfull (:,:), dip_mo (:,:) real ( kind = dp ), allocatable :: bvec (:,:), uvec (:,:), scr (:,:) real ( kind = dp ) :: origin ( 3 ) integer :: nbf , nbf2 , nocc , nvir , lexc , q , i , a , ia basis => infos % basis basis % atoms => infos % atoms nbf = basis % nbf nbf2 = nbf * ( nbf + 1 ) / 2 nocc = infos % mol_prop % nocc nvir = nbf - nocc lexc = nocc * nvir call tagarray_get_data ( infos % dat , OQP_VEC_MO_A , mo_a ) ! dipole integrals about the origin (first 3 of the multipole set: X,Y,Z) allocate ( mints ( nbf2 , 19 ), source = 0.0_dp ) origin = 0.0_dp call multipole_integrals ( basis , mints , origin , 3 ) allocate ( dipfull ( nbf , nbf ), dip_mo ( nbf , nbf ), scr ( nbf , nbf )) allocate ( bvec ( lexc , 3 ), uvec ( lexc , 3 ), source = 0.0_dp ) ! Build MO-basis dipole and the occ-vir RHS B&#94;q_{ia} = -mu&#94;q_{ia} do q = 1 , 3 call unpack_matrix ( mints (:, q ), dipfull ) ! MO transform: dip_mo = C&#94;T (dipfull) C call dgemm ( 't' , 'n' , nbf , nbf , nbf , 1.0_dp , mo_a , nbf , dipfull , nbf , 0.0_dp , scr , nbf ) call dgemm ( 'n' , 'n' , nbf , nbf , nbf , 1.0_dp , scr , nbf , mo_a , nbf , 0.0_dp , dip_mo , nbf ) ia = 0 do a = 1 , nvir do i = 1 , nocc ia = ia + 1 bvec ( ia , q ) = - dip_mo ( i , nocc + a ) end do end do end do call cphf_solve ( infos , 3 , bvec , uvec ) ! alpha_pq = -4 sum_ia mu&#94;p_ia U&#94;q_ia  (closed shell) alpha = 0.0_dp do q = 1 , 3 do i = 1 , 3 ! recompute mu&#94;p_ia from bvec (= -mu) : mu = -bvec alpha ( i , q ) = - 4.0_dp * sum ( ( - bvec (:, i )) * uvec (:, q ) ) end do end do deallocate ( mints , dipfull , dip_mo , scr , bvec , uvec ) end subroutine cphf_static_polarizability !> @brief Validate the CPHF solver via the reusable static dipole polarizability. !>   Writes the 3x3 tensor to /tmp/cphf_polar.out for comparison with a reference. subroutine cphf_polarizability_selftest ( infos ) type ( information ), target , intent ( inout ) :: infos real ( kind = dp ) :: alpha ( 3 , 3 ) integer :: i , u call cphf_static_polarizability ( infos , alpha ) open ( newunit = u , file = '/tmp/cphf_polar.out' , status = 'replace' , action = 'write' ) write ( u , '(a)' ) 'CPHF static dipole polarizability (a.u.):' do i = 1 , 3 write ( u , '(3f16.8)' ) alpha ( i , 1 : 3 ) end do write ( u , '(a,f16.8)' ) 'isotropic = ' , ( alpha ( 1 , 1 ) + alpha ( 2 , 2 ) + alpha ( 3 , 3 )) / 3.0_dp close ( u ) end subroutine cphf_polarizability_selftest !############################################################################### !  Open-shell (UHF) CPHF solver !############################################################################### !> @brief Solve the open-shell (UHF) CPHF equations  M U = B. !> !>   The unknown/RHS vectors are laid out as the concatenation of the alpha !>   occ-vir block (length la = nocca*nvira) followed by the beta occ-vir block !>   (length lb = noccb*nvirb), each in the iatogen/mntoia (occ-major) order. !> !>   The UHF orbital-Hessian action on a trial rotation U is !>       (M U)&#94;sigma_ia = (e&#94;sigma_a - e&#94;sigma_i) U&#94;sigma_ia !>                        + [ C&#94;sigma&#94;T  dF&#94;sigma  C&#94;sigma ]_ia , !>       dF&#94;sigma = J[dP&#94;alpha + dP&#94;beta] - c_x K[dP&#94;sigma]  (+ f_xc for KS), !>       dP&#94;sigma_mn = sum_ia ( C&#94;s_mi U&#94;s_ia C&#94;s_na + C&#94;s_ma U&#94;s_ia C&#94;s_ni ). !>   The Coulomb response is built from the spin-summed trial density and the !>   exchange response from the same-spin trial density, exactly the open-shell !>   two-electron Fock that scf_addons::fock_jk assembles for scftype>=2. !> !>   This is the genuine static CPHF operator (not the TDDFT A+B), so it serves !>   the open-shell analytic Hessian nuclear-perturbation response and the !>   open-shell static dipole polarizability on the same footing. subroutine cphf_solve_uhf ( infos , nrhs , bvec , uvec , tol , maxit ) use oqp_tagarray_driver , only : tagarray_get_data , & OQP_E_MO_A , OQP_VEC_MO_A , OQP_E_MO_B , OQP_VEC_MO_B use dft , only : dft_initialize real ( kind = dp ), parameter :: default_tol = 1.0d-9 type ( information ), target , intent ( inout ) :: infos integer , intent ( in ) :: nrhs real ( kind = dp ), intent ( in ) :: bvec (:,:) real ( kind = dp ), intent ( out ) :: uvec (:,:) real ( kind = dp ), intent ( in ), optional :: tol integer , intent ( in ), optional :: maxit type ( basis_set ), pointer :: basis type ( dft_grid_t ), target :: molgrid type ( cphf_cg_data_uhf ), target :: cgdata type ( pcg_t ) :: pcg real ( kind = dp ), contiguous , pointer :: moa (:,:), mob (:,:), epsa (:), epsb (:) real ( kind = dp ), allocatable , target :: wrka (:,:), wrkb (:,:), xm (:), xminv (:) real ( kind = dp ), pointer :: pxm (:,:) integer :: nbf , nocca , noccb , nvira , nvirb , la , lb , ltot integer :: i , j , irhs , iter , mxit , off logical :: dft real ( kind = dp ) :: cnv , scale_exch basis => infos % basis basis % atoms => infos % atoms nbf = basis % nbf nocca = infos % mol_prop % nelec_A noccb = infos % mol_prop % nelec_B nvira = nbf - nocca nvirb = nbf - noccb la = nocca * nvira lb = noccb * nvirb ltot = la + lb dft = infos % control % hamilton == 20 cnv = default_tol ; if ( present ( tol )) cnv = tol mxit = 100 ; if ( present ( maxit )) mxit = maxit if ( mxit < ltot + 5 ) mxit = ltot + 5 call tagarray_get_data ( infos % dat , OQP_E_MO_A , epsa ) call tagarray_get_data ( infos % dat , OQP_VEC_MO_A , moa ) call tagarray_get_data ( infos % dat , OQP_E_MO_B , epsb ) call tagarray_get_data ( infos % dat , OQP_VEC_MO_B , mob ) if ( dft ) call dft_initialize ( infos , basis , molGrid ) allocate ( wrka ( nbf , nbf ), wrkb ( nbf , nbf ), xm ( ltot ), xminv ( ltot ), source = 0.0_dp ) ! orbital-energy difference diagonal (e_a - e_i), occ-vir (occ-major) layout if ( la > 0 ) then pxm ( 1 : nocca , 1 : nvira ) => xm ( 1 : la ) do i = 1 , nvira do j = 1 , nocca pxm ( j , i ) = epsa ( nocca + i ) - epsa ( j ) end do end do end if if ( lb > 0 ) then pxm ( 1 : noccb , 1 : nvirb ) => xm ( la + 1 : ltot ) do i = 1 , nvirb do j = 1 , noccb pxm ( j , i ) = epsb ( noccb + i ) - epsb ( j ) end do end do end if ! clamp near-degenerate occ-vir gaps so the diagonal preconditioner ! stays finite (same guard as the ROHF solver) xminv = 1.0_dp / sign ( max ( abs ( xm ), 1.0d-8 ), xm ) scale_exch = 1.0_dp if ( dft ) scale_exch = infos % dft % HFscale cgdata % infos => infos cgdata % basis => basis cgdata % molgrid => molgrid cgdata % moa => moa cgdata % mob => mob cgdata % xm => xm cgdata % xminv => xminv cgdata % wrka => wrka cgdata % wrkb => wrkb cgdata % nbf = nbf cgdata % nocca = nocca cgdata % noccb = noccb cgdata % la = la cgdata % lb = lb cgdata % scale_exch = scale_exch cgdata % dft = dft write ( iw , '(/3x,60(\"-\"))' ) write ( iw , '(6x,\"open-shell (UHF) CPHF iterative solver\")' ) write ( iw , '(6x,\"right-hand sides =\",I5,3x,\"la =\",I6,3x,\"lb =\",I6)' ) nrhs , la , lb write ( iw , '(6x,\"tolerance =\",1P,E10.3,3x,\"max iterations =\",I6)' ) cnv , mxit write ( iw , '(3x,60(\"-\"))' ) off = 0 do irhs = 1 , nrhs call pcg % init ( b = bvec (:, irhs ), update = cphf_apbx_uhf , precond = cphf_precond_uhf , & dat = cgdata , tol = sqrt ( abs ( cnv ))) do iter = 1 , mxit if ( pcg % errcode /= PCG_OK ) exit call pcg % step () end do write ( iw , '(\" UHF CPHF RHS\",I5,\" completed in\",I5,\" iterations; error =\",1P,E10.3)' ) & irhs , iter - 1 , pcg % error ** 2 call flush ( iw ) uvec (:, irhs ) = pcg % x call pcg % clean () end do deallocate ( wrka , wrkb , xm , xminv ) end subroutine cphf_solve_uhf !############################################################################### !> @brief Open-shell (UHF) A-matrix action  y = M x  (see cphf_solve_uhf). subroutine cphf_apbx_uhf ( y , x , dat ) use mathlib , only : symmetrize_matrix , orthogonal_transform , pack_matrix , unpack_matrix use mod_dft_gridint_fxc , only : utddft_fxc use scf_addons , only : fock_jk real ( kind = dp ) :: x (:) real ( kind = dp ) :: y (:) type ( c_ptr ) :: dat type ( cphf_cg_data_uhf ), pointer :: p real ( kind = dp ), allocatable :: pa_ao (:,:), pb_ao (:,:), dpack (:,:), fpack (:,:) real ( kind = dp ), allocatable :: ga (:,:,:), gb (:,:,:), dxa (:,:,:), dxb (:,:,:) integer :: nbf , nbf2 , nocca , noccb , la , lb call c_f_pointer ( dat , p ) nbf = p % nbf ; nbf2 = nbf * ( nbf + 1 ) / 2 nocca = p % nocca ; noccb = p % noccb ; la = p % la ; lb = p % lb allocate ( pa_ao ( nbf , nbf ), pb_ao ( nbf , nbf ), source = 0.0_dp ) allocate ( ga ( nbf , nbf , 1 ), gb ( nbf , nbf , 1 ), source = 0.0_dp ) allocate ( dpack ( nbf2 , 2 ), fpack ( nbf2 , 2 ), source = 0.0_dp ) ! Trial AO densities from the occ-vir rotation amplitudes (per spin). if ( la > 0 ) then call iatogen ( x ( 1 : la ), p % wrka , nocca , nocca ) call symmetrize_matrix ( p % wrka , nbf ) call orthogonal_transform ( 't' , nbf , p % moa , p % wrka , pa_ao ) end if if ( lb > 0 ) then call iatogen ( x ( la + 1 : la + lb ), p % wrkb , noccb , noccb ) call symmetrize_matrix ( p % wrkb , nbf ) call orthogonal_transform ( 't' , nbf , p % mob , p % wrkb , pb_ao ) end if call pack_matrix ( pa_ao , dpack (:, 1 )) call pack_matrix ( pb_ao , dpack (:, 2 )) ! Open-shell two-electron response Fock: dF&#94;s = J[dPa+dPb] - cx K[dP&#94;s]. call fock_jk ( p % basis , d = dpack , f = fpack , scale_exch = p % scale_exch , infos = p % infos ) call unpack_matrix ( fpack (:, 1 ), ga (:,:, 1 )) call unpack_matrix ( fpack (:, 2 ), gb (:,:, 1 )) ! XC response kernel (UKS): spin-resolved f_xc on the trial spin densities. if ( p % dft ) then allocate ( dxa ( nbf , nbf , 1 ), dxb ( nbf , nbf , 1 )) dxa (:,:, 1 ) = pa_ao ; dxb (:,:, 1 ) = pb_ao call utddft_fxc ( basis = p % infos % basis , molGrid = p % molgrid , isVecs = . true ., & wfa = p % moa , wfb = p % mob , fxa = ga , fxb = gb , dxa = dxa , dxb = dxb , & nmtx = 1 , threshold = 0.0d0 , infos = p % infos ) deallocate ( dxa , dxb ) end if ! Project back to MO occ-vir and add the orbital-energy diagonal. if ( la > 0 ) call mntoia ( ga (:,:, 1 ), y ( 1 : la ), p % moa , p % moa , nocca , nocca ) if ( lb > 0 ) call mntoia ( gb (:,:, 1 ), y ( la + 1 : la + lb ), p % mob , p % mob , noccb , noccb ) y = y + p % xm * x deallocate ( pa_ao , pb_ao , ga , gb , dpack , fpack ) end subroutine cphf_apbx_uhf !############################################################################### subroutine cphf_precond_uhf ( y , x , dat ) real ( kind = dp ) :: x (:) real ( kind = dp ) :: y (:) type ( c_ptr ) :: dat type ( cphf_cg_data_uhf ), pointer :: p call c_f_pointer ( dat , p ) y = p % xminv * x end subroutine cphf_precond_uhf !############################################################################### subroutine cphf_uhf_polarizability_selftest_C ( c_handle ) bind ( C , name = \"cphf_uhf_polarizability_selftest\" ) use c_interop , only : oqp_handle_t , oqp_handle_get_info type ( oqp_handle_t ) :: c_handle type ( information ), pointer :: inf inf => oqp_handle_get_info ( c_handle ) call cphf_uhf_polarizability_selftest ( inf ) end subroutine cphf_uhf_polarizability_selftest_C !> @brief Compute the native open-shell (UHF) static dipole polarizability. !>   Built per spin: B&#94;sigma_ia = -<i|q|a>&#94;sigma, solve !>   M U&#94;q = B&#94;q, and alpha_pq = -2 sum_sigma sum_ia mu&#94;p,sigma_ia U&#94;q,sigma_ia. !>   For a closed-shell system run as UHF (multiplicity 1) the tensor must equal !>   the closed-shell (RHF) cphf_static_polarizability, which is the unambiguous !>   correctness check for the spin coupling and normalization. subroutine cphf_uhf_static_polarizability ( infos , alpha ) use oqp_tagarray_driver , only : tagarray_get_data , OQP_VEC_MO_A , OQP_VEC_MO_B use int1 , only : multipole_integrals use mathlib , only : unpack_matrix type ( information ), target , intent ( inout ) :: infos real ( kind = dp ), intent ( out ) :: alpha ( 3 , 3 ) type ( basis_set ), pointer :: basis real ( kind = dp ), contiguous , pointer :: moa (:,:), mob (:,:) real ( kind = dp ), allocatable :: mints (:,:), dipfull (:,:), dmo (:,:), scr (:,:) real ( kind = dp ), allocatable :: bvec (:,:), uvec (:,:), mua (:,:), mub (:,:) real ( kind = dp ) :: origin ( 3 ) integer :: nbf , nbf2 , nocca , noccb , nvira , nvirb , la , lb , ltot integer :: q , i , a , ia , pq basis => infos % basis basis % atoms => infos % atoms nbf = basis % nbf nbf2 = nbf * ( nbf + 1 ) / 2 nocca = infos % mol_prop % nelec_A noccb = infos % mol_prop % nelec_B nvira = nbf - nocca nvirb = nbf - noccb la = nocca * nvira lb = noccb * nvirb ltot = la + lb call tagarray_get_data ( infos % dat , OQP_VEC_MO_A , moa ) call tagarray_get_data ( infos % dat , OQP_VEC_MO_B , mob ) allocate ( mints ( nbf2 , 19 ), source = 0.0_dp ) origin = 0.0_dp call multipole_integrals ( basis , mints , origin , 3 ) allocate ( dipfull ( nbf , nbf ), dmo ( nbf , nbf ), scr ( nbf , nbf )) allocate ( bvec ( ltot , 3 ), uvec ( ltot , 3 ), source = 0.0_dp ) allocate ( mua ( la , 3 ), mub ( lb , 3 ), source = 0.0_dp ) do q = 1 , 3 call unpack_matrix ( mints (:, q ), dipfull ) ! alpha MO dipole and RHS call dgemm ( 't' , 'n' , nbf , nbf , nbf , 1.0_dp , moa , nbf , dipfull , nbf , 0.0_dp , scr , nbf ) call dgemm ( 'n' , 'n' , nbf , nbf , nbf , 1.0_dp , scr , nbf , moa , nbf , 0.0_dp , dmo , nbf ) ia = 0 do a = 1 , nvira do i = 1 , nocca ia = ia + 1 mua ( ia , q ) = dmo ( i , nocca + a ) bvec ( ia , q ) = - dmo ( i , nocca + a ) end do end do ! beta MO dipole and RHS call dgemm ( 't' , 'n' , nbf , nbf , nbf , 1.0_dp , mob , nbf , dipfull , nbf , 0.0_dp , scr , nbf ) call dgemm ( 'n' , 'n' , nbf , nbf , nbf , 1.0_dp , scr , nbf , mob , nbf , 0.0_dp , dmo , nbf ) ia = 0 do a = 1 , nvirb do i = 1 , noccb ia = ia + 1 mub ( ia , q ) = dmo ( i , noccb + a ) bvec ( la + ia , q ) = - dmo ( i , noccb + a ) end do end do end do call cphf_solve_uhf ( infos , 3 , bvec , uvec ) alpha = 0.0_dp do q = 1 , 3 do pq = 1 , 3 alpha ( pq , q ) = - 2.0_dp * ( sum ( mua (:, pq ) * uvec ( 1 : la , q )) & + sum ( mub (:, pq ) * uvec ( la + 1 : ltot , q )) ) end do end do deallocate ( mints , dipfull , dmo , scr , bvec , uvec , mua , mub ) end subroutine cphf_uhf_static_polarizability !> @brief Validate the open-shell (UHF) CPHF solver via the static dipole !>   polarizability.  Written to /tmp/cphf_uhf_polar.out. subroutine cphf_uhf_polarizability_selftest ( infos ) type ( information ), target , intent ( inout ) :: infos real ( kind = dp ) :: alpha ( 3 , 3 ) integer :: i , uu call cphf_uhf_static_polarizability ( infos , alpha ) open ( newunit = uu , file = '/tmp/cphf_uhf_polar.out' , status = 'replace' , action = 'write' ) write ( uu , '(a)' ) 'open-shell (UHF) CPHF static dipole polarizability (a.u.):' do i = 1 , 3 write ( uu , '(3f16.8)' ) alpha ( i , 1 : 3 ) end do write ( uu , '(a,f16.8)' ) 'isotropic = ' , ( alpha ( 1 , 1 ) + alpha ( 2 , 2 ) + alpha ( 3 , 3 )) / 3.0_dp close ( uu ) end subroutine cphf_uhf_polarizability_selftest !############################################################################### !  Open-shell (ROHF) CPHF solver !############################################################################### !> @brief Pack ROHF alpha/beta vir-occ rotation matrices into a single vector. !>   Layout (nocc_a >= nocc_b, offset = nocc_a - nocc_b = n_socc): !>     block 1 (socc-docc): xb(1:offset, 1:noccb) !>     block 2 (virt-docc): xa(1:nvira, 1:noccb) + xb(offset+1:, 1:noccb) !>     block 3 (virt-socc): xa(1:nvira, noccb+1:nocca) !>   Mirrors scf_converger::pack_rohf_trial. subroutine rohf_pack_trial ( x , xa , xb , nbf , nocca , noccb ) real ( kind = dp ), intent ( out ) :: x (:) real ( kind = dp ), intent ( in ) :: xa (:,:), xb (:,:) integer , intent ( in ) :: nbf , nocca , noccb integer :: nvira , offset , k , iv , a nvira = nbf - nocca offset = nocca - noccb x = 0.0_dp k = 0 if ( offset > 0 ) then do iv = 1 , offset do a = 1 , noccb k = k + 1 ; x ( k ) = xb ( iv , a ) end do end do end if do iv = 1 , nvira do a = 1 , noccb k = k + 1 ; x ( k ) = xa ( iv , a ) + xb ( offset + iv , a ) end do end do if ( offset > 0 ) then do iv = 1 , nvira do a = 1 , offset k = k + 1 ; x ( k ) = xa ( iv , noccb + a ) end do end do end if end subroutine rohf_pack_trial !> @brief Inverse of rohf_pack_trial (scf_converger::unpack_rohf_trial). subroutine rohf_unpack_trial ( x , xa , xb , nbf , nocca , noccb ) real ( kind = dp ), intent ( in ) :: x (:) real ( kind = dp ), intent ( out ) :: xa (:,:), xb (:,:) integer , intent ( in ) :: nbf , nocca , noccb integer :: nvira , offset , k , iv , a nvira = nbf - nocca offset = nocca - noccb xa = 0.0_dp ; xb = 0.0_dp k = 0 if ( offset > 0 ) then do iv = 1 , offset do a = 1 , noccb k = k + 1 ; xb ( iv , a ) = x ( k ) end do end do end if do iv = 1 , nvira do a = 1 , noccb k = k + 1 xa ( iv , a ) = x ( k ) xb ( offset + iv , a ) = x ( k ) end do end do if ( offset > 0 ) then do iv = 1 , nvira do a = 1 , offset k = k + 1 ; xa ( iv , noccb + a ) = x ( k ) end do end do end if end subroutine rohf_unpack_trial !> @brief Solve the open-shell (ROHF) CPHF equations  H theta = B  over the !>   docc/socc/virt rotation space (layout: rohf_pack_trial).  The orbital !>   Hessian action replicates the validated TRAH ROHF operator !>   (scf_converger::calc_h_op): per spin the orbital-energy-difference part !>   Fvv x - x Foo (full MO Fock blocks, so non-canonical orbitals are handled) !>   plus the response Fock from the trial rotation density (get_response_packed, !>   scftype>=2 -> Coulomb from the spin-summed density, exchange same-spin). subroutine cphf_solve_rohf ( infos , nrhs , bvec , uvec , tol , maxit ) use oqp_tagarray_driver , only : tagarray_get_data , & OQP_VEC_MO_A , OQP_FOCK_A , OQP_FOCK_B use mathlib , only : unpack_matrix use dft , only : dft_initialize real ( kind = dp ), parameter :: default_tol = 1.0d-9 type ( information ), target , intent ( inout ) :: infos integer , intent ( in ) :: nrhs real ( kind = dp ), intent ( in ) :: bvec (:,:) real ( kind = dp ), intent ( out ) :: uvec (:,:) real ( kind = dp ), intent ( in ), optional :: tol integer , intent ( in ), optional :: maxit type ( basis_set ), pointer :: basis type ( dft_grid_t ), target :: molgrid type ( cphf_cg_data_rohf ), target :: cgdata type ( pcg_t ) :: pcg real ( kind = dp ), contiguous , pointer :: mo (:,:), focka (:), fockb (:) real ( kind = dp ), allocatable , target :: famo (:,:), fbmo (:,:) real ( kind = dp ), allocatable , target :: xminv (:) real ( kind = dp ), allocatable :: fao (:,:), w2 (:,:), w3 (:,:) integer :: nbf , nocca , noccb , nvira , nvirb , offset , ltot integer :: i , a , k , irhs , iter , mxit logical :: dft real ( kind = dp ) :: cnv , scale_exch , d basis => infos % basis basis % atoms => infos % atoms nbf = basis % nbf nocca = infos % mol_prop % nelec_A noccb = infos % mol_prop % nelec_B nvira = nbf - nocca nvirb = nbf - noccb offset = nocca - noccb ltot = noccb * ( offset + nvira ) + offset * nvira dft = infos % control % hamilton == 20 cnv = default_tol ; if ( present ( tol )) cnv = tol mxit = 100 ; if ( present ( maxit )) mxit = maxit if ( mxit < ltot + 5 ) mxit = ltot + 5 call tagarray_get_data ( infos % dat , OQP_VEC_MO_A , mo ) call tagarray_get_data ( infos % dat , OQP_FOCK_A , focka ) call tagarray_get_data ( infos % dat , OQP_FOCK_B , fockb ) if ( dft ) call dft_initialize ( infos , basis , molGrid ) ! converged spin Fock matrices in the MO basis (FULL matrices; the operator ! needs the off-diagonal vir-occ blocks for the non-canonical commutator) allocate ( famo ( nbf , nbf ), fbmo ( nbf , nbf )) allocate ( fao ( nbf , nbf ), w2 ( nbf , nbf ), w3 ( nbf , nbf )) call unpack_matrix ( focka , fao ) call dgemm ( 'n' , 'n' , nbf , nbf , nbf , 1.0_dp , fao , nbf , mo , nbf , 0.0_dp , w2 , nbf ) call dgemm ( 't' , 'n' , nbf , nbf , nbf , 1.0_dp , mo , nbf , w2 , nbf , 0.0_dp , famo , nbf ) call unpack_matrix ( fockb , fao ) call dgemm ( 'n' , 'n' , nbf , nbf , nbf , 1.0_dp , fao , nbf , mo , nbf , 0.0_dp , w2 , nbf ) call dgemm ( 't' , 'n' , nbf , nbf , nbf , 1.0_dp , mo , nbf , w2 , nbf , 0.0_dp , fbmo , nbf ) ! diagonal preconditioner (orbital-energy-difference gaps from the Fock diag) allocate ( xminv ( ltot )) k = 0 if ( offset > 0 ) then do i = 1 , offset ! socc-docc (beta gap) do a = 1 , noccb k = k + 1 ; d = fbmo ( noccb + i , noccb + i ) - fbmo ( a , a ) xminv ( k ) = 1.0_dp / sign ( max ( abs ( d ), 1.0d-8 ), d ) end do end do end if do i = 1 , nvira ! virt-docc (alpha + beta share) do a = 1 , noccb k = k + 1 d = ( famo ( nocca + i , nocca + i ) - famo ( a , a )) + ( fbmo ( noccb + offset + i , noccb + offset + i ) - fbmo ( a , a )) xminv ( k ) = 1.0_dp / sign ( max ( abs ( d ), 1.0d-8 ), d ) end do end do if ( offset > 0 ) then do i = 1 , nvira ! virt-socc (alpha gap) do a = 1 , offset k = k + 1 ; d = famo ( nocca + i , nocca + i ) - famo ( noccb + a , noccb + a ) xminv ( k ) = 1.0_dp / sign ( max ( abs ( d ), 1.0d-8 ), d ) end do end do end if scale_exch = 1.0_dp if ( dft ) scale_exch = infos % dft % HFscale cgdata % infos => infos cgdata % basis => basis cgdata % molgrid => molgrid cgdata % mo => mo cgdata % famo => famo ; cgdata % fbmo => fbmo cgdata % xminv => xminv cgdata % nbf = nbf cgdata % nocca = nocca ; cgdata % noccb = noccb cgdata % nvira = nvira ; cgdata % nvirb = nvirb cgdata % offset = offset ; cgdata % ltot = ltot cgdata % scale_exch = scale_exch cgdata % dft = dft write ( iw , '(/3x,60(\"-\"))' ) write ( iw , '(6x,\"open-shell (ROHF) CPHF iterative solver\")' ) write ( iw , '(6x,\"right-hand sides =\",I5,3x,\"rotation dim =\",I6)' ) nrhs , ltot write ( iw , '(6x,\"tolerance =\",1P,E10.3,3x,\"max iterations =\",I6)' ) cnv , mxit write ( iw , '(3x,60(\"-\"))' ) do irhs = 1 , nrhs call pcg % init ( b = bvec (:, irhs ), update = cphf_apbx_rohf , precond = cphf_precond_rohf , & dat = cgdata , tol = sqrt ( abs ( cnv ))) do iter = 1 , mxit if ( pcg % errcode /= PCG_OK ) exit call pcg % step () end do write ( iw , '(\" ROHF CPHF RHS\",I5,\" completed in\",I5,\" iterations; error =\",1P,E10.3)' ) & irhs , iter - 1 , pcg % error ** 2 call flush ( iw ) uvec (:, irhs ) = pcg % x call pcg % clean () end do deallocate ( famo , fbmo , xminv , fao , w2 , w3 ) end subroutine cphf_solve_rohf !############################################################################### !> @brief ROHF orbital-Hessian action y = H x (see cphf_solve_rohf). subroutine cphf_apbx_rohf ( y , x , dat ) use mathlib , only : pack_matrix , unpack_matrix use scf_addons , only : get_response_packed real ( kind = dp ) :: x (:) real ( kind = dp ) :: y (:) type ( c_ptr ) :: dat type ( cphf_cg_data_rohf ), pointer :: p real ( kind = dp ), allocatable :: xa (:,:), xb (:,:), x2a (:,:), x2b (:,:) real ( kind = dp ), allocatable :: work2 (:,:), work3 (:,:), dm (:,:), v (:,:) real ( kind = dp ), allocatable :: dm_tri (:,:), pfock (:,:), kmat (:,:), ck (:,:) integer :: nbf , nbf2 , nocca , noccb , nvira , nvirb , offset , i , j , a , s call c_f_pointer ( dat , p ) nbf = p % nbf ; nbf2 = nbf * ( nbf + 1 ) / 2 nocca = p % nocca ; noccb = p % noccb ; nvira = p % nvira ; nvirb = p % nvirb offset = p % offset allocate ( xa ( nvira , nocca ), xb ( nvirb , noccb ), x2a ( nvira , nocca ), x2b ( nvirb , noccb )) allocate ( work2 ( nbf , nbf ), work3 ( nbf , nbf ), dm ( nbf , nbf ), v ( nbf , nbf )) allocate ( kmat ( nbf , nbf ), ck ( nbf , nbf )) allocate ( dm_tri ( nbf2 , 2 ), pfock ( nbf2 , 2 ), source = 0.0_dp ) call rohf_unpack_trial ( x , xa , xb , nbf , nocca , noccb ) ! Fock-transform part: exact commutator [F&#94;s_MO, K]_vo per spin, where K is the ! antisymmetric MO rotation (vir-occ_alpha from xa; socc-docc occ-occ from xb). ! This reduces to Fvv x - x Foo only for canonical orbitals (F_MO vir-occ = 0); ! for ROHF the raw vir-occ Fock blocks are nonzero and their coupling to the ! socc rotations is the term the canonical form drops. kmat = 0.0_dp do i = 1 , nocca do a = 1 , nvira kmat ( nocca + a , i ) = xa ( a , i ) kmat ( i , nocca + a ) = - xa ( a , i ) end do end do do j = 1 , noccb do s = 1 , offset kmat ( noccb + s , j ) = kmat ( noccb + s , j ) + xb ( s , j ) kmat ( j , noccb + s ) = kmat ( j , noccb + s ) - xb ( s , j ) end do end do call dgemm ( 'n' , 'n' , nbf , nbf , nbf , 1.0_dp , p % famo , nbf , kmat , nbf , 0.0_dp , ck , nbf ) call dgemm ( 'n' , 'n' , nbf , nbf , nbf , - 1.0_dp , kmat , nbf , p % famo , nbf , 1.0_dp , ck , nbf ) x2a = ck ( nocca + 1 : nbf , 1 : nocca ) call dgemm ( 'n' , 'n' , nbf , nbf , nbf , 1.0_dp , p % fbmo , nbf , kmat , nbf , 0.0_dp , ck , nbf ) call dgemm ( 'n' , 'n' , nbf , nbf , nbf , - 1.0_dp , kmat , nbf , p % fbmo , nbf , 1.0_dp , ck , nbf ) x2b = ck ( noccb + 1 : nbf , 1 : noccb ) ! orbital-rotation density (alpha):  dm = Cv xa Co&#94;T + (Cv xa Co&#94;T)&#94;T work2 = 0.0_dp call dgemm ( 'n' , 'n' , nbf , nocca , nvira , 1.0_dp , p % mo (:, nocca + 1 : nbf ), nbf , xa , nvira , 0.0_dp , work2 , nbf ) call dgemm ( 'n' , 't' , nbf , nbf , nocca , 1.0_dp , work2 , nbf , p % mo (:, 1 : nocca ), nbf , 0.0_dp , work3 , nbf ) do i = 1 , nbf do j = 1 , nbf dm ( i , j ) = work3 ( i , j ) + work3 ( j , i ) end do end do call pack_matrix ( dm , dm_tri (:, 1 )) ! beta work2 = 0.0_dp call dgemm ( 'n' , 'n' , nbf , noccb , nvirb , 1.0_dp , p % mo (:, noccb + 1 : nbf ), nbf , xb , nvirb , 0.0_dp , work2 , nbf ) call dgemm ( 'n' , 't' , nbf , nbf , noccb , 1.0_dp , work2 , nbf , p % mo (:, 1 : noccb ), nbf , 0.0_dp , work3 , nbf ) do i = 1 , nbf do j = 1 , nbf dm ( i , j ) = work3 ( i , j ) + work3 ( j , i ) end do end do call pack_matrix ( dm , dm_tri (:, 2 )) ! response Fock from the trial density (open-shell: J[dPa+dPb] - cx K[dP&#94;s]) call get_response_packed ( p % basis , p % infos , p % molgrid , p % mo , dm_tri , pfock , p % mo ) ! add the MO vir-occ block of the response Fock (alpha) call unpack_matrix ( pfock (:, 1 ), v ) call dgemm ( 't' , 'n' , nbf , nbf , nbf , 1.0_dp , p % mo , nbf , v , nbf , 0.0_dp , work2 , nbf ) call dgemm ( 'n' , 'n' , nbf , nbf , nbf , 1.0_dp , work2 , nbf , p % mo , nbf , 0.0_dp , work3 , nbf ) x2a = x2a + work3 ( nocca + 1 : nbf , 1 : nocca ) ! beta call unpack_matrix ( pfock (:, 2 ), v ) call dgemm ( 't' , 'n' , nbf , nbf , nbf , 1.0_dp , p % mo , nbf , v , nbf , 0.0_dp , work2 , nbf ) call dgemm ( 'n' , 'n' , nbf , nbf , nbf , 1.0_dp , work2 , nbf , p % mo , nbf , 0.0_dp , work3 , nbf ) x2b = x2b + work3 ( noccb + 1 : nbf , 1 : noccb ) call rohf_pack_trial ( y , x2a , x2b , nbf , nocca , noccb ) deallocate ( xa , xb , x2a , x2b , work2 , work3 , dm , v , dm_tri , pfock , kmat , ck ) end subroutine cphf_apbx_rohf !############################################################################### subroutine cphf_precond_rohf ( y , x , dat ) real ( kind = dp ) :: x (:) real ( kind = dp ) :: y (:) type ( c_ptr ) :: dat type ( cphf_cg_data_rohf ), pointer :: p call c_f_pointer ( dat , p ) y = p % xminv * x end subroutine cphf_precond_rohf !############################################################################### subroutine cphf_rohf_polarizability_selftest_C ( c_handle ) bind ( C , name = \"cphf_rohf_polarizability_selftest\" ) use c_interop , only : oqp_handle_t , oqp_handle_get_info type ( oqp_handle_t ) :: c_handle type ( information ), pointer :: inf inf => oqp_handle_get_info ( c_handle ) call cphf_rohf_polarizability_selftest ( inf ) end subroutine cphf_rohf_polarizability_selftest_C !> @brief Compute the native ROHF static dipole polarizability. !>   For a closed-shell molecule run as ROHF (multiplicity 1, offset=0) the !>   rotation space reduces to the virt-docc block and the ROHF orbital Hessian !>   reduces to (twice) the RHF one; the resulting static polarizability must !>   equal the validated closed-shell cphf_static_polarizability.  This is the !>   unambiguous check for the solver plumbing, the operator and the packing. subroutine cphf_rohf_static_polarizability ( infos , alpha ) use oqp_tagarray_driver , only : tagarray_get_data , OQP_VEC_MO_A use int1 , only : multipole_integrals use mathlib , only : unpack_matrix type ( information ), target , intent ( inout ) :: infos real ( kind = dp ), intent ( out ) :: alpha ( 3 , 3 ) type ( basis_set ), pointer :: basis real ( kind = dp ), contiguous , pointer :: mo (:,:) real ( kind = dp ), allocatable :: mints (:,:), dipfull (:,:), dmo (:,:), scr (:,:) real ( kind = dp ), allocatable :: xa (:,:), xb (:,:), bvec (:,:), uvec (:,:) real ( kind = dp ) :: origin ( 3 ) integer :: nbf , nbf2 , nocca , noccb , nvira , nvirb , offset , ltot integer :: q , pq , i , a basis => infos % basis basis % atoms => infos % atoms nbf = basis % nbf nbf2 = nbf * ( nbf + 1 ) / 2 nocca = infos % mol_prop % nelec_A noccb = infos % mol_prop % nelec_B nvira = nbf - nocca nvirb = nbf - noccb offset = nocca - noccb ltot = noccb * ( offset + nvira ) + offset * nvira call tagarray_get_data ( infos % dat , OQP_VEC_MO_A , mo ) allocate ( mints ( nbf2 , 19 ), source = 0.0_dp ) origin = 0.0_dp call multipole_integrals ( basis , mints , origin , 3 ) allocate ( dipfull ( nbf , nbf ), dmo ( nbf , nbf ), scr ( nbf , nbf )) allocate ( xa ( nvira , nocca ), xb ( nvirb , noccb )) allocate ( bvec ( ltot , 3 ), uvec ( ltot , 3 ), source = 0.0_dp ) ! dipole RHS over the rotation space (single ROHF MO set; vir-occ blocks) do q = 1 , 3 call unpack_matrix ( mints (:, q ), dipfull ) call dgemm ( 't' , 'n' , nbf , nbf , nbf , 1.0_dp , mo , nbf , dipfull , nbf , 0.0_dp , scr , nbf ) call dgemm ( 'n' , 'n' , nbf , nbf , nbf , 1.0_dp , scr , nbf , mo , nbf , 0.0_dp , dmo , nbf ) do i = 1 , nocca do a = 1 , nvira xa ( a , i ) = - dmo ( nocca + a , i ) end do end do do i = 1 , noccb do a = 1 , nvirb xb ( a , i ) = - dmo ( noccb + a , i ) end do end do call rohf_pack_trial ( bvec (:, q ), xa , xb , nbf , nocca , noccb ) end do call cphf_solve_rohf ( infos , 3 , bvec , uvec ) ! alpha_pq = -2 sum over rotation space of mu&#94;p . theta&#94;q  (mu = -bvec) alpha = 0.0_dp do q = 1 , 3 do pq = 1 , 3 alpha ( pq , q ) = - 2.0_dp * sum ( ( - bvec (:, pq )) * uvec (:, q ) ) end do end do deallocate ( mints , dipfull , dmo , scr , xa , xb , bvec , uvec ) end subroutine cphf_rohf_static_polarizability !> @brief Validate the ROHF CPHF solver via the static dipole polarizability. !>   Written to /tmp/cphf_rohf_polar.out. subroutine cphf_rohf_polarizability_selftest ( infos ) type ( information ), target , intent ( inout ) :: infos real ( kind = dp ) :: alpha ( 3 , 3 ) integer :: i , uu call cphf_rohf_static_polarizability ( infos , alpha ) open ( newunit = uu , file = '/tmp/cphf_rohf_polar.out' , status = 'replace' , action = 'write' ) write ( uu , '(a)' ) 'open-shell (ROHF) CPHF static dipole polarizability (a.u.):' do i = 1 , 3 write ( uu , '(3f16.8)' ) alpha ( i , 1 : 3 ) end do write ( uu , '(a,f16.8)' ) 'isotropic = ' , ( alpha ( 1 , 1 ) + alpha ( 2 , 2 ) + alpha ( 3 , 3 )) / 3.0_dp close ( uu ) end subroutine cphf_rohf_polarizability_selftest end module cphf_mod","tags":"","url":"sourcefile/cphf.f90.html"},{"title":"soc_mrsf.F90 – OpenQP Fortran API","text":"Source Code module soc_mrsf_mod use precision , only : dp implicit none character ( len =* ), parameter :: module_name = \"soc_mrsf_mod\" private public soc_mrsf contains subroutine soc_mrsf_C ( c_handle ) bind ( C , name = \"soc_mrsf\" ) use c_interop , only : oqp_handle_t , oqp_handle_get_info use types , only : information type ( oqp_handle_t ) :: c_handle type ( information ), pointer :: inf inf => oqp_handle_get_info ( c_handle ) call soc_mrsf ( inf ) end subroutine soc_mrsf_C !> @brief Compute spin-orbit coupling corrections for MRSF-TDDFT states !> @details !>  Driver for the MRSF SOC calculation. Performs the following steps: !>    1. Compute 1e SOC AO integrals <mu|Z*L/r&#94;3|nu> via Breit-Pauli operator !>    2. Transform AO integrals to MO basis !>    3. Optionally add 2e mean-field SOC correction (controlled by infos%control%soc_2e) !>    4. Build spin-dependent transition density matrices from MRSF Davidson vectors !>    5. Assemble the SOC Hamiltonian in the (singlet + 3*triplet) basis !>    6. Diagonalize to obtain SOC-corrected adiabatic energies and eigenvectors !> !>  State ordering in the SOC basis follows the GAMESS convention: !>    indices 1..ns        -> singlet states S0..S(ns-1) !>    indices ns+1..ns+3nt -> triplet Ms sublevels T0(Ms=-1,0,+1), T1(...), ... !> !> @param[inout] infos  OQP information struct (basis, atoms, control, tagarray, log) subroutine soc_mrsf ( infos ) use io_constants , only : iw use types , only : information use oqp_tagarray_driver use precision , only : dp use printing , only : print_module_info use messages , only : show_message , with_abort use grd2_rys , only : soc2e_driver use mathlib , only : orthogonal_transform use parallel , only : par_env_t use physical_constants , only : alpha => FINE_STRUCTURE , & ha2wn => HA_TO_WAVENUM , & ha2ev => EV2HTREE implicit none character ( len =* ), parameter :: subroutine_name = \"soc_mrsf\" type ( information ), target , intent ( inout ) :: infos real ( kind = dp ), contiguous , pointer :: singlet_energies (:), triplet_energies (:) real ( kind = dp ), contiguous , pointer :: bvec_mo_s (:,:), bvec_mo_t (:,:), mo_a (:,:) real ( kind = dp ) :: e_ref integer :: ok , nbf , nbf2 real ( kind = dp ), allocatable :: lx_ao (:), ly_ao (:), lz_ao (:) real ( kind = dp ), allocatable :: lx_2e_ao (:), ly_2e_ao (:), lz_2e_ao (:) integer :: ns , nt , ist , jst , ims , ims_i , ims_j , itemp , i , idx , j real ( kind = dp ), allocatable :: lx_mo (:,:), ly_mo (:,:), lz_mo (:,:) real ( kind = dp ), allocatable :: t00aa (:,:,:,:), t110aa (:,:,:,:), t11ab (:,:,:,:) integer :: nocca , noccb complex ( kind = dp ), allocatable :: hsoc (:,:), h1soc (:,:), h2soc (:,:) real ( kind = dp ), allocatable :: eval (:) complex ( kind = dp ), allocatable :: evec (:,:) real ( kind = dp ), parameter :: dfac = alpha ** 2 / 2.0_dp * ha2wn ! 5.8438 cm-1/a.u. real ( kind = dp ) :: re1e , im1e , re2e , im2e , abs12e character ( len = 7 ), dimension ( 3 ), parameter :: trip = [ '(Ms=-1)' , '(Ms= 0)' , '(Ms=+1)' ] real ( kind = dp ), allocatable :: den_rohf (:,:) real ( kind = dp ), allocatable :: wao (:,:,:) real ( kind = dp ), allocatable :: lx_2e_mo (:,:), ly_2e_mo (:,:), lz_2e_mo (:,:) real ( kind = dp ), allocatable :: lx_12e_mo (:,:), ly_12e_mo (:,:), lz_12e_mo (:,:) logical :: do_2e_soc logical :: debug_soc_prints type ( par_env_t ) :: pe integer :: nstate_soc real ( kind = dp ), pointer :: eval_out (:) real ( kind = dp ), pointer :: evec_re_out (:,:), evec_im_out (:,:) real ( kind = dp ), pointer :: hsoc_re_out (:,:), hsoc_im_out (:,:) call pe % init ( infos % mpiinfo % comm , infos % mpiinfo % usempi ) debug_soc_prints = ( infos % control % verbose > 1 ) do_2e_soc = ( infos % control % soc_2e /= 0 ) ! The 2e SOC kernel (grd2_rys soc2e path) still scatters Cartesian ! component counts against spherical AO offsets: under ispher with pure ! shells it would silently corrupt memory. Abort until it is ported. block use constants , only : HARMONIC_ACTIVE if ( do_2e_soc . and . HARMONIC_ACTIVE ) then if ( any ( infos % basis % harmonic == 1 )) & call show_message ( 'soc_mrsf: 2e SOC is not yet available with ' // & 'spherical-harmonic AOs; set soc_2e=0 or ispher=false' , WITH_ABORT ) end if end block if ( pe % rank == 0 ) then open ( unit = iw , file = infos % log_filename , position = \"append\" ) if ( do_2e_soc ) then call print_module_info ( 'SOC_MRSF (1e+2e)' , 'Spin-Orbit Coupling: MRSF Energies' ) else call print_module_info ( 'SOC_MRSF (1e)' , 'Spin-Orbit Coupling: MRSF Energies' ) end if end if !    write(iw, *) 'Do we 2e?', infos%control%soc_2e e_ref = infos % mol_energy % energy call data_has_tags ( infos % dat , & ( / character ( len = 80 ) :: OQP_td_singlet_energies , OQP_td_triplet_energies / ), & module_name , subroutine_name , WITH_ABORT ) call tagarray_get_data ( infos % dat , OQP_td_singlet_energies , singlet_energies ) call tagarray_get_data ( infos % dat , OQP_td_triplet_energies , triplet_energies ) call tagarray_get_data ( infos % dat , OQP_td_bvec_mo_s , bvec_mo_s ) call tagarray_get_data ( infos % dat , OQP_td_bvec_mo_t , bvec_mo_t ) call tagarray_get_data ( infos % dat , OQP_VEC_MO_A , mo_a ) nbf = infos % basis % nbf nbf2 = nbf * ( nbf + 1 ) / 2 ns = size ( singlet_energies ) nt = size ( triplet_energies ) nstate_soc = ns + 3 * nt ! Number of alpha/beta occupied MOs, needed for TDM flat index mapping nocca = infos % mol_prop % nelec_a noccb = infos % mol_prop % nelec_b ! --- Step 1: Compute SOC 1e AO integrals <mu|Z*L/r&#94;3|nu> --- allocate ( lx_ao ( nbf2 ), ly_ao ( nbf2 ), lz_ao ( nbf2 ), stat = ok ) if ( ok /= 0 ) call show_message ( 'soc_mrsf: cannot allocate AO L matrices' , WITH_ABORT ) call compute_soc_ao ( infos , lx_ao , ly_ao , lz_ao ) ! --- Step 2: Transform AO integrals to MO basis: L_MO = C&#94;T * L_AO * C --- allocate ( lx_mo ( nbf , nbf ), ly_mo ( nbf , nbf ), lz_mo ( nbf , nbf ), stat = ok ) if ( ok /= 0 ) call show_message ( 'soc_mrsf: cannot allocate MO L matrices' , WITH_ABORT ) call ao2mo_soc ( lx_ao , lx_mo , mo_a , nbf ) call ao2mo_soc ( ly_ao , ly_mo , mo_a , nbf ) call ao2mo_soc ( lz_ao , lz_mo , mo_a , nbf ) allocate ( lx_12e_mo ( nbf , nbf ), ly_12e_mo ( nbf , nbf ), lz_12e_mo ( nbf , nbf ), stat = ok ) if ( ok /= 0 ) call show_message ( 'soc_mrsf: cannot allocate total MO L matrices' , WITH_ABORT ) ! --- Step 2b: compute SOC 2e AO integrals, AO2MO transformation --- if ( do_2e_soc ) then allocate ( den_rohf ( nbf , nbf ), stat = ok ) if ( ok /= 0 ) call show_message ( 'soc_mrsf: cannot allocate ROHF density' , WITH_ABORT ) allocate ( lx_2e_mo ( nbf , nbf ), ly_2e_mo ( nbf , nbf ), lz_2e_mo ( nbf , nbf ), stat = ok ) if ( ok /= 0 ) call show_message ( 'soc_mrsf: cannot allocate 2e MO L matrices' , WITH_ABORT ) den_rohf = 0.0_dp call dgemm ( 'N' , 'T' , nbf , nbf , noccb , 1.0_dp , & mo_a , nbf , mo_a , nbf , 0.0_dp , den_rohf , nbf ) allocate ( wao ( 3 , nbf , nbf ), stat = ok ) if ( ok /= 0 ) call show_message ( 'soc_mrsf: cannot allocate 2e AO L matrices' , WITH_ABORT ) wao = 0.0_dp if ( pe % rank == 0 . and . debug_soc_prints ) then do i = 1 , infos % basis % nshell write ( iw , '(a,3i4)' ) 'shell ao_offset am:' , i , & infos % basis % ao_offset ( i ), infos % basis % am ( i ) end do write ( iw , '(a,2i4)' ) ' nocca, noccb = ' , nocca , noccb end if call soc2e_driver ( infos , infos % basis , den_rohf , wao ) if ( pe % rank == 0 . and . debug_soc_prints ) then write ( iw , '(/,a)' ) ' LX in AO (our wao)' do i = 1 , nbf write ( iw , '(*(f12.6))' ) ( wao ( 1 , i , j ), j = 1 , i ) end do write ( iw , '(/,a)' ) ' LY in AO (our wao)' do i = 1 , nbf write ( iw , '(*(f12.6))' ) ( wao ( 2 , i , j ), j = 1 , i ) end do write ( iw , '(/,a)' ) ' LZ in AO (our wao)' do i = 1 , nbf write ( iw , '(*(f12.6))' ) ( wao ( 3 , i , j ), j = 1 , i ) end do write ( iw , '(/,a,3es14.6)' ) '  ||wao|| (Lx,Ly,Lz) = ' , & sqrt ( sum ( wao ( 1 ,:,:) ** 2 )), & sqrt ( sum ( wao ( 2 ,:,:) ** 2 )), & sqrt ( sum ( wao ( 3 ,:,:) ** 2 )) end if deallocate ( den_rohf ) call orthogonal_transform ( 'n' , nbf , mo_a , wao ( 1 ,:,:), lx_2e_mo ) call orthogonal_transform ( 'n' , nbf , mo_a , wao ( 2 ,:,:), ly_2e_mo ) call orthogonal_transform ( 'n' , nbf , mo_a , wao ( 3 ,:,:), lz_2e_mo ) deallocate ( wao ) lx_12e_mo = lx_mo + lx_2e_mo ly_12e_mo = ly_mo + ly_2e_mo lz_12e_mo = lz_mo + lz_2e_mo else lx_12e_mo = lx_mo ly_12e_mo = ly_mo lz_12e_mo = lz_mo end if deallocate ( lx_ao , ly_ao , lz_ao ) ! --- Step 3: Build spin-dependent transition density matrices --- allocate ( t00aa ( ns , nt , nbf , nbf ), & t110aa ( nt , nt , nbf , nbf ), & t11ab ( nt , nt , nbf , nbf ), stat = ok ) if ( ok /= 0 ) call show_message ( 'soc_mrsf: cannot allocate TDM arrays' , WITH_ABORT ) call compute_tdm ( bvec_mo_s , bvec_mo_t , nocca , noccb , nbf , ns , nt , & t00aa , t110aa , t11ab ) ! --- Step 4: Assemble the 1e SOC Hamiltonian H_SOC --- allocate ( hsoc ( ns + 3 * nt , ns + 3 * nt ), stat = ok ) allocate ( h1soc ( ns + 3 * nt , ns + 3 * nt ), stat = ok ) allocate ( h2soc ( ns + 3 * nt , ns + 3 * nt ), stat = ok ) if ( ok /= 0 ) call show_message ( 'soc_mrsf: cannot allocate H_SOC matrix' , WITH_ABORT ) h2soc = cmplx ( 0.0_dp , 0.0_dp , kind = dp ) call compute_soc_matrix ( t00aa , t110aa , t11ab , lx_mo , ly_mo , lz_mo , ns , nt , nbf , h1soc ) if ( do_2e_soc ) call compute_soc_matrix ( t00aa , t110aa , t11ab , lx_2e_mo , ly_2e_mo , lz_2e_mo , ns , nt , nbf , h2soc ) call compute_soc_matrix ( t00aa , t110aa , t11ab , lx_12e_mo , ly_12e_mo , lz_12e_mo , ns , nt , nbf , hsoc ) deallocate ( t00aa , t110aa , t11ab , lx_mo , ly_mo , lz_mo ) ! --- Step 5: Print SOC coupling constants, separated into 1e and 2e parts --- if ( pe % rank == 0 ) then write ( iw , '(/,11x,89(\"-\"))' ) write ( iw , '(41x,a)' ) 'Absolute = sqrt(Re(1e+2e)**2+Im(1e+2e)**2)' write ( iw , '(11x,89(\"-\"))' ) write ( iw , '(2x,a,4x,a,9x,a,6x,a,6x,a,6x,a,6x,a)' ) & 'State_i' , 'State_j' , 'Re(1e)' , 'Im(1e)' , 'Re(2e)' , 'Im(2e)' , 'Absolute' ! S-T block do ist = 1 , ns do jst = 1 , nt do ims = 1 , 3 ! Ms = -1, 0, +1 idx = ns + ( jst - 1 ) * 3 + ims re1e = real ( h1soc ( ist , idx )) * dfac im1e = aimag ( h1soc ( ist , idx )) * dfac re2e = real ( h2soc ( ist , idx )) * dfac im2e = aimag ( h2soc ( ist , idx )) * dfac abs12e = sqrt (( re1e + re2e ) ** 2 + ( im1e + im2e ) ** 2 ) write ( iw , '(5x,a,i0,4x,\"/\",x,a,i0,a,x,4f12.4,f18.12)' ) & 'S' , ist - 1 , 'T' , jst - 1 , trim ( trip ( ims )), re1e , im1e , re2e , im2e , abs12e end do end do end do ! T-T block do ist = 1 , nt do jst = 1 , nt do ims_i = 1 , 3 do ims_j = 1 , 3 i = ns + ( ist - 1 ) * 3 + ims_i j = ns + ( jst - 1 ) * 3 + ims_j re1e = real ( h1soc ( i , j )) * dfac im1e = aimag ( h1soc ( i , j )) * dfac re2e = real ( h2soc ( i , j )) * dfac im2e = aimag ( h2soc ( i , j )) * dfac abs12e = sqrt (( re1e + re2e ) ** 2 + ( im1e + im2e ) ** 2 ) write ( iw , '(5x,a,i0,a,4x,\"/\",x,a,i0,a,x,4f12.4,f18.12)' ) & 'T' , ist - 1 , trim ( trip ( ims_i )), 'T' , jst - 1 , trim ( trip ( ims_j )), & re1e , im1e , re2e , im2e , abs12e end do end do end do end do end if ! --- Step 6: Diagonalize H_SOC + excitation energies, print eigenvalues --- allocate ( eval ( ns + 3 * nt ), stat = ok ) if ( ok /= 0 ) call show_message ( 'soc_mrsf: cannot allocate eigenvalue array' , WITH_ABORT ) allocate ( evec ( ns + 3 * nt , ns + 3 * nt ), stat = ok ) if ( ok /= 0 ) call show_message ( 'soc_mrsf: cannot allocate eigenvector array' , WITH_ABORT ) call diag_soc ( hsoc , singlet_energies , triplet_energies , e_ref , ns , nt , eval , evec ) if ( pe % rank == 0 ) then call print_soc_eigenvalues ( iw , eval , evec , singlet_energies , triplet_energies , e_ref , ns , nt ) call print_soc_decomposition ( iw , eval , evec , ns , nt ) call infos % dat % alloc_or_die ( OQP_soc_eval , ( / nstate_soc / ), eval_out , description = OQP_soc_eval_comment ) call infos % dat % alloc_or_die ( OQP_soc_evec_re , ( / nstate_soc , nstate_soc / ), evec_re_out , description = OQP_soc_evec_re_comment ) call infos % dat % alloc_or_die ( OQP_soc_evec_im , ( / nstate_soc , nstate_soc / ), evec_im_out , description = OQP_soc_evec_im_comment ) call infos % dat % alloc_or_die ( OQP_soc_hsoc_re , ( / nstate_soc , nstate_soc / ), hsoc_re_out , description = OQP_soc_hsoc_re_comment ) call infos % dat % alloc_or_die ( OQP_soc_hsoc_im , ( / nstate_soc , nstate_soc / ), hsoc_im_out , description = OQP_soc_hsoc_im_comment ) eval_out = eval evec_re_out = real ( evec , kind = dp ) evec_im_out = aimag ( evec ) hsoc_re_out = real ( hsoc , kind = dp ) hsoc_im_out = aimag ( hsoc ) write ( iw , '(/,a)' ) 'SOC_MRSF done' call flush ( iw ) close ( iw ) end if deallocate ( eval , evec ) deallocate ( lx_12e_mo , ly_12e_mo , lz_12e_mo ) deallocate ( hsoc ) if ( do_2e_soc ) then deallocate ( lx_2e_mo , ly_2e_mo , lz_2e_mo ) end if end subroutine soc_mrsf !> @brief Compute 1-electron SOC AO integrals using the Breit-Pauli operator !> @details !>  Evaluates <mu|Z_A * L_A / r_A&#94;3|nu> for each atom A, where L_A is the !>  angular momentum operator relative to nucleus A and Z_A is the (effective) !>  nuclear charge. Loops over shell pairs (ii >= jj) and accumulates into !>  packed lower-triangular arrays. Results are normalised with basis function norms. !> !>  Note: uses bare nuclear charges (ze = Z). !> @param[inout] infos   OQP information struct (basis, atoms) !> @param[out]   lx_ao   Lx AO integrals, packed lower-triangular (nbf*(nbf+1)/2) !> @param[out]   ly_ao   Ly AO integrals, packed lower-triangular !> @param[out]   lz_ao   Lz AO integrals, packed lower-triangular subroutine compute_soc_ao ( infos , lx_ao , ly_ao , lz_ao ) use basis_tools , only : basis_set , bas_norm_matrix use cart2sph , only : cart2sph_mat use mod_1e_primitives , only : comp_soc_int1_prim , update_triang_matrix use mod_shell_tools , only : shell_t , shpair_t use constants , only : HARMONIC_ACTIVE , tol_int use precision , only : dp use types , only : information use parallel , only : par_env_t implicit none type ( information ), target , intent ( inout ) :: infos real ( kind = dp ), intent ( out ) :: lx_ao (:), ly_ao (:), lz_ao (:) type ( basis_set ), pointer :: basis type ( shell_t ) :: shi , shj type ( shpair_t ) :: cntp integer , parameter :: blocksize = 28 * 28 real ( kind = dp ) :: socblk ( blocksize , 3 ) integer :: ii , jj , ig , iat , iz , nat , nbf , mpi_ii real ( kind = dp ) :: ze , tol type ( par_env_t ) :: pe basis => infos % basis basis % atoms => infos % atoms nat = size ( infos % atoms % zn ) nbf = basis % nbf tol = log ( 1 0.0_dp ) * tol_int lx_ao = 0.0_dp ly_ao = 0.0_dp lz_ao = 0.0_dp call pe % init ( infos % mpiinfo % comm , infos % mpiinfo % usempi ) !$omp parallel & !$omp   private(shi, shj, cntp, socblk, ii, jj, ig, iat, iz, ze, mpi_ii) & !$omp   reduction(+:lx_ao, ly_ao, lz_ao) call cntp % alloc ( basis ) !$omp barrier if ( infos % mpiinfo % usempi ) mpi_ii = 0 do ii = basis % nshell , 1 , - 1 if ( infos % mpiinfo % usempi ) then mpi_ii = mpi_ii + 1 if ( mod ( mpi_ii , pe % size ) /= pe % rank ) cycle end if call shi % fetch_by_id ( basis , ii ) !$omp do schedule(dynamic) do jj = 1 , ii call shj % fetch_by_id ( basis , jj ) call cntp % shell_pair ( basis , shi , shj , tol , dup = . false .) if ( cntp % numpairs == 0 ) cycle socblk = 0.0_dp do ig = 1 , cntp % numpairs do iat = 1 , nat iz = nint ( infos % atoms % zn ( iat )) ze = real ( iz , dp ) call comp_soc_int1_prim ( cntp , ig , infos % atoms % xyz (:, iat ), ze , socblk ) end do end do if ( HARMONIC_ACTIVE . and . ( shi % harmonic == 1 . or . shj % harmonic == 1 )) then call cart2sph_mat ( socblk (:, 1 ), shj % ang , shj % harmonic , shi % ang , shi % harmonic , & iandj = ( shi % shid == shj % shid ), antisym = . true .) call cart2sph_mat ( socblk (:, 2 ), shj % ang , shj % harmonic , shi % ang , shi % harmonic , & iandj = ( shi % shid == shj % shid ), antisym = . true .) call cart2sph_mat ( socblk (:, 3 ), shj % ang , shj % harmonic , shi % ang , shi % harmonic , & iandj = ( shi % shid == shj % shid ), antisym = . true .) end if call update_triang_matrix ( shi , shj , socblk (:, 1 ), lx_ao ) call update_triang_matrix ( shi , shj , socblk (:, 2 ), ly_ao ) call update_triang_matrix ( shi , shj , socblk (:, 3 ), lz_ao ) end do !$omp end do end do !$omp end parallel call pe % allreduce ( lx_ao , size ( lx_ao )) call pe % allreduce ( ly_ao , size ( ly_ao )) call pe % allreduce ( lz_ao , size ( lz_ao )) call bas_norm_matrix ( lx_ao , basis % bfnrm , nbf ) call bas_norm_matrix ( ly_ao , basis % bfnrm , nbf ) call bas_norm_matrix ( lz_ao , basis % bfnrm , nbf ) end subroutine compute_soc_ao !> @brief Print a packed SOC AO integral matrix in GAMESS-compatible format !> @details !>  Writes the lower-triangular AO integral matrix to unit iw in blocks of !>  NCOLS=5 columns, with basis function labels and row indices, matching !>  the layout used in GAMESS for direct comparison. !> !> @param[in]  iw     Log file unit !> @param[in]  comp   Component label ('LX', 'LY', or 'LZ') !> @param[in]  mat    Packed lower-triangular AO matrix (nbf*(nbf+1)/2) !> @param[in]  nbf    Number of basis functions !> @param[in]  basis  Basis set descriptor (used for bf_label) subroutine print_soc_ao_gamess ( iw , comp , mat , nbf , basis ) use basis_tools , only : basis_set use precision , only : dp implicit none integer , intent ( in ) :: iw , nbf character ( len = 2 ), intent ( in ) :: comp ! 'LX', 'LY', or 'LZ' real ( kind = dp ), intent ( in ) :: mat ( nbf * ( nbf + 1 ) / 2 ) type ( basis_set ), intent ( in ) :: basis integer , parameter :: NCOLS = 5 integer :: i , j , jstart , jend , jend_row , idx write ( iw , '(/,2x,a)' ) comp // '  AO INTEGRALS' jstart = 1 do while ( jstart <= nbf ) jend = min ( jstart + NCOLS - 1 , nbf ) ! column index header write ( iw , '(/,17x)' , advance = 'no' ) do j = jstart , jend write ( iw , '(i11)' , advance = 'no' ) j end do write ( iw , '(/)' ) ! data rows (lower triangle only) do i = jstart , nbf jend_row = min ( jend , i ) if ( jend_row < jstart ) cycle write ( iw , '(i5,2x,a8,2x)' , advance = 'no' ) i , basis % bf_label ( i ) do j = jstart , jend_row idx = i * ( i - 1 ) / 2 + j write ( iw , '(f11.6)' , advance = 'no' ) mat ( idx ) end do write ( iw , * ) end do jstart = jend + 1 end do write ( iw , * ) end subroutine print_soc_ao_gamess !> @brief Transform a packed antisymmetric SOC AO matrix to the MO basis !> @details !>  Unpacks the lower-triangular AO integral into a full antisymmetric matrix !>  (L(nu,mu) = -L(mu,nu), diagonal = 0), then applies the two-step MO !>  transformation: tmp = L_AO * C, L_MO = C&#94;T * tmp via DGEMM. !> !> @param[in]  l_tri  Packed lower-triangular AO integrals (nbf*(nbf+1)/2) !> @param[out] l_mo   Full MO integral matrix (nbf x nbf) !> @param[in]  cmo    MO coefficient matrix C(mu,p) (nbf x nbf) !> @param[in]  nbf    Number of basis functions subroutine ao2mo_soc ( l_tri , l_mo , cmo , nbf ) use precision , only : dp implicit none real ( kind = dp ), intent ( in ) :: l_tri ( nbf * ( nbf + 1 ) / 2 ) ! AO integrals, packed lower triangle real ( kind = dp ), intent ( out ) :: l_mo ( nbf , nbf ) ! MO integrals, full matrix real ( kind = dp ), intent ( in ) :: cmo ( nbf , nbf ) ! MO coefficient matrix C(mu,p) integer , intent ( in ) :: nbf real ( kind = dp ), allocatable :: l_full (:,:), tmp (:,:) integer :: mu , nu , idx allocate ( l_full ( nbf , nbf ), tmp ( nbf , nbf )) ! Unpack lower triangle into full antisymmetric matrix: L(nu,mu) = -L(mu,nu) l_full = 0.0_dp do mu = 1 , nbf do nu = 1 , mu - 1 idx = mu * ( mu - 1 ) / 2 + nu l_full ( mu , nu ) = l_tri ( idx ) l_full ( nu , mu ) = - l_tri ( idx ) end do ! diagonal is zero by antisymmetry end do ! tmp(mu,q) = sum_nu L&#94;AO(mu,nu) * C(nu,q) call dgemm ( 'N' , 'N' , nbf , nbf , nbf , & 1.0_dp , l_full , nbf , & cmo , nbf , & 0.0_dp , tmp , nbf ) ! L&#94;MO(p,q) = sum_mu C(mu,p) * tmp(mu,q)  =  C&#94;T * tmp call dgemm ( 'T' , 'N' , nbf , nbf , nbf , & 1.0_dp , cmo , nbf , & tmp , nbf , & 0.0_dp , l_mo , nbf ) deallocate ( l_full , tmp ) end subroutine ao2mo_soc !> @brief Build spin-dependent transition density matrices from MRSF Davidson vectors !> @details !>  Constructs the TDMs needed to assemble the SOC Hamiltonian matrix elements: !>    t00aa(I,J,t,u)  -- singlet I / triplet J TDM in the alpha-alpha spin sector !>    t110aa(I,J,t,u) -- triplet I / triplet J, Ms=0 component (alpha-alpha) !>    t11ab(I,J,t,u)  -- triplet I / triplet J, Ms=+1/-1 component (alpha-beta) !> !>  The Davidson eigenvectors are first reordered to the Ms-resolved form required !>  by the GAMESS SOC convention (see compute_soc_matrix for the state ordering). !>  The open-shell ROHF reference determines the active MO indices (iO1, iO2, iC). !> !> @param[in]  bvec_s   Singlet Davidson vectors (xvec_dim x ns) !> @param[in]  bvec_t   Triplet Davidson vectors (xvec_dim x nt) !> @param[in]  nocca    Number of alpha occupied MOs !> @param[in]  noccb    Number of beta  occupied MOs !> @param[in]  nbf      Number of basis functions !> @param[in]  ns, nt   Number of singlet/triplet states !> @param[out] t00aa    Singlet-triplet TDM (ns x nt x nbf x nbf) !> @param[out] t110aa   Triplet-triplet TDM, Ms=0 sector (nt x nt x nbf x nbf) !> @param[out] t11ab    Triplet-triplet TDM, Ms=±1 sector (nt x nt x nbf x nbf) subroutine compute_tdm ( bvec_s , bvec_t , nocca , noccb , nbf , ns , nt , & t00aa , t110aa , t11ab ) use precision , only : dp implicit none real ( kind = dp ), intent ( in ) :: bvec_s ( nocca * ( nbf - noccb ), ns ) real ( kind = dp ), intent ( in ) :: bvec_t ( nocca * ( nbf - noccb ), nt ) integer , intent ( in ) :: nocca , noccb , nbf , ns , nt real ( kind = dp ), intent ( out ) :: t00aa ( ns , nt , nbf , nbf ) real ( kind = dp ), intent ( out ) :: t110aa ( nt , nt , nbf , nbf ) real ( kind = dp ), intent ( out ) :: t11ab ( nt , nt , nbf , nbf ) real ( kind = dp ), allocatable :: xs (:,:), xt (:,:) integer :: xvec_dim integer :: iV , iO2 , iO1 , iC integer :: ijLR1 , ijG , ijD , ijLR2 integer :: ist , jst , i , it , iu integer :: ijiO1 , ijiO2 , ijO1a , ijO2a integer :: iO1a , jO1a , iO2a , jO2a integer :: iiO1 , jiO1 , iiO2 , jiO2 real ( kind = dp ), parameter :: half = 0.5_dp real ( kind = dp ), parameter :: sqrt2 = 1.0_dp / sqrt ( 2.0_dp ) iV = nocca + 1 iO2 = nocca iO1 = nocca - 1 iC = nocca - 2 xvec_dim = size ( bvec_s , 1 ) ijLR1 = ( iO1 - noccb - 1 ) * nocca + iO1 ijG = ( iO1 - noccb - 1 ) * nocca + iO2 ijD = ( iO2 - noccb - 1 ) * nocca + iO1 ijLR2 = ( iO2 - noccb - 1 ) * nocca + iO2 allocate ( xs ( xvec_dim , ns ), xt ( xvec_dim , nt )) do ist = 1 , ns xs (:, ist ) = bvec_s (:, ist ) xs ( ijLR2 , ist ) = - bvec_s ( ijLR1 , ist ) end do do jst = 1 , nt xt (:, jst ) = bvec_t (:, jst ) xt ( ijLR2 , jst ) = bvec_t ( ijLR1 , jst ) xt ( ijG , jst ) = 0.0_dp xt ( ijD , jst ) = 0.0_dp end do t00aa = 0.0_dp t110aa = 0.0_dp t11ab = 0.0_dp ! Diagonal t=u block. Only triplet-triplet TDMs are nonzero. do ist = 1 , nt do jst = 1 , nt do iu = 1 , nbf it = iu do i = 1 , noccb ijiO1 = ( iO1 - noccb - 1 ) * nocca + i ijiO2 = ( iO2 - noccb - 1 ) * nocca + i t110aa ( ist , jst , it , iu ) = t110aa ( ist , jst , it , iu ) & + xt ( ijiO1 , ist ) * xt ( ijiO1 , jst ) & + xt ( ijiO2 , ist ) * xt ( ijiO2 , jst ) end do t110aa ( ist , jst , it , iu ) = t110aa ( ist , jst , it , iu ) & + xt ( ijLR1 , ist ) * xt ( ijLR1 , jst ) end do end do end do ! Core-open blocks: singlet-triplet part. do ist = 1 , ns do jst = 1 , nt ijiO1 = ( iO1 - noccb - 1 ) * nocca + iC ijiO2 = ( iO2 - noccb - 1 ) * nocca + iC t00aa ( ist , jst , iO1 , iC ) = - half * xs ( ijLR1 , ist ) * xt ( ijiO1 , jst ) & - sqrt2 * xs ( ijD , ist ) * xt ( ijiO2 , jst ) t00aa ( ist , jst , iC , iO1 ) = - half * xs ( ijiO1 , ist ) * xt ( ijLR1 , jst ) t00aa ( ist , jst , iO2 , iC ) = - sqrt2 * xs ( ijG , ist ) * xt ( ijiO1 , jst ) & + half * xs ( ijLR2 , ist ) * xt ( ijiO2 , jst ) t00aa ( ist , jst , iC , iO2 ) = - half * xs ( ijiO2 , ist ) * xt ( ijLR2 , jst ) end do end do ! Core-open blocks: triplet-triplet part. do ist = 1 , nt do jst = 1 , nt ijiO1 = ( iO1 - noccb - 1 ) * nocca + iC ijiO2 = ( iO2 - noccb - 1 ) * nocca + iC t110aa ( ist , jst , iO1 , iC ) = - half * xt ( ijLR1 , ist ) * xt ( ijiO1 , jst ) t11ab ( ist , jst , iO1 , iC ) = + sqrt2 * xt ( ijLR1 , ist ) * xt ( ijiO1 , jst ) t110aa ( ist , jst , iC , iO1 ) = - half * xt ( ijiO1 , ist ) * xt ( ijLR1 , jst ) t11ab ( ist , jst , iC , iO1 ) = + sqrt2 * xt ( ijiO1 , ist ) * xt ( ijLR1 , jst ) t110aa ( ist , jst , iO2 , iC ) = - half * xt ( ijLR2 , ist ) * xt ( ijiO2 , jst ) t11ab ( ist , jst , iO2 , iC ) = + sqrt2 * xt ( ijLR2 , ist ) * xt ( ijiO2 , jst ) t110aa ( ist , jst , iC , iO2 ) = - half * xt ( ijiO2 , ist ) * xt ( ijLR2 , jst ) t11ab ( ist , jst , iC , iO2 ) = + sqrt2 * xt ( ijiO2 , ist ) * xt ( ijLR1 , jst ) end do end do ! Open-open blocks: singlet-triplet part. do ist = 1 , ns do jst = 1 , nt do i = 1 , noccb ijiO1 = ( iO1 - noccb - 1 ) * nocca + i ijiO2 = ( iO2 - noccb - 1 ) * nocca + i t00aa ( ist , jst , iO2 , iO1 ) = t00aa ( ist , jst , iO2 , iO1 ) & - half * xs ( ijiO1 , ist ) * xt ( ijiO2 , jst ) t00aa ( ist , jst , iO1 , iO2 ) = t00aa ( ist , jst , iO1 , iO2 ) & - half * xs ( ijiO2 , ist ) * xt ( ijiO1 , jst ) end do t00aa ( ist , jst , iO2 , iO1 ) = t00aa ( ist , jst , iO2 , iO1 ) & - sqrt2 * xs ( ijG , ist ) * xt ( ijLR1 , jst ) t00aa ( ist , jst , iO1 , iO2 ) = t00aa ( ist , jst , iO1 , iO2 ) & - sqrt2 * xs ( ijD , ist ) * xt ( ijLR2 , jst ) do i = 1 , nbf - nocca ijO2a = ( nocca + i - noccb - 1 ) * nocca + iO2 ijO1a = ( nocca + i - noccb - 1 ) * nocca + iO1 t00aa ( ist , jst , iO2 , iO1 ) = t00aa ( ist , jst , iO2 , iO1 ) & - half * xs ( ijO2a , ist ) * xt ( ijO1a , jst ) t00aa ( ist , jst , iO1 , iO2 ) = t00aa ( ist , jst , iO1 , iO2 ) & - half * xs ( ijO1a , ist ) * xt ( ijO2a , jst ) end do end do end do ! Open-open blocks: triplet-triplet part. do ist = 1 , nt do jst = 1 , nt do i = 1 , noccb ijiO1 = ( iO1 - noccb - 1 ) * nocca + i ijiO2 = ( iO2 - noccb - 1 ) * nocca + i t110aa ( ist , jst , iO2 , iO1 ) = t110aa ( ist , jst , iO2 , iO1 ) & + half * xt ( ijiO1 , ist ) * xt ( ijiO2 , jst ) t11ab ( ist , jst , iO2 , iO1 ) = t11ab ( ist , jst , iO2 , iO1 ) & - sqrt2 * xt ( ijiO1 , ist ) * xt ( ijiO2 , jst ) t110aa ( ist , jst , iO1 , iO2 ) = t110aa ( ist , jst , iO1 , iO2 ) & + half * xt ( ijiO2 , ist ) * xt ( ijiO1 , jst ) t11ab ( ist , jst , iO1 , iO2 ) = t11ab ( ist , jst , iO1 , iO2 ) & - sqrt2 * xt ( ijiO2 , ist ) * xt ( ijiO1 , jst ) end do do i = 1 , nbf - nocca ijO2a = ( nocca + i - noccb - 1 ) * nocca + iO2 ijO1a = ( nocca + i - noccb - 1 ) * nocca + iO1 t110aa ( ist , jst , iO2 , iO1 ) = t110aa ( ist , jst , iO2 , iO1 ) & - half * xt ( ijO2a , ist ) * xt ( ijO1a , jst ) t11ab ( ist , jst , iO2 , iO1 ) = t11ab ( ist , jst , iO2 , iO1 ) & - sqrt2 * xt ( ijO2a , ist ) * xt ( ijO1a , jst ) t110aa ( ist , jst , iO1 , iO2 ) = t110aa ( ist , jst , iO1 , iO2 ) & - half * xt ( ijO1a , ist ) * xt ( ijO2a , jst ) t11ab ( ist , jst , iO1 , iO2 ) = t11ab ( ist , jst , iO1 , iO2 ) & - sqrt2 * xt ( ijO1a , ist ) * xt ( ijO2a , jst ) end do end do end do ! Virtual-open blocks: singlet-triplet part. do ist = 1 , ns do jst = 1 , nt do it = iV , nbf ijO1a = ( it - noccb - 1 ) * nocca + iO1 ijO2a = ( it - noccb - 1 ) * nocca + iO2 t00aa ( ist , jst , it , iO1 ) = - sqrt2 * xs ( ijG , ist ) * xt ( ijO2a , jst ) & - half * xs ( ijLR2 , ist ) * xt ( ijO1a , jst ) t00aa ( ist , jst , iO1 , it ) = - half * xs ( ijO1a , ist ) * xt ( ijLR2 , jst ) t00aa ( ist , jst , it , iO2 ) = + half * xs ( ijLR1 , ist ) * xt ( ijO2a , jst ) & - sqrt2 * xs ( ijD , ist ) * xt ( ijO1a , jst ) t00aa ( ist , jst , iO2 , it ) = - half * xs ( ijO2a , ist ) * xt ( ijLR1 , jst ) end do end do end do ! Virtual-open blocks: triplet-triplet part. do ist = 1 , nt do jst = 1 , nt do it = iV , nbf ijO1a = ( it - noccb - 1 ) * nocca + iO1 ijO2a = ( it - noccb - 1 ) * nocca + iO2 t110aa ( ist , jst , it , iO1 ) = + half * xt ( ijLR2 , ist ) * xt ( ijO1a , jst ) t11ab ( ist , jst , it , iO1 ) = + sqrt2 * xt ( ijLR1 , ist ) * xt ( ijO1a , jst ) t110aa ( ist , jst , iO1 , it ) = + half * xt ( ijO1a , ist ) * xt ( ijLR2 , jst ) t11ab ( ist , jst , iO1 , it ) = + sqrt2 * xt ( ijO1a , ist ) * xt ( ijLR1 , jst ) t110aa ( ist , jst , it , iO2 ) = + half * xt ( ijLR1 , ist ) * xt ( ijO2a , jst ) t11ab ( ist , jst , it , iO2 ) = + sqrt2 * xt ( ijLR2 , ist ) * xt ( ijO2a , jst ) t110aa ( ist , jst , iO2 , it ) = + half * xt ( ijO2a , ist ) * xt ( ijLR1 , jst ) t11ab ( ist , jst , iO2 , it ) = + sqrt2 * xt ( ijO2a , ist ) * xt ( ijLR1 , jst ) end do end do end do ! Off-diagonal virtual-virtual blocks. do ist = 1 , ns do jst = 1 , nt do iu = iV , nbf do it = iV , nbf if ( iu == it ) cycle iO1a = ( iu - noccb - 1 ) * nocca + iO1 jO1a = ( it - noccb - 1 ) * nocca + iO1 iO2a = ( iu - noccb - 1 ) * nocca + iO2 jO2a = ( it - noccb - 1 ) * nocca + iO2 t00aa ( ist , jst , it , iu ) = - half * ( xs ( iO1a , ist ) * xt ( jO1a , jst ) & + xs ( iO2a , ist ) * xt ( jO2a , jst )) end do end do end do end do do ist = 1 , nt do jst = 1 , nt do iu = iV , nbf do it = iV , nbf if ( iu == it ) cycle iO1a = ( iu - noccb - 1 ) * nocca + iO1 jO1a = ( it - noccb - 1 ) * nocca + iO1 iO2a = ( iu - noccb - 1 ) * nocca + iO2 jO2a = ( it - noccb - 1 ) * nocca + iO2 t110aa ( ist , jst , it , iu ) = + half * ( xt ( iO1a , ist ) * xt ( jO1a , jst ) & + xt ( iO2a , ist ) * xt ( jO2a , jst )) t11ab ( ist , jst , it , iu ) = + sqrt2 * ( xt ( iO1a , ist ) * xt ( jO1a , jst ) & + xt ( iO2a , ist ) * xt ( jO2a , jst )) end do end do end do end do ! Off-diagonal core-core blocks. do ist = 1 , ns do jst = 1 , nt do iu = 1 , noccb do it = 1 , noccb if ( iu == it ) cycle iiO1 = ( iO1 - noccb - 1 ) * nocca + iu jiO1 = ( iO1 - noccb - 1 ) * nocca + it iiO2 = ( iO2 - noccb - 1 ) * nocca + iu jiO2 = ( iO2 - noccb - 1 ) * nocca + it t00aa ( ist , jst , it , iu ) = - half * ( xs ( iiO1 , ist ) * xt ( jiO1 , jst ) & + xs ( iiO2 , ist ) * xt ( jiO2 , jst )) end do end do end do end do do ist = 1 , nt do jst = 1 , nt do iu = 1 , noccb do it = 1 , noccb if ( iu == it ) cycle iiO1 = ( iO1 - noccb - 1 ) * nocca + iu jiO1 = ( iO1 - noccb - 1 ) * nocca + it iiO2 = ( iO2 - noccb - 1 ) * nocca + iu jiO2 = ( iO2 - noccb - 1 ) * nocca + it t110aa ( ist , jst , it , iu ) = + half * ( xt ( iiO1 , ist ) * xt ( jiO1 , jst ) & + xt ( iiO2 , ist ) * xt ( jiO2 , jst )) t11ab ( ist , jst , it , iu ) = + sqrt2 * ( xt ( iiO1 , ist ) * xt ( jiO1 , jst ) & + xt ( iiO2 , ist ) * xt ( jiO2 , jst )) end do end do end do end do deallocate ( xs , xt ) end subroutine compute_tdm subroutine compute_soc_matrix ( t00aa , t110aa , t11ab , lx_mo , ly_mo , lz_mo , & ns , nt , nbf , hsoc ) ! ! Assemble the full SOC Hamiltonian in the basis of MRSF spin-states. ! ! Basis ordering (GAMESS convention): !   rows/cols 1..ns              : singlets S_I !   rows/cols ns+1..ns+3*nt      : triplets, grouped as !                                  (T_0,Ms=-1),(T_0,Ms=0),(T_0,Ms=+1), !                                  (T_1,Ms=-1),(T_1,Ms=0),(T_1,Ms=+1), ... !   index helper: itrp(J,Ms) = ns + (J-1)*3 + (Ms+2) ! ! S-T block (only T00aa needed; T00bb = -T00aa by time reversal): !   <S_I| h_soc |T_J, Ms=0 > = sum_tu 2*celm_aa * T00aa(I,J,t,u) !   <S_I| h_soc |T_J, Ms=+1> = sum_tu celm_ba*(-sqrt2) * T00aa(I,J,t,u) !   <S_I| h_soc |T_J, Ms=-1> = sum_tu celm_ab*(+sqrt2) * T00aa(I,J,t,u) ! ! T-T block (needs T110aa and T11ab; derived TDMs computed on the fly): !   T111aa   =  sqrt2*T11ab + T110aa !   T111bb   = -sqrt2*T11ab + T110aa  (= Tm11m1aa) !   T110bb   =  T110aa !   T1m1ba   =  T11ab                 (= Tm11m1bb) ! !   <T_I,Ms=0 | h_soc |T_J,Ms=+1> = sum_tu celm_ba * T11ab(I,J,t,u) !   <T_I,Ms=0 | h_soc |T_J,Ms=-1> = sum_tu celm_ab * T11ab(I,J,t,u) !   <T_I,Ms=+1| h_soc |T_J,Ms=+1> = sum_tu (celm_aa*T111aa + celm_bb*T111bb) !   <T_I,Ms=0 | h_soc |T_J,Ms=0 > = sum_tu (celm_aa*T110aa + celm_bb*T110bb) !   <T_I,Ms=-1| h_soc |T_J,Ms=-1> = sum_tu (celm_aa*Tm11m1aa + celm_bb*Tm11m1bb) ! ! Spin matrix elements (spnfac absorbed, GAMESS convention): !   celm_aa = (0, -Lz(t,u)/2) !   celm_bb = -celm_aa = (0, +Lz(t,u)/2) !   celm_ba = (Ly(t,u)/4, -Lx(t,u)/4)   [S- component; spnfac=0.5 already absorbed] !   celm_ab = (Ly(t,u)/4,  Lx(t,u)/4)   [S+ component] ! ! Note: celm_ba here = sqrt(0.5)*0.5*(Ly-iLx) per GAMESS lines 1108-1110. !       The extra sqrt(0.5) from the spin ladder operator S- is the spnfac. ! ! Output: hsoc(nstate, nstate), nstate = ns + 3*nt, in Hartree. ! use precision , only : dp implicit none real ( kind = dp ), intent ( in ) :: t00aa ( ns , nt , nbf , nbf ) real ( kind = dp ), intent ( in ) :: t110aa ( nt , nt , nbf , nbf ) real ( kind = dp ), intent ( in ) :: t11ab ( nt , nt , nbf , nbf ) real ( kind = dp ), intent ( in ) :: lx_mo ( nbf , nbf ) real ( kind = dp ), intent ( in ) :: ly_mo ( nbf , nbf ) real ( kind = dp ), intent ( in ) :: lz_mo ( nbf , nbf ) integer , intent ( in ) :: ns , nt , nbf complex ( kind = dp ), intent ( out ) :: hsoc ( ns + 3 * nt , ns + 3 * nt ) integer :: ist , jst , it , iu , itrp_i , itrp_j complex ( kind = dp ) :: celm_aa , celm_bb , celm_ba , celm_ab real ( kind = dp ) :: t111aa , t111bb , tm11m1aa , tm11m1bb , t110bb real ( kind = dp ), parameter :: sq2 = sqrt ( 2.0_dp ) real ( kind = dp ), parameter :: sq05 = sqrt ( 0.5_dp ) real ( kind = dp ), parameter :: half = 0.5_dp real ( kind = dp ), parameter :: quart = 0.25_dp hsoc = cmplx ( 0.0_dp , 0.0_dp , kind = dp ) do iu = 1 , nbf do it = 1 , nbf celm_aa = cmplx ( 0.0_dp , - lz_mo ( it , iu ) * half , kind = dp ) celm_bb = cmplx ( 0.0_dp , + lz_mo ( it , iu ) * half , kind = dp ) ! = -celm_aa celm_ba = cmplx ( + ly_mo ( it , iu ) * half , - lx_mo ( it , iu ) * half , kind = dp ) celm_ab = cmplx ( - ly_mo ( it , iu ) * half , - lx_mo ( it , iu ) * half , kind = dp ) do ist = 1 , ns do jst = 1 , nt ! --- S-T block: row=ist (singlet), col=ns+(jst-1)*3+Ms+2 --- ! Ms=0: hsoc ( ist , ns + ( jst - 1 ) * 3 + 2 ) = hsoc ( ist , ns + ( jst - 1 ) * 3 + 2 ) & + 2.0_dp * celm_aa * t00aa ( ist , jst , it , iu ) ! Ms=+1: hsoc ( ist , ns + ( jst - 1 ) * 3 + 3 ) = hsoc ( ist , ns + ( jst - 1 ) * 3 + 3 ) & + celm_ba * ( - sq2 ) * t00aa ( ist , jst , it , iu ) ! Ms=-1: hsoc ( ist , ns + ( jst - 1 ) * 3 + 1 ) = hsoc ( ist , ns + ( jst - 1 ) * 3 + 1 ) & + celm_ab * ( + sq2 ) * t00aa ( ist , jst , it , iu ) end do end do do ist = 1 , nt do jst = 1 , nt ! Derived TDMs (computed on the fly): t111aa = sq05 * t11ab ( ist , jst , it , iu ) + t110aa ( ist , jst , it , iu ) t111bb = - sq05 * t11ab ( ist , jst , it , iu ) + t110aa ( ist , jst , it , iu ) t110bb = t110aa ( ist , jst , it , iu ) tm11m1aa = t111bb tm11m1bb = t111aa itrp_i = ns + ( ist - 1 ) * 3 itrp_j = ns + ( jst - 1 ) * 3 ! <T_I,Ms=0| h_soc |T_J,Ms=+1>: celm_ba * T11ab hsoc ( itrp_i + 2 , itrp_j + 3 ) = hsoc ( itrp_i + 2 , itrp_j + 3 ) & + celm_ba * t11ab ( ist , jst , it , iu ) ! <T_I,Ms=0| h_soc |T_J,Ms=-1>: celm_ab * T11ab (T1m1ba = T11ab) hsoc ( itrp_i + 2 , itrp_j + 1 ) = hsoc ( itrp_i + 2 , itrp_j + 1 ) & + celm_ab * t11ab ( ist , jst , it , iu ) ! <T_I,Ms=+1| h_soc |T_J,Ms=+1>: celm_aa*T111aa + celm_bb*T111bb hsoc ( itrp_i + 3 , itrp_j + 3 ) = hsoc ( itrp_i + 3 , itrp_j + 3 ) & + celm_aa * t111aa + celm_bb * t111bb ! <Ti,Ms=+1|Tj,Ms=0> = conjg(celm_ba) * T11ab(jst,ist,it,iu) hsoc ( itrp_i + 3 , itrp_j + 2 ) = hsoc ( itrp_i + 3 , itrp_j + 2 ) + conjg ( celm_ba ) * t11ab ( jst , ist , it , iu ) ! <T_I,Ms=0| h_soc |T_J,Ms=0>: celm_aa*T110aa + celm_bb*T110bb hsoc ( itrp_i + 2 , itrp_j + 2 ) = hsoc ( itrp_i + 2 , itrp_j + 2 ) & + celm_aa * t110aa ( ist , jst , it , iu ) + celm_bb * t110bb ! <Ti,Ms=-1|Tj,Ms=0> = conjg(celm_ab) * T11ab(jst,ist,it,iu) hsoc ( itrp_i + 1 , itrp_j + 2 ) = hsoc ( itrp_i + 1 , itrp_j + 2 ) + conjg ( celm_ab ) * t11ab ( jst , ist , it , iu ) ! <T_I,Ms=-1| h_soc |T_J,Ms=-1>: celm_aa*Tm11m1aa + celm_bb*Tm11m1bb hsoc ( itrp_i + 1 , itrp_j + 1 ) = hsoc ( itrp_i + 1 , itrp_j + 1 ) & + celm_aa * tm11m1aa + celm_bb * tm11m1bb end do end do end do end do ! Fill lower triangle by Hermitian conjugation (hsoc should be Hermitian): ! H(j,i) = conjg(H(i,j)) for all i>j do ist = 1 , ns + 3 * nt do jst = ist + 1 , ns + 3 * nt hsoc ( jst , ist ) = conjg ( hsoc ( ist , jst )) end do end do end subroutine compute_soc_matrix !> @brief Diagonalize the SOC Hamiltonian and return adiabatic eigenvalues/eigenvectors !> @details !>  Builds the full (ns+3*nt) x (ns+3*nt) complex Hermitian matrix: !>    diagonal  = (E_I - E_0) * ha2wn  [excitation energies in cm-1] !>    off-diag  = hsoc(I,J)  * dfac    [SOC couplings in cm-1] !>  where E_0 = min(singlet_energies(1), triplet_energies(1)). !>  Diagonalizes via LAPACK zheev. The eigenvectors evec are returned in !>  column-major order and used for the state decomposition print. !> !>  Note: uses explicit integer(4) arguments for LP64 LAPACK compatibility. !> !> @param[in]  hsoc                SOC Hamiltonian matrix in Hartree (ns+3*nt x ns+3*nt) !> @param[in]  singlet_energies    MRSF singlet excitation energies (Hartree, rel. ROHF) !> @param[in]  triplet_energies    MRSF triplet excitation energies (Hartree, rel. ROHF) !> @param[in]  e_ref               ROHF reference energy (Hartree) !> @param[in]  ns, nt              Number of singlet/triplet states !> @param[out] eval                Adiabatic SOC eigenvalues (cm-1, rel. lowest state) !> @param[out] evec                SOC eigenvectors (complex, column = adiabat) subroutine diag_soc ( hsoc , singlet_energies , triplet_energies , e_ref , ns , nt , eval , evec ) use precision , only : dp use mathlib_types , only : blas_int use messages , only : show_message , WITH_ABORT use physical_constants , only : ha2wn => HA_TO_WAVENUM , & FINE_STRUCTURE implicit none complex ( kind = dp ), intent ( in ) :: hsoc ( ns + 3 * nt , ns + 3 * nt ) real ( kind = dp ), intent ( in ) :: singlet_energies ( ns ) real ( kind = dp ), intent ( in ) :: triplet_energies ( nt ) real ( kind = dp ), intent ( in ) :: e_ref integer , intent ( in ) :: ns , nt real ( kind = dp ), intent ( out ) :: eval ( ns + 3 * nt ) complex ( kind = dp ), intent ( out ) :: evec ( ns + 3 * nt , ns + 3 * nt ) integer :: nstate , ist , i , j , ioff integer ( blas_int ) :: nstate_ , lwork_ , info real ( kind = dp ) :: e0 complex ( kind = dp ), allocatable :: work (:) complex ( kind = dp ) :: work_query ( 1 ) real ( kind = dp ), allocatable :: rwork (:) real ( kind = dp ), parameter :: dfac = FINE_STRUCTURE ** 2 / 2.0_dp * ha2wn nstate = ns + 3 * nt nstate_ = int ( nstate , blas_int ) allocate ( rwork ( 3 * nstate )) ! --- 1. Scale off-diagonal SOC elements to cm-1, fill diagonal with excitation energies --- do j = 1 , nstate do i = 1 , nstate evec ( i , j ) = hsoc ( i , j ) * dfac end do end do e0 = min ( singlet_energies ( 1 ), triplet_energies ( 1 )) do ist = 1 , ns evec ( ist , ist ) = cmplx (( singlet_energies ( ist ) - e0 ) * ha2wn , 0.0_dp , kind = dp ) end do do ist = 1 , nt do j = 1 , 3 ! Ms = -1, 0, +1 components share the same energy ioff = ns + ( ist - 1 ) * 3 + j evec ( ioff , ioff ) = cmplx (( triplet_energies ( ist ) - e0 ) * ha2wn , 0.0_dp , kind = dp ) end do end do ! --- 2. Diagonalize via LAPACK zheev --- ! Workspace query call zheev ( 'V' , 'U' , nstate_ , evec , nstate_ , eval , work_query , - 1_blas_int , rwork , info ) lwork_ = int ( real ( work_query ( 1 )), blas_int ) allocate ( work ( lwork_ )) call zheev ( 'V' , 'U' , nstate_ , evec , nstate_ , eval , work , lwork_ , rwork , info ) if ( info /= 0 ) then call show_message ( '(A,I0)' , 'ZHEEV failed in diag_soc, info=' , int ( info ), WITH_ABORT ) end if deallocate ( rwork , work ) end subroutine diag_soc !> @brief Print SOC adiabatic eigenvalues and eigenvector decomposition table !> @details !>  Writes two blocks to iw: !>    1. Eigenvalue table: state index, energy in cm-1, Hartree, and eV !>    2. Eigenvector table: mixing coefficients printed in blocks of 5 columns; !>       components with |c|&#94;2 < 0.01 are suppressed for readability. !> !> @param[in]  iw                 Log file unit !> @param[in]  eval               Adiabatic SOC eigenvalues (cm-1) !> @param[in]  evec               SOC eigenvectors (complex, column = adiabat) !> @param[in]  singlet_energies   MRSF singlet excitation energies (Hartree) !> @param[in]  triplet_energies   MRSF triplet excitation energies (Hartree) !> @param[in]  e_ref              ROHF reference energy (Hartree) !> @param[in]  ns, nt             Number of singlet/triplet states subroutine print_soc_eigenvalues ( iw , eval , evec , singlet_energies , triplet_energies , e_ref , ns , nt ) use precision , only : dp implicit none integer , intent ( in ) :: iw , ns , nt real ( kind = dp ), intent ( in ) :: eval ( ns + 3 * nt ) complex ( kind = dp ), intent ( in ) :: evec ( ns + 3 * nt , ns + 3 * nt ) real ( kind = dp ), intent ( in ) :: singlet_energies ( ns ), triplet_energies ( nt ), e_ref integer :: nstate , ist , i , j , ncols , ioff , ms_idx real ( kind = dp ) :: e0 , a , b , tmpmod real ( kind = dp ), parameter :: ha2wn = 21947 4.6_dp real ( kind = dp ), parameter :: ha2ev = 2 7.211386245988_dp nstate = ns + 3 * nt e0 = min ( singlet_energies ( 1 ), triplet_energies ( 1 )) ! Eigenvalues write ( iw , '(/,11x,65(\"-\"))' ) write ( iw , '(11x,a)' ) 'SOC eigenvalues (adiabatic, SOC-corrected)' write ( iw , '(11x,65(\"-\"))' ) write ( iw , '(a)' ) '  Non-SOC ground state is at 0 cm-1' write ( iw , '()' ) write ( iw , '(5x,a,12x,a,14x,a,14x,a)' ) 'State' , 'cm-1' , 'Hartree' , 'eV' do ist = 1 , nstate write ( iw , '(5x,i4,2x,f14.4,2x,f18.10,2x,f14.6)' ) & ist , eval ( ist ), eval ( ist ) / ha2wn + e0 , ( eval ( ist ) / ha2wn + e0 ) * ha2ev end do ! Eigenvectors (5 columns at a time) write ( iw , '(/,11x,a)' ) 'SOC eigenvectors (rows = diabatic states, cols = adiabats)' ncols = 5 ioff = 0 do while ( ioff < nstate ) write ( iw , '(/,10x)' , advance = 'no' ) do j = ioff + 1 , min ( ioff + ncols , nstate ) write ( iw , '(i6,8x)' , advance = 'no' ) j end do write ( iw , * ) write ( iw , '(8x,a)' , advance = 'no' ) 'E(cm-1)' do j = ioff + 1 , min ( ioff + ncols , nstate ) write ( iw , '(f10.2,4x)' , advance = 'no' ) eval ( j ) end do write ( iw , * ) do i = 1 , nstate if ( i <= ns ) then write ( iw , '(4x,a1,i3,2x)' , advance = 'no' ) 'S' , i - 1 else ist = ( i - ns - 1 ) / 3 + 1 ms_idx = mod ( i - ns - 1 , 3 ) select case ( ms_idx ) case ( 0 ); write ( iw , '(3x,a1,i3,a)' , advance = 'no' ) 'T' , ist - 1 , '(-1)' case ( 1 ); write ( iw , '(3x,a1,i3,a)' , advance = 'no' ) 'T' , ist - 1 , '( 0)' case ( 2 ); write ( iw , '(3x,a1,i3,a)' , advance = 'no' ) 'T' , ist - 1 , '(+1)' end select end if do j = ioff + 1 , min ( ioff + ncols , nstate ) a = real ( evec ( i , j )); b = aimag ( evec ( i , j )) tmpmod = a ** 2 + b ** 2 if ( tmpmod >= 0.01_dp ) then write ( iw , '(f8.4,sp,f7.4,\"i\",\" \")' , advance = 'no' ) a , b else write ( iw , '(16x)' , advance = 'no' ) end if end do write ( iw , * ) end do ioff = ioff + ncols end do end subroutine print_soc_eigenvalues ! 2e part !> @brief Print per-state SOC decomposition: energy and top-3 diabatic contributions !> @details !>  For each adiabatic SOC state, computes the diabatic weights |c_I|&#94;2 from !>  the eigenvector matrix and identifies the three largest contributions. !>  Output format (one line per state): !>    index   cm-1   eV   Label1 (wt%)   Label2 (wt%)   Label3 (wt%) !>  where labels are S<n> for singlets and T<n>(Ms) for triplet sublevels. !>  Contributions below 0.1% are suppressed. !> !> @param[in]  iw    Log file unit !> @param[in]  eval  Adiabatic SOC eigenvalues (cm-1) !> @param[in]  evec  SOC eigenvectors (complex, column = adiabat) !> @param[in]  ns    Number of singlet states !> @param[in]  nt    Number of triplet states subroutine print_soc_decomposition ( iw , eval , evec , ns , nt ) use precision , only : dp implicit none integer , intent ( in ) :: iw , ns , nt real ( kind = dp ), intent ( in ) :: eval ( ns + 3 * nt ) complex ( kind = dp ), intent ( in ) :: evec ( ns + 3 * nt , ns + 3 * nt ) integer , parameter :: ntop = 3 integer :: nstate , ist , i , j , ms_idx real ( kind = dp ) :: weight ( ns + 3 * nt ), tmpmod real ( kind = dp ), parameter :: ha2wn = 21947 4.6_dp real ( kind = dp ), parameter :: ha2ev = 2 7.211386245988_dp integer :: idx ( ntop ) real ( kind = dp ) :: best ( ntop ) character ( len = 10 ) :: label nstate = ns + 3 * nt write ( iw , '(/,11x,65(\"-\"))' ) write ( iw , '(11x,a)' ) 'SOC state decomposition (top 3 diabatic contributions)' write ( iw , '(11x,65(\"-\"))' ) write ( iw , '(/,2x,a,4x,a,8x,a,8x,a)' ) 'State' , 'cm-1' , 'eV' , 'Composition' write ( iw , * ) do ist = 1 , nstate ! compute weights do i = 1 , nstate tmpmod = real ( evec ( i , ist )) ** 2 + aimag ( evec ( i , ist )) ** 2 weight ( i ) = tmpmod end do ! find top-3 by simple selection idx = 0 best = - 1.0_dp do j = 1 , ntop do i = 1 , nstate if ( weight ( i ) > best ( j )) then if ( j == 1 . or . all ( idx ( 1 : j - 1 ) /= i )) then best ( j ) = weight ( i ) idx ( j ) = i end if end if end do ! mask already chosen if ( idx ( j ) > 0 ) weight ( idx ( j )) = - 1.0_dp end do ! restore weights for next iteration do i = 1 , nstate tmpmod = real ( evec ( i , ist )) ** 2 + aimag ( evec ( i , ist )) ** 2 weight ( i ) = tmpmod end do write ( iw , '(2x,i4,2x,f10.2,2x,f10.6,2x)' , advance = 'no' ) & ist , eval ( ist ), eval ( ist ) / ha2wn * ha2ev do j = 1 , ntop i = idx ( j ) if ( i == 0 ) exit if ( weight ( i ) < 0.001_dp ) exit if ( i <= ns ) then write ( label , '(a1,i0)' ) 'S' , i - 1 else ms_idx = mod ( i - ns - 1 , 3 ) select case ( ms_idx ) case ( 0 ); write ( label , '(a1,i0,a)' ) 'T' , ( i - ns - 1 ) / 3 , '(-1)' case ( 1 ); write ( label , '(a1,i0,a)' ) 'T' , ( i - ns - 1 ) / 3 , '( 0)' case ( 2 ); write ( label , '(a1,i0,a)' ) 'T' , ( i - ns - 1 ) / 3 , '(+1)' end select end if write ( iw , '(a8,a,f5.1,a,a)' , advance = 'no' ) & trim ( label ), ' (' , weight ( i ) * 10 0.0_dp , '%)' , '   ' end do write ( iw , * ) end do write ( iw , '(11x,65(\"-\"))' ) end subroutine print_soc_decomposition end module soc_mrsf_mod","tags":"","url":"sourcefile/soc_mrsf.f90.html"},{"title":"tdhf_sf_hessian.F90 – OpenQP Fortran API","text":"Source Code module tdhf_sf_hessian_mod implicit none character ( len =* ), parameter :: module_name = \"tdhf_sf_hessian_mod\" contains !############################################################################### subroutine tdhf_sf_hessian_C ( c_handle ) bind ( C , name = \"tdhf_sf_hessian\" ) use c_interop , only : oqp_handle_t , oqp_handle_get_info use types , only : information type ( oqp_handle_t ) :: c_handle type ( information ), pointer :: inf inf => oqp_handle_get_info ( c_handle ) call tdhf_sf_hessian ( inf ) end subroutine tdhf_sf_hessian_C !############################################################################### subroutine tdhf_sf_hessian ( infos ) use types , only : information use messages , only : show_message , WITH_ABORT implicit none type ( information ), target , intent ( inout ) :: infos ! Analytic SF-TDDFT Hessian kernel scaffold reached. The C ABI is present ! for build/link integration, but the scientific kernel is deliberately ! guarded so `[hess] type=analytical` cannot return placeholder zeros or ! fall back to the numerical Hessian. call show_message (& 'Analytic SF-TDDFT Hessian kernel scaffold reached; implementation is not available yet.' , & WITH_ABORT ) end subroutine tdhf_sf_hessian end module tdhf_sf_hessian_mod","tags":"","url":"sourcefile/tdhf_sf_hessian.f90.html"},{"title":"dk_scalar.F90 – OpenQP Fortran API","text":"Source Code !> @file dk_scalar.F90 !> @brief Douglas-Kroll scalar relativistic correction to the one-electron Hamiltonian !> !> @details Implements the DK1 and DK2 Douglas-Kroll-Hess transformations that replace !>          the non-relativistic H_core = T + V with the scalar relativistic H&#94;DK. !>          The DK transformation is carried out in the momentum (p) representation !>          obtained by diagonalising the kinetic energy matrix T. !> !>          Pipeline (called once per SCF): !>            1. Compute pVp integrals  <mu|p(-sum_A Z_A/r_A)p|nu> !>            2. Build p-space basis:   S&#94;{-1/2} -> XU, SXU, p&#94;2 eigenvalues !>            3. Compute kinematic factors: E_p, A, R !>            4. Transform V and pVp to p-space !>            5. Build H&#94;DK1 in p-space (DK1 correction) !>            6. Add H&#94;DK2 correction in p-space (DK2 correction) !>            7. Back-transform to AO basis -> overwrite OQP::Hcore !> !> @author Vladimir Makhnev !> @date   March 2026 module dk_scalar_mod implicit none character ( len =* ), parameter :: module_name = \"dk_scalar_mod\" !> Set to .true. to enable diagnostic output from DK routines logical :: dk_debug = . false . private compute_and_check_pvp public dk_scalar contains !> @brief C-interop wrapper: unpack the OQP handle and call dk_scalar subroutine dk_scalar_C ( c_handle ) bind ( C , name = \"dk_scalar\" ) use c_interop , only : oqp_handle_t , oqp_handle_get_info use types , only : information type ( oqp_handle_t ) :: c_handle type ( information ), pointer :: inf inf => oqp_handle_get_info ( c_handle ) call dk_scalar ( inf ) end subroutine dk_scalar_C !> @brief Apply scalar relativistic Douglas-Kroll correction to H_core !> !> @details Reads OQP::SM (overlap), OQP::TM (kinetic energy), and !>          OQP::Hcore (= T + V) from the tagarray, performs the DK1+DK2 !>          transformation, and overwrites OQP::Hcore with H&#94;DK. !> !> @param[inout] infos  OQP information struct (basis, atoms, tagarray, log) subroutine dk_scalar ( infos ) use types , only : information use oqp_tagarray_driver use precision , only : dp use io_constants , only : iw use basis_tools , only : basis_set use messages , only : show_message , WITH_ABORT use printing , only : print_module_info implicit none character ( len =* ), parameter :: subroutine_name = \"dk_scalar\" type ( information ), target , intent ( inout ) :: infos type ( basis_set ), pointer :: basis integer :: nbf ! number of AO basis functions integer :: nbf2 ! triangular size nbf*(nbf+1)/2 integer :: ok ! allocation status integer :: i , j , idx ! --- tagarray pointers (no copy: point into tagarray storage) --- real ( kind = dp ), contiguous , pointer :: hcore (:), tmat (:), smat (:) character ( len =* ), parameter :: tags_required ( 3 ) = ( / character ( len = 80 ) :: & OQP_SM , OQP_TM , OQP_Hcore / ) ! --- working arrays --- real ( kind = dp ), allocatable :: & pvp (:), & ! <mu|p V p|nu>,  packed triangular (nbf2) XU (:,:), & ! X*U:  columns are the p-space basis vectors in AO rep. SXU (:,:), & ! S*X*U: used for the back-transformation to AO basis psq (:), & ! p_i&#94;2: eigenvalues of 2T in the orthonormal basis Ep (:), & ! relativistic kinetic energy  E_p = c*sqrt(p&#94;2 + c&#94;2) Akin (:), & ! kinematic factor  A_i = sqrt((E_p+c&#94;2)/(2*E_p)) Rkin (:), & ! kinematic factor  R_i = c/(E_p+c&#94;2) hdk (:) ! H&#94;DK in AO basis, packed triangular (nbf2) real ( kind = dp ), allocatable :: hdkp (:) ! H&#94;DK in p-space, packed triangular real ( kind = dp ), allocatable :: & Vp (:), & ! V = Hcore-T transformed to p-space, packed triangular PVPp (:) ! pVp transformed to p-space, packed triangular integer :: qrnk ! effective rank after removing linear dependencies in S dk_debug = ( infos % control % verbose > 1 ) open ( unit = iw , file = infos % log_filename , position = \"append\" ) call print_module_info ( 'DK_SCALAR' , 'Douglas-Kroll Scalar Relativistic Correction' ) ! --- check requested DK order --- select case ( infos % control % scal_rel ) case ( 0 ) write ( iw , '(1x,a)' ) 'scal_rel = 0: scalar relativistic correction disabled, skipping.' close ( iw ) return case ( 1 ) write ( iw , '(1x,a)' ) 'scal_rel = 1: applying DK1 correction.' case ( 2 ) write ( iw , '(1x,a)' ) 'scal_rel = 2: applying DK1 + DK2 correction.' case default write ( iw , '(1x,a,i0)' ) 'WARNING: unknown scal_rel value: ' , infos % control % scal_rel write ( iw , '(1x,a)' ) 'Defaulting to DK2.' end select basis => infos % basis basis % atoms => infos % atoms nbf = basis % nbf nbf2 = nbf * ( nbf + 1 ) / 2 ! --- verify required tags are present --- call data_has_tags ( infos % dat , tags_required , & module_name , subroutine_name , WITH_ABORT ) call tagarray_get_data ( infos % dat , OQP_SM , smat ) call tagarray_get_data ( infos % dat , OQP_TM , tmat ) call tagarray_get_data ( infos % dat , OQP_Hcore , hcore ) ! --- allocate main working arrays --- allocate ( pvp ( nbf2 ), & XU ( nbf , nbf ), & SXU ( nbf , nbf ), & psq ( nbf ), & Ep ( nbf ), & Akin ( nbf ), & Rkin ( nbf ), & hdk ( nbf2 ), & stat = ok ) if ( ok /= 0 ) call show_message ( 'dk_scalar: cannot allocate' , WITH_ABORT ) ! --- Step 1: compute <mu|pVp|nu> integrals --- call compute_and_check_pvp ( basis , infos , pvp ) if ( dk_debug ) then write ( iw , '(/,a)' ) '  Hcore diagonal d-block (14-19):' do i = 14 , 19 write ( iw , '(2x,i5,es16.6)' ) i , hcore ( i * ( i - 1 ) / 2 + i ) end do write ( iw , '(a)' ) '  Hcore(17,17), (18,18), (19,19) vs (14,14):' write ( iw , '(3es16.6)' ) hcore ( 17 * 16 / 2 + 17 ), hcore ( 14 * 13 / 2 + 14 ) end if ! --- Step 2: build p-space basis --- call build_p_space ( smat , tmat , nbf , XU , SXU , psq , qrnk ) if ( dk_debug ) then write ( iw , '(a,2i5)' ) '  nbf, qrnk = ' , nbf , qrnk end if call check_p_space ( smat , tmat , nbf , qrnk , XU , SXU , psq ) allocate ( Vp ( qrnk * ( qrnk + 1 ) / 2 ), PVPp ( qrnk * ( qrnk + 1 ) / 2 ), hdkp ( qrnk * ( qrnk + 1 ) / 2 ), stat = ok ) if ( ok /= 0 ) call show_message ( 'dk_scalar: cannot allocate p-space arrays' , WITH_ABORT ) ! --- Step 3: kinematic factors E_p, A, R --- call compute_kinematic_factors ( psq , qrnk , Ep , Akin , Rkin ) if ( dk_debug ) then write ( iw , '(a,es12.4)' ) '  PVP min diagonal: ' , minval ([( pvp ( i * ( i + 1 ) / 2 ), i = 1 , nbf )]) write ( iw , '(a,es16.6)' ) '  Trace pvp: ' , sum ([( pvp ( i * ( i + 1 ) / 2 ), i = 1 , nbf )]) end if ! --- Step 4: transform V and pVp to p-space --- call transform_to_p_space ( hcore , tmat , pvp , XU , nbf , qrnk , Vp , PVPp ) if ( dk_debug ) then write ( iw , '(/,a)' ) '  Vp diagonal (first 5):' do i = 1 , min ( 5 , qrnk ) write ( iw , '(2x,i5,es16.6)' ) i , Vp ( i * ( i + 1 ) / 2 ) end do end if ! --- Steps 5-6: build H&#94;DK1, then add H&#94;DK2 correction if requested --- call build_hdk_p ( Ep , Akin , Rkin , Vp , PVPp , qrnk , hdkp ) if ( infos % control % scal_rel >= 2 ) & call build_hdk2_p ( Ep , Akin , Rkin , psq , Vp , PVPp , qrnk , hdkp ) ! --- Step 7: back-transform to AO basis --- call back_transform_hdk ( hdkp , SXU , nbf , qrnk , hdk ) if ( dk_debug ) then write ( iw , '(/,a)' ) '  === NR limit check: hdk vs hcore ===' write ( iw , '(a,es12.4)' ) '  Max |hdk - hcore|: ' , maxval ( abs ( hdk ( 1 : nbf2 ) - hcore ( 1 : nbf2 ))) write ( iw , '(/,a)' ) '  hcore diagonal (first 5):' do i = 1 , min ( 5 , nbf ) write ( iw , '(2x,i5,es16.6)' ) i , hcore ( i * ( i + 1 ) / 2 ) end do write ( iw , '(/,a)' ) '  H_DK matrix:' do i = 1 , nbf do j = 1 , i idx = i * ( i - 1 ) / 2 + j write ( iw , '(2i5, f20.10)' ) i , j , hdk ( idx ) end do end do end if ! --- overwrite OQP::Hcore with H&#94;DK --- hcore (:) = hdk (:) deallocate ( pvp , XU , SXU , psq , Ep , Akin , Rkin , hdk , Vp , PVPp , hdkp ) write ( iw , '(/1X,\"...... End Of DK Scalar Correction ......\"/)' ) close ( iw ) end subroutine dk_scalar !> @brief Compute the <mu|pVp|nu> integrals and apply AO normalisation !> !> @details Loops over shell pairs and accumulates the momentum-weighted !>          nuclear attraction integrals: !> !>            (pVp)_{mu nu} = <mu| p * (-sum_A Z_A&#94;eff/r_A) * p |nu> !> !>          The result is stored in packed triangular form and normalised !>          with bas_norm_matrix (accounts for the sqrt(3) factor for !>          Cartesian d-functions).  When dk_debug is enabled, symmetry !>          and positivity of the diagonal are verified. !> !> @param[in]    basis   Basis set descriptor !> @param[inout] infos   OQP information struct (atoms, ECP charges, log) !> @param[out]   pvp     pVp matrix, packed lower-triangular (nbf*(nbf+1)/2) subroutine compute_and_check_pvp ( basis , infos , pvp ) use types , only : information use basis_tools , only : basis_set , bas_norm_matrix use mod_1e_primitives , only : comp_pvp_int1_prim , update_triang_matrix use mod_shell_tools , only : shell_t , shpair_t use cart2sph , only : cart2sph_mat use constants , only : HARMONIC_ACTIVE , tol_int use messages , only : show_message , with_abort use precision , only : dp use io_constants , only : iw use printing , only : print_sym_labeled implicit none type ( basis_set ), intent ( in ) :: basis type ( information ), intent ( inout ) :: infos real ( dp ), intent ( out ) :: pvp (:) ! packed triangular, size nbf2 type ( shell_t ) :: shi , shj type ( shpair_t ) :: cntp integer :: ii , jj , iat , nat , nbf , nbf2 , ig , ok real ( dp ) :: tol integer , parameter :: blocksize = 28 * 28 ! max Cartesian functions per shell pair real ( dp ), allocatable :: pvpmat (:) ! accumulated pVp, packed triangular real ( dp ), allocatable :: pvpfull (:,:) ! unpacked pVp for symmetry check (debug) real ( dp ) :: pvpblk ( blocksize ) ! primitive-level buffer for one shell pair real ( dp ) :: sym_err , diag_min integer :: mu , nu , idx_mu_nu nbf = basis % nbf nbf2 = nbf * ( nbf + 1 ) / 2 nat = ubound ( infos % atoms % zn , 1 ) tol = log ( 1 0.0_dp ) * tol_int allocate ( pvpmat ( nbf2 ), stat = ok ) if ( ok /= 0 ) call show_message ( 'compute_and_check_pvp: cannot allocate' , with_abort ) pvpmat = 0.0_dp ! --- loop over shell pairs, accumulate pVp contributions from all nuclei --- call cntp % alloc ( basis ) do ii = basis % nshell , 1 , - 1 call shi % fetch_by_id ( basis , ii ) do jj = 1 , ii call shj % fetch_by_id ( basis , jj ) call cntp % shell_pair ( basis , shi , shj , tol ) if ( cntp % numpairs == 0 ) cycle pvpblk = 0.0_dp do iat = 1 , nat do ig = 1 , cntp % numpairs ! charge weight: -(Z - Z_ecp) so that V = -sum_A Z_eff/r_A call comp_pvp_int1_prim ( & cntp , ig , & infos % atoms % xyz (:, iat ), & - ( infos % atoms % zn ( iat ) - infos % basis % ecp_zn_num ( iat )), & pvpblk ) end do end do if ( HARMONIC_ACTIVE . and . ( shi % harmonic == 1 . or . shj % harmonic == 1 )) & call cart2sph_mat ( pvpblk , shj % ang , shj % harmonic , shi % ang , shi % harmonic , iandj = ( shi % shid == shj % shid )) call update_triang_matrix ( shi , shj , pvpblk , pvpmat ) end do end do if ( dk_debug ) then ! --- check 1: pVp must be symmetric --- allocate ( pvpfull ( nbf , nbf ), stat = ok ) if ( ok /= 0 ) call show_message ( 'compute_and_check_pvp: cannot allocate pvpfull' , with_abort ) pvpfull = 0.0_dp do mu = 1 , nbf do nu = 1 , mu idx_mu_nu = mu * ( mu - 1 ) / 2 + nu pvpfull ( mu , nu ) = pvpmat ( idx_mu_nu ) pvpfull ( nu , mu ) = pvpmat ( idx_mu_nu ) end do end do sym_err = 0.0_dp do mu = 1 , nbf do nu = 1 , nbf sym_err = max ( sym_err , abs ( pvpfull ( mu , nu ) - pvpfull ( nu , mu ))) end do end do write ( iw , '(/,a)' ) '  === PVP integral checks ===' write ( iw , '(a,es12.4)' ) '  Max symmetry error (should be 0): ' , sym_err ! --- check 2: diagonal elements must be non-negative --- diag_min = huge ( 1.0_dp ) do mu = 1 , nbf idx_mu_nu = mu * ( mu - 1 ) / 2 + mu diag_min = min ( diag_min , pvpmat ( idx_mu_nu )) end do write ( iw , '(a,es12.4)' ) '  Min diagonal element (should be >= 0): ' , diag_min deallocate ( pvpfull ) end if ! --- apply AO normalisation (accounts for sqrt(3) on d-shell cross terms) --- call bas_norm_matrix ( pvpmat , basis % bfnrm , nbf ) if ( dk_debug ) then write ( iw , '(/,a)' ) '  PVP matrix:' call print_sym_labeled ( pvpmat , nbf , basis ) end if pvp (:) = pvpmat (:) deallocate ( pvpmat ) end subroutine compute_and_check_pvp !> @brief Build the p-space transformation matrices from S and T !> !> @details Constructs the momentum-space basis by canonical orthogonalisation !>          of the overlap followed by diagonalisation of 2T.  The result is !>          a set of vectors X~ such that: !> !>            X~&#94;T * S * X~ = I_qrnk !>            X~&#94;T * 2T * X~ = diag(p_i&#94;2),  i = 1..qrnk !> !>          Procedure: !>            1. X  = S&#94;{-1/2}               (canonical orthogonalisation) !>            2. T~ = X&#94;T * 2T * X            (2T in orthonormal basis) !>            3. T~ * U = U * diag(p&#94;2)       (diagonalise T~) !>            4. XU  = X * U                  (p-space basis in AO rep.) !>            5. SXU = S * XU                 (needed for back-transform) !> !> @param[in]  smat   Overlap matrix, packed triangular (nbf*(nbf+1)/2) !> @param[in]  tmat   Kinetic energy matrix, packed triangular !> @param[in]  nbf    Number of AO basis functions !> @param[out] xu     XU matrix (nbf x nbf);  columns 1:qrnk are valid !> @param[out] sxu    SXU = S * XU (nbf x nbf);  columns 1:qrnk are valid !> @param[out] psq    p_i&#94;2 eigenvalues (nbf); entries 1:qrnk are valid !> @param[out] qrnk   Effective rank (nbf minus linear dependencies) subroutine build_p_space ( smat , tmat , nbf , xu , sxu , psq , qrnk ) use mathlib , only : matrix_invsqrt , orthogonal_transform_sym , unpack_f90 use eigen , only : diag_symm_packed use messages , only : show_message , with_abort use precision , only : dp implicit none real ( dp ), intent ( in ) :: smat ( * ), tmat ( * ) ! packed triangular, nbf*(nbf+1)/2 integer , intent ( in ) :: nbf real ( dp ), intent ( out ) :: xu ( nbf , nbf ) real ( dp ), intent ( out ) :: sxu ( nbf , nbf ) real ( dp ), intent ( out ) :: psq ( nbf ) integer , intent ( out ) :: qrnk real ( dp ), allocatable :: x (:,:) ! S&#94;{-1/2}  (nbf x nbf) real ( dp ), allocatable :: ttilde (:) ! X&#94;T * 2T * X, packed triangular real ( dp ), allocatable :: u (:,:) ! eigenvectors of ttilde real ( dp ), allocatable :: t2 (:) ! 2*T, packed triangular real ( dp ), allocatable :: sfull (:,:) ! S in full storage (for dsymm) integer :: nbf2 , ok , ierr nbf2 = nbf * ( nbf + 1 ) / 2 allocate ( x ( nbf , nbf ), & ttilde ( nbf2 ), & u ( nbf , nbf ), & t2 ( nbf2 ), & sfull ( nbf , nbf ), & stat = ok ) if ( ok /= 0 ) call show_message ( 'build_p_space: cannot allocate' , with_abort ) ! --- step 1: X = S&#94;{-1/2} --- call matrix_invsqrt ( smat , x , nbf , qrnk ) ! --- step 2: T~ = X&#94;T * 2T * X --- t2 ( 1 : nbf2 ) = 2.0_dp * tmat ( 1 : nbf2 ) call orthogonal_transform_sym ( nbf , qrnk , t2 , x , nbf , ttilde ) ! --- step 3: diagonalise T~ -> p&#94;2 eigenvalues and eigenvectors --- call diag_symm_packed ( 1 , qrnk , qrnk , qrnk , ttilde , psq , u , ierr ) if ( ierr /= 0 ) call show_message ( 'build_p_space: diag_symm_packed failed' , with_abort ) ! --- step 4: XU = X * U --- call dgemm ( 'n' , 'n' , nbf , qrnk , qrnk , & 1.0_dp , x , nbf , u , qrnk , & 0.0_dp , xu , nbf ) ! --- step 5: SXU = S * XU --- call unpack_f90 ( smat , sfull , 'u' ) call dsymm ( 'l' , 'u' , nbf , qrnk , & 1.0_dp , sfull , nbf , xu , nbf , & 0.0_dp , sxu , nbf ) deallocate ( x , ttilde , u , t2 , sfull ) end subroutine build_p_space !> @brief Verify the p-space orthonormality conditions (debug only) !> !> @details When dk_debug is .true., checks: !>            - XU&#94;T * S * XU  = I_qrnk   (orthonormality) !>            - XU&#94;T * 2T * XU = diag(psq) (eigenvalue condition) !>          and prints the first five p&#94;2 values.  Returns immediately !>          if dk_debug is .false. (zero cost in production runs). !> !> @param[in] smat   Overlap matrix, packed triangular !> @param[in] tmat   Kinetic energy matrix, packed triangular !> @param[in] nbf    Number of AO basis functions !> @param[in] qrnk   Effective rank !> @param[in] xu     p-space basis vectors in AO rep. (nbf x nbf) !> @param[in] sxu    S * XU  (nbf x nbf) !> @param[in] psq    p&#94;2 eigenvalues (qrnk) subroutine check_p_space ( smat , tmat , nbf , qrnk , xu , sxu , psq ) use precision , only : dp use io_constants , only : iw use messages , only : show_message , with_abort use mathlib , only : unpack_f90 implicit none real ( dp ), intent ( in ) :: smat ( * ), tmat ( * ) integer , intent ( in ) :: nbf , qrnk real ( dp ), intent ( in ) :: xu ( nbf , nbf ), sxu ( nbf , nbf ), psq ( nbf ) real ( dp ), allocatable :: check (:,:), t2full (:,:), tmp (:,:) real ( dp ) :: err1 , err2 integer :: i , j , ok if (. not . dk_debug ) return allocate ( check ( nbf , nbf ), t2full ( nbf , nbf ), tmp ( nbf , nbf ), stat = ok ) if ( ok /= 0 ) call show_message ( 'check_p_space: cannot allocate' , with_abort ) write ( iw , '(/,a)' ) '  === build_p_space checks ===' ! --- test 1: XU&#94;T * S * XU = I --- call dgemm ( 't' , 'n' , qrnk , qrnk , nbf , & 1.0_dp , sxu , nbf , xu , nbf , & 0.0_dp , check , nbf ) err1 = 0.0_dp do i = 1 , qrnk do j = 1 , qrnk if ( i == j ) then err1 = max ( err1 , abs ( check ( i , j ) - 1.0_dp )) else err1 = max ( err1 , abs ( check ( i , j ))) end if end do end do write ( iw , '(a,es12.4)' ) '  XU&#94;T*S*XU = I,            max error: ' , err1 ! --- test 2: XU&#94;T * 2T * XU = diag(psq) --- t2full = 0.0_dp call unpack_f90 ( tmat , t2full , 'u' ) t2full = 2.0_dp * t2full call dgemm ( 'n' , 'n' , nbf , qrnk , nbf , & 1.0_dp , t2full , nbf , xu , nbf , & 0.0_dp , tmp , nbf ) call dgemm ( 't' , 'n' , qrnk , qrnk , nbf , & 1.0_dp , xu , nbf , tmp , nbf , & 0.0_dp , check , nbf ) err2 = 0.0_dp do i = 1 , qrnk do j = 1 , qrnk if ( i == j ) then err2 = max ( err2 , abs ( check ( i , j ) - psq ( i ))) else err2 = max ( err2 , abs ( check ( i , j ))) end if end do end do write ( iw , '(a,es12.4)' ) '  XU&#94;T*2T*XU = diag(psq),  max error: ' , err2 write ( iw , '(a)' ) '  First 5 p&#94;2 values:' do i = 1 , min ( 5 , qrnk ) write ( iw , '(2x,i5,es16.6)' ) i , psq ( i ) end do deallocate ( check , t2full , tmp ) end subroutine check_p_space !> @brief Compute the DK kinematic factors for each p-space eigenvalue !> !> @details For each momentum-space eigenvalue p_i&#94;2 computes: !> !>            E_p(i) = c * sqrt(p_i&#94;2 + c&#94;2)   (relativistic energy) !>            A(i)   = sqrt((E_p + c&#94;2) / (2*E_p)) !>            R(i)   = c / (E_p + c&#94;2) !> !>          where c = 137.0359895 a.u. (speed of light). !> !> @param[in]  psq    p_i&#94;2 eigenvalues (qrnk) !> @param[in]  qrnk   Number of p-space basis vectors !> @param[out] ep     Relativistic kinetic energy E_p (qrnk) !> @param[out] akin   Kinematic factor A (qrnk) !> @param[out] rkin   Kinematic factor R (qrnk) subroutine compute_kinematic_factors ( psq , qrnk , ep , akin , rkin ) use precision , only : dp use io_constants , only : iw implicit none real ( dp ), intent ( in ) :: psq ( * ) integer , intent ( in ) :: qrnk real ( dp ), intent ( out ) :: ep ( * ), akin ( * ), rkin ( * ) real ( dp ), parameter :: clight = 13 7.0359895_dp real ( dp ), parameter :: clight2 = clight * clight integer :: i do i = 1 , qrnk ep ( i ) = clight * sqrt ( psq ( i ) + clight2 ) akin ( i ) = sqrt (( ep ( i ) + clight2 ) / ( 2.0_dp * ep ( i ))) rkin ( i ) = clight / ( ep ( i ) + clight2 ) end do if ( dk_debug ) then write ( iw , '(/,a)' ) '  === Kinematic factors (first 5) ===' write ( iw , '(2x,a5,3a16)' ) 'i' , 'p&#94;2' , 'E_p - c&#94;2' , 'A_i' do i = 1 , min ( 5 , qrnk ) write ( iw , '(2x,i5,3es16.6)' ) i , psq ( i ), ep ( i ) - clight2 , akin ( i ) end do write ( iw , '(a)' ) '  Last 5:' do i = max ( 1 , qrnk - 4 ), qrnk write ( iw , '(2x,i5,3es16.6)' ) i , psq ( i ), ep ( i ) - clight2 , akin ( i ) end do end if end subroutine compute_kinematic_factors !> @brief Transform V and pVp from AO basis to p-space !> !> @details Applies the congruence transformation X~&#94;T * M * X~ !>          to both the potential V = Hcore - T and the pVp matrix: !> !>            V&#94;p   = XU&#94;T * V   * XU !>            pVp&#94;p = XU&#94;T * pVp * XU !> !>          Both results are stored as packed lower-triangular arrays !>          of size qrnk*(qrnk+1)/2. !> !> @param[in]  hcore  H_core = T+V, packed triangular AO (nbf2) !> @param[in]  tmat   Kinetic energy T, packed triangular AO (nbf2) !> @param[in]  pvp    pVp integrals, packed triangular AO (nbf2) !> @param[in]  xu     p-space basis XU (nbf x nbf) !> @param[in]  nbf    Number of AO basis functions !> @param[in]  qrnk   Effective rank !> @param[out] vp     V in p-space, packed triangular (qrnk*(qrnk+1)/2) !> @param[out] pvpp   pVp in p-space, packed triangular (qrnk*(qrnk+1)/2) subroutine transform_to_p_space ( hcore , tmat , pvp , xu , nbf , qrnk , vp , pvpp ) use mathlib , only : orthogonal_transform_sym use messages , only : show_message , with_abort use precision , only : dp use io_constants , only : iw implicit none real ( dp ), intent ( in ) :: hcore ( * ), tmat ( * ), pvp ( * ) ! packed triangular AO real ( dp ), intent ( in ) :: xu ( nbf , nbf ) integer , intent ( in ) :: nbf , qrnk real ( dp ), intent ( out ) :: vp ( * ) ! V in p-space, packed triangular real ( dp ), intent ( out ) :: pvpp ( * ) ! pVp in p-space, packed triangular integer :: nbf2 , ok real ( dp ), allocatable :: vao (:) ! V = Hcore - T in AO basis nbf2 = nbf * ( nbf + 1 ) / 2 allocate ( vao ( nbf2 ), stat = ok ) if ( ok /= 0 ) call show_message ( 'transform_to_p_space: cannot allocate' , with_abort ) ! --- V = Hcore - T --- vao ( 1 : nbf2 ) = hcore ( 1 : nbf2 ) - tmat ( 1 : nbf2 ) ! --- V&#94;p = XU&#94;T * V * XU --- call orthogonal_transform_sym ( nbf , qrnk , vao , xu , nbf , vp ) ! --- (pVp)&#94;p = XU&#94;T * pVp * XU --- call orthogonal_transform_sym ( nbf , qrnk , pvp , xu , nbf , pvpp ) if ( dk_debug ) then write ( iw , '(/,a)' ) '  === transform_to_p_space done ===' end if deallocate ( vao ) end subroutine transform_to_p_space !> @brief Build the DK1 Hamiltonian in p-space !> !> @details Constructs the first-order Douglas-Kroll Hamiltonian matrix !>          in the momentum representation (packed lower-triangular): !> !>            H&#94;DK1_{ij} = (E_p(i) - c&#94;2) * delta_{ij} !>                       + A(i) * V&#94;p_{ij} * A(j) !>                       + A(i)*R(i) * (pVp)&#94;p_{ij} * R(j)*A(j) !> !> @param[in]  ep     Relativistic energy E_p (qrnk) !> @param[in]  akin   Kinematic factor A (qrnk) !> @param[in]  rkin   Kinematic factor R (qrnk) !> @param[in]  vp     V in p-space, packed triangular (qrnk*(qrnk+1)/2) !> @param[in]  pvpp   pVp in p-space, packed triangular !> @param[in]  qrnk   Effective rank !> @param[out] hdkp   H&#94;DK1 in p-space, packed triangular subroutine build_hdk_p ( ep , akin , rkin , vp , pvpp , qrnk , hdkp ) use precision , only : dp use io_constants , only : iw implicit none real ( dp ), intent ( in ) :: ep ( * ), akin ( * ), rkin ( * ) real ( dp ), intent ( in ) :: vp ( * ), pvpp ( * ) integer , intent ( in ) :: qrnk real ( dp ), intent ( out ) :: hdkp ( * ) real ( dp ), parameter :: clight = 13 7.0359895_dp real ( dp ), parameter :: clight2 = clight * clight integer :: i , j , ij real ( dp ) :: ar_i , ar_j ij = 0 do i = 1 , qrnk ar_i = akin ( i ) * rkin ( i ) do j = 1 , i ij = ij + 1 ar_j = akin ( j ) * rkin ( j ) hdkp ( ij ) = akin ( i ) * vp ( ij ) * akin ( j ) & ! A * V&#94;p * A + ar_i * pvpp ( ij ) * ar_j ! A*R * (pVp)&#94;p * R*A ! add kinetic energy contribution on diagonal if ( i == j ) hdkp ( ij ) = hdkp ( ij ) + ep ( i ) - clight2 end do end do if ( dk_debug ) then write ( iw , '(/,a)' ) '  === H&#94;DK in p-space, diagonal (first 5) ===' do i = 1 , min ( 5 , qrnk ) write ( iw , '(2x,i5,3es16.6)' ) i , ep ( i ) - clight2 , hdkp ( i * ( i + 1 ) / 2 ) end do end if end subroutine build_hdk_p !> @brief Back-transform H&#94;DK from p-space to AO basis !> !> @details Applies the two-sided transformation: !> !>            H&#94;DK_AO = SXU * H&#94;DK_p * SXU&#94;T !> !>          where SXU = S * XU.  The result is symmetrised and packed !>          into a lower-triangular array. !> !> @param[in]  hdkp   H&#94;DK in p-space, packed triangular (qrnk*(qrnk+1)/2) !> @param[in]  sxu    S * XU matrix (nbf x nbf);  columns 1:qrnk are used !> @param[in]  nbf    Number of AO basis functions !> @param[in]  qrnk   Effective rank !> @param[out] hdk    H&#94;DK in AO basis, packed triangular (nbf*(nbf+1)/2) subroutine back_transform_hdk ( hdkp , sxu , nbf , qrnk , hdk ) use mathlib , only : unpack_f90 , pack_f90 use messages , only : show_message , with_abort use precision , only : dp use io_constants , only : iw implicit none real ( dp ), intent ( in ) :: hdkp ( * ) real ( dp ), intent ( in ) :: sxu ( nbf , nbf ) integer , intent ( in ) :: nbf , qrnk real ( dp ), intent ( out ) :: hdk ( * ) real ( dp ), allocatable :: hdkp_full (:,:) ! H&#94;DK_p in full storage real ( dp ), allocatable :: tmp (:,:) ! intermediate  SXU * H&#94;DK_p real ( dp ), allocatable :: hdk_full (:,:) ! H&#94;DK_AO in full storage integer :: ok , i , j allocate ( hdkp_full ( qrnk , qrnk ), & tmp ( nbf , qrnk ), & hdk_full ( nbf , nbf ), & stat = ok ) if ( ok /= 0 ) call show_message ( 'back_transform_hdk: cannot allocate' , with_abort ) ! --- unpack H&#94;DK_p and symmetrise --- call unpack_f90 ( hdkp , hdkp_full , 'u' ) do i = 1 , qrnk do j = i + 1 , qrnk hdkp_full ( j , i ) = hdkp_full ( i , j ) end do end do ! --- tmp = SXU * H&#94;DK_p --- call dgemm ( 'n' , 'n' , nbf , qrnk , qrnk , & 1.0_dp , sxu , nbf , hdkp_full , qrnk , & 0.0_dp , tmp , nbf ) ! --- H&#94;DK_AO = tmp * SXU&#94;T --- call dgemm ( 'n' , 't' , nbf , nbf , qrnk , & 1.0_dp , tmp , nbf , sxu , nbf , & 0.0_dp , hdk_full , nbf ) if ( dk_debug ) then write ( iw , '(/,a)' ) '  hdk_full diagonal (first 5):' do i = 1 , min ( 5 , nbf ) write ( iw , '(2x,i5,3es16.6)' ) i , hdk_full ( i , i ) end do end if ! --- pack to lower-triangular --- call pack_f90 ( hdk_full , hdk ( 1 : nbf * ( nbf + 1 ) / 2 ), 'u' ) if ( dk_debug ) then write ( iw , '(/,a)' ) '  === back_transform_hdk done ===' write ( iw , '(a)' ) '  H&#94;DK diagonal (first 5):' do i = 1 , min ( 5 , nbf ) write ( iw , '(2x,i5,es16.6)' ) i , hdk ( i * ( i + 1 ) / 2 ) end do end if deallocate ( hdkp_full , tmp , hdk_full ) end subroutine back_transform_hdk !> @brief Add the DK2 second-order correction to H&#94;DK in p-space !> !> @details Computes and accumulates the DK2 correction following the !>          direct W_1&#94;2 approach (equivalent to GAMESS DK2X): !> !>            H&#94;DK2 += -1/2 (E * W_1&#94;2 + W_1&#94;2 * E)  -  W_1 * E * W_1 !> !>          where W_1 is the first-order unitary generator.  Rather than !>          forming W_1 explicitly, W_1&#94;2 and W_1*E*W_1 are assembled !>          from four matrix-matrix products each, using scaled V&#94;p and !>          pVp&#94;p matrices: !> !>            V~_{ij}   = V&#94;p_{ij}   / (E_p(i) + E_p(j)) !>            pVp~_{ij} = pVp&#94;p_{ij} / (E_p(i) + E_p(j)) !> !>          Block 1 - W_1&#94;2 (four terms): !>            +  (AR*pVp~*RA) * (A*V~*A) !>            +  (A*V~*A)     * (AR*pVp~*RA) !>            -  (A*V~*p&#94;2*R&#94;2*A) * (A*V~*A) !>            -  (AR*pVp~*A/p&#94;2)  * (A*pVp~*RA) !> !>          Block 2 - W_1*E*W_1 (four analogous terms with extra E factors). !> !>          The result is symmetrised and added to hdkp in-place. !> !> @param[in]    ep     Relativistic energy E_p (qrnk) !> @param[in]    akin   Kinematic factor A (qrnk) !> @param[in]    rkin   Kinematic factor R (qrnk) !> @param[in]    psq    p&#94;2 eigenvalues (qrnk) !> @param[in]    vp     V in p-space, packed triangular !> @param[in]    pvpp   pVp in p-space, packed triangular !> @param[in]    qrnk   Effective rank !> @param[inout] hdkp   H&#94;DK in p-space (DK2 correction accumulated in-place) subroutine build_hdk2_p ( ep , akin , rkin , psq , vp , pvpp , qrnk , hdkp ) use precision , only : dp use messages , only : show_message , with_abort implicit none real ( dp ), intent ( in ) :: ep ( * ), akin ( * ), rkin ( * ), psq ( * ) real ( dp ), intent ( in ) :: vp ( * ), pvpp ( * ) integer , intent ( in ) :: qrnk real ( dp ), intent ( inout ) :: hdkp ( * ) real ( dp ), allocatable :: vps (:,:) ! V~   = V&#94;p  / (Ei+Ej),  full real ( dp ), allocatable :: pvpps (:,:) ! pVp~ = pVp&#94;p/ (Ei+Ej),  full real ( dp ), allocatable :: ma (:,:) ! scratch matrix A real ( dp ), allocatable :: mb (:,:) ! scratch matrix B real ( dp ), allocatable :: w1sq (:,:) ! W_1&#94;2  accumulator real ( dp ), allocatable :: hdk2 (:,:) ! DK2 correction (full, before pack) integer :: i , j , ij , ok allocate ( vps ( qrnk , qrnk ), pvpps ( qrnk , qrnk ), & ma ( qrnk , qrnk ), mb ( qrnk , qrnk ), & w1sq ( qrnk , qrnk ), hdk2 ( qrnk , qrnk ), & stat = ok ) if ( ok /= 0 ) call show_message ( 'build_hdk2_p: cannot allocate' , with_abort ) ! --- scale V&#94;p and pVp&#94;p by 1/(Ei+Ej) --- ij = 0 do i = 1 , qrnk do j = 1 , i ij = ij + 1 vps ( i , j ) = vp ( ij ) / ( ep ( i ) + ep ( j )) vps ( j , i ) = vps ( i , j ) pvpps ( i , j ) = pvpp ( ij ) / ( ep ( i ) + ep ( j )) pvpps ( j , i ) = pvpps ( i , j ) end do end do ! ========================================================= ! Block 1: build W_1&#94;2 from four terms ! ========================================================= w1sq = 0.0_dp ! --- term 1: (AR*pVp~*RA) * (A*V~*A) --- do i = 1 , qrnk do j = 1 , i ma ( i , j ) = akin ( i ) * rkin ( i ) * pvpps ( i , j ) * rkin ( j ) * akin ( j ) ma ( j , i ) = ma ( i , j ) mb ( i , j ) = akin ( i ) * vps ( i , j ) * akin ( j ) mb ( j , i ) = mb ( i , j ) end do end do call dgemm ( 'n' , 'n' , qrnk , qrnk , qrnk , 1.0_dp , ma , qrnk , mb , qrnk , 0.0_dp , w1sq , qrnk ) ! --- term 2: (A*V~*A) * (AR*pVp~*RA) --- call dgemm ( 'n' , 'n' , qrnk , qrnk , qrnk , 1.0_dp , mb , qrnk , ma , qrnk , 1.0_dp , w1sq , qrnk ) ! --- term 3: -(A*V~*p&#94;2*R&#94;2*A) * (A*V~*A) --- do i = 1 , qrnk do j = 1 , i ma ( i , j ) = akin ( i ) * vps ( i , j ) * akin ( j ) * psq ( j ) * rkin ( j ) ** 2 ma ( j , i ) = akin ( j ) * vps ( i , j ) * akin ( i ) * psq ( i ) * rkin ( i ) ** 2 end do end do call dgemm ( 'n' , 'n' , qrnk , qrnk , qrnk , - 1.0_dp , ma , qrnk , mb , qrnk , 1.0_dp , w1sq , qrnk ) ! --- term 4: -(AR*pVp~*A/p&#94;2) * (A*pVp~*RA) --- do i = 1 , qrnk do j = 1 , i ma ( i , j ) = akin ( i ) * rkin ( i ) * pvpps ( i , j ) * akin ( j ) / psq ( j ) ma ( j , i ) = akin ( j ) * rkin ( j ) * pvpps ( i , j ) * akin ( i ) / psq ( i ) mb ( i , j ) = akin ( i ) * pvpps ( i , j ) * rkin ( j ) * akin ( j ) mb ( j , i ) = akin ( j ) * pvpps ( i , j ) * rkin ( i ) * akin ( i ) end do end do call dgemm ( 'n' , 'n' , qrnk , qrnk , qrnk , - 1.0_dp , ma , qrnk , mb , qrnk , 1.0_dp , w1sq , qrnk ) ! --- accumulate -1/2*(E*W1sq + W1sq*E) into hdk2 --- ! E is diagonal: (E*W1sq)_{ij} = ep(i)*w1sq(i,j) do i = 1 , qrnk do j = 1 , qrnk hdk2 ( i , j ) = - 0.5_dp * ( ep ( i ) * w1sq ( i , j ) + w1sq ( i , j ) * ep ( j )) end do end do ! ========================================================= ! Block 2: -W_1*E*W_1 from four terms (same structure, extra ep factor) ! ========================================================= ! --- term 1: -(AR*pVp~*RA*E) * (A*V~*A) --- do i = 1 , qrnk do j = 1 , i ma ( i , j ) = akin ( i ) * rkin ( i ) * pvpps ( i , j ) * rkin ( j ) * akin ( j ) * ep ( j ) ma ( j , i ) = akin ( j ) * rkin ( j ) * pvpps ( i , j ) * rkin ( i ) * akin ( i ) * ep ( i ) mb ( i , j ) = akin ( i ) * vps ( i , j ) * akin ( j ) mb ( j , i ) = mb ( i , j ) end do end do call dgemm ( 'n' , 'n' , qrnk , qrnk , qrnk , - 1.0_dp , ma , qrnk , mb , qrnk , 1.0_dp , hdk2 , qrnk ) ! --- term 2: -(A*V~*A) * (AR*pVp~*RA*E)&#94;T --- call dgemm ( 'n' , 't' , qrnk , qrnk , qrnk , - 1.0_dp , mb , qrnk , ma , qrnk , 1.0_dp , hdk2 , qrnk ) ! --- term 3: +(A*V~*p&#94;2*R&#94;2*E*A) * (A*V~*A) --- do i = 1 , qrnk do j = 1 , i ma ( i , j ) = akin ( i ) * vps ( i , j ) * akin ( j ) * psq ( j ) * rkin ( j ) ** 2 * ep ( j ) ma ( j , i ) = akin ( j ) * vps ( i , j ) * akin ( i ) * psq ( i ) * rkin ( i ) ** 2 * ep ( i ) end do end do call dgemm ( 'n' , 'n' , qrnk , qrnk , qrnk , 1.0_dp , ma , qrnk , mb , qrnk , 1.0_dp , hdk2 , qrnk ) ! --- term 4: +(AR*pVp~*A*E/p&#94;2) * (A*pVp~*RA) --- do i = 1 , qrnk do j = 1 , i ma ( i , j ) = akin ( i ) * rkin ( i ) * pvpps ( i , j ) * akin ( j ) * ep ( j ) / psq ( j ) ma ( j , i ) = akin ( j ) * rkin ( j ) * pvpps ( i , j ) * akin ( i ) * ep ( i ) / psq ( i ) mb ( i , j ) = akin ( i ) * pvpps ( i , j ) * rkin ( j ) * akin ( j ) mb ( j , i ) = akin ( j ) * pvpps ( i , j ) * rkin ( i ) * akin ( i ) end do end do call dgemm ( 'n' , 'n' , qrnk , qrnk , qrnk , 1.0_dp , ma , qrnk , mb , qrnk , 1.0_dp , hdk2 , qrnk ) ! --- symmetrise and accumulate into hdkp (packed triangular) --- ij = 0 do i = 1 , qrnk do j = 1 , i ij = ij + 1 hdkp ( ij ) = hdkp ( ij ) + 0.5_dp * ( hdk2 ( i , j ) + hdk2 ( j , i )) end do end do deallocate ( vps , pvpps , ma , mb , w1sq , hdk2 ) end subroutine build_hdk2_p end module dk_scalar_mod","tags":"","url":"sourcefile/dk_scalar.f90.html"},{"title":"ecp.F90 – OpenQP Fortran API","text":"Source Code !> @brief ECP (effective core potential) interface built on libecpint. !> @detail Provides ECP one-electron integrals and first derivatives, handling !>         AO-label remapping and shell-origin geometry. Wraps libecpint’s C API !>         and exposes simple Fortran-callable routines for OpenQP. !> @author Mohsen Mazaherifar !> @date January 2025 module ecp_tool use iso_c_binding , only : c_double , c_ptr , c_int , c_int64_t ,& c_f_pointer , C_LOC , c_null_ptr use , intrinsic :: iso_fortran_env , only : real64 use libecpint_wrapper use libecp_result , only : ecp_result use basis_tools , only : basis_set use precision , only : dp use constants , only : HARMONIC_ACTIVE , NUM_CART_BF implicit none private public add_ecpint public add_ecpder public add_ecphess public ecp_deriv_ints contains !> @brief Add ECP one-electron contribution to the AO-core Hamiltonian (packed). !> @detail Computes scalar ECP integrals with libecpint (deriv order 0), !>         remaps them into OpenQP AO ordering via @ref transform_ecp_matrix, !>         and accumulates into upper-triangular packed Hcore. !> @param[in]  basis   Basis set (contains ECP params and AO metadata). !> @param[in]  coord   Nuclear coordinates (3×natm). !> @param[inout] hcore Upper-triangular packed AO core Hamiltonian (size nbf*(nbf+1)/2). !> @note No-op if basis%ecp_params%is_ecp == .false. !> @author Mohsen Mazaherifar !> @date January 2025 subroutine add_ecpint ( basis , coord , hcore ) real ( real64 ), contiguous , intent ( in ) :: coord (:,:) type ( basis_set ), intent ( in ) :: basis real ( real64 ), contiguous , intent ( inout ) :: hcore (:) type ( c_ptr ) :: integrator type ( ecp_result ) :: result_ptr real ( c_double ), pointer :: libecp_res (:) real ( c_double ), allocatable :: ecp_mat (:) integer :: i , j , c integer ( c_int ) :: driv_order if (. not .( basis % ecp_params % is_ecp )) then return end if driv_order = 0 call set_integrator ( integrator , basis , coord , driv_order ) result_ptr = compute_integrals ( integrator ) call c_f_pointer ( result_ptr % data , libecp_res , [ result_ptr % size ]) call transform_ecp_matrix ( basis , libecp_res , ecp_mat ) c = 0 do i = 1 , basis % nbf do j = 1 , i c = c + 1 hcore ( c ) = ecp_mat (( i - 1 ) * basis % nbf + j ) + hcore ( c ) end do end do ! free the C-side buffer BEFORE nulling the local handle: free_result ! takes the struct by value, so nulling first would leak the buffer call free_result ( result_ptr ) result_ptr % data = c_null_ptr result_ptr % size = 0 nullify ( libecp_res ) deallocate ( ecp_mat ) call free_integrator ( integrator ) end subroutine add_ecpint !> @brief Add ECP force contribution (first derivatives) to nuclear gradients. !> @detail Computes dV_ECP/dR_A in AO full-square form for each atom using !>         libecpint (deriv order 1), transforms to OpenQP AO ordering, and !>         contracts with the symmetric density `denab` (packed) to accumulate !>         into atomic gradient components `de(:,A)`. !> @param[in]    basis  Basis set (with ECP params). !> @param[in]    coord  Nuclear coordinates (3×natm). !> @param[inout] denab  Packed AO density (size nbf*(nbf+1)/2). !> @param[inout] de     Nuclear gradients (3×natm), incremented by ECP part. !> @note No-op if basis%ecp_params%is_ecp == .false. !> @author Mohsen Mazaherifar !> @date January 2025 subroutine add_ecpder ( basis , coord , denab , de ) real ( real64 ), contiguous , intent ( in ) :: coord (:,:) type ( basis_set ), intent ( in ) :: basis REAL ( kind = dp ), INTENT ( INOUT ) :: denab (:) REAL ( kind = dp ), intent ( INOUT ) :: de (:,:) type ( ecp_result ) :: result_ptr type ( c_ptr ) :: integrator real ( c_double ), pointer :: libecp_res (:) real ( c_double ), allocatable :: raw_block (:), ecp_mat (:) real ( real64 ), allocatable :: deloc (:,:) integer :: i , j , c , n , natm , prim , cc , nbf_raw ! 64-bit: slice offsets reach 3*natm*nbf&#94;2 and overflow default integers integer ( c_int64_t ) :: full_size integer ( c_int ) :: driv_order if (. not .( basis % ecp_params % is_ecp )) then return end if driv_order = 1 nbf_raw = ecp_cart_nbf ( basis ) full_size = int ( nbf_raw , c_int64_t ) * nbf_raw allocate ( raw_block ( full_size )) natm = size ( coord , dim = 2 ) allocate ( deloc ( 3 , natm )) deloc = 0 call set_integrator ( integrator , basis , coord , driv_order ) result_ptr = compute_first_derivs ( integrator ) call c_f_pointer ( result_ptr % data , libecp_res , [ result_ptr % size ]) do n = 1 , natm do cc = 1 , 3 raw_block = libecp_res ( full_size * ( 3 * ( n - 1 ) + cc - 1 ) + 1 : & full_size * ( 3 * ( n - 1 ) + cc )) call transform_ecp_matrix ( basis , raw_block , ecp_mat ) do j = 1 , basis % nbf do i = 1 , j c = j * ( j - 1 ) / 2 + i if ( i == j ) then prim = 1 else prim = 2 end if deloc ( cc , n ) = deloc ( cc , n ) + prim * ecp_mat (( i - 1 ) * basis % nbf + j ) * denab ( c ) end do end do end do end do de (:, 1 : natm ) = de (:, 1 : natm ) + deloc (:, 1 : natm ) ! free the C-side buffer BEFORE nulling the local handle (see add_ecpint) call free_result ( result_ptr ) result_ptr % data = c_null_ptr result_ptr % size = 0 nullify ( libecp_res ) if ( allocated ( ecp_mat )) deallocate ( ecp_mat ) deallocate ( raw_block ) call free_integrator ( integrator ) end subroutine add_ecpder !> @brief Return ECP one-electron first-derivative integrals (uncontracted). !> @detail Computes dV_ECP_{mu,nu}/dR_{I,c} for every atom I and Cartesian !>         direction c using libecpint (deriv order 1), transforms each block !>         to OpenQP AO ordering, and stores the full-square AO matrices into !>         `dVecp(mu,nu,c,I)`.  These are the response counterpart of !>         @ref add_ecpder (which contracts the same integrals with a density); !>         the analytic Hessian adds them into the core-Hamiltonian derivative !>         dHcore/dR so the ECP enters the CPHF right-hand side and the !>         orbital-relaxation response, exactly as nuclear attraction does. !>         Like @ref add_ecpint, the integrals are returned in the OpenQP !>         normalized (density/Hcore) convention, so callers must NOT apply an !>         additional bfnrm scaling. !> @param[in]  basis  Basis set (with ECP params). !> @param[in]  coord  Nuclear coordinates (3 x natm). !> @param[out] dVecp  ECP derivative integrals (nbf x nbf x 3 x natm). !> @note Returns zeros if basis%ecp_params%is_ecp == .false. subroutine ecp_deriv_ints ( basis , coord , dVecp ) real ( real64 ), contiguous , intent ( in ) :: coord (:,:) type ( basis_set ), intent ( in ) :: basis real ( kind = dp ), intent ( out ) :: dVecp (:,:,:,:) type ( ecp_result ) :: result_ptr type ( c_ptr ) :: integrator real ( c_double ), pointer :: libecp_res (:) real ( c_double ), allocatable :: raw_block (:), ecp_mat (:) integer :: nbf , nbf_raw , natm , n , cc , i , j ! 64-bit: slice offsets reach 3*natm*nbf&#94;2 and overflow default integers integer ( c_int64_t ) :: full_size integer ( c_int ) :: driv_order dVecp = 0.0_dp if (. not .( basis % ecp_params % is_ecp )) then return end if driv_order = 1 nbf = basis % nbf nbf_raw = ecp_cart_nbf ( basis ) full_size = int ( nbf_raw , c_int64_t ) * nbf_raw natm = size ( coord , dim = 2 ) allocate ( raw_block ( full_size )) call set_integrator ( integrator , basis , coord , driv_order ) result_ptr = compute_first_derivs ( integrator ) call c_f_pointer ( result_ptr % data , libecp_res , [ result_ptr % size ]) do n = 1 , natm do cc = 1 , 3 raw_block = libecp_res ( full_size * ( 3 * ( n - 1 ) + cc - 1 ) + 1 : & full_size * ( 3 * ( n - 1 ) + cc )) call transform_ecp_matrix ( basis , raw_block , ecp_mat ) do j = 1 , nbf do i = 1 , nbf dVecp ( i , j , cc , n ) = ecp_mat (( i - 1 ) * nbf + j ) end do end do end do end do ! free the C-side buffer BEFORE nulling the local handle (see add_ecpint) call free_result ( result_ptr ) result_ptr % data = c_null_ptr result_ptr % size = 0 nullify ( libecp_res ) if ( allocated ( ecp_mat )) deallocate ( ecp_mat ) call free_integrator ( integrator ) deallocate ( raw_block ) end subroutine ecp_deriv_ints !> @brief Add ECP second-derivative contribution to the nuclear Hessian. !> @detail Computes d&#94;2 V_ECP/dR_I dR_J in AO full-square form for every atom !>         pair using libecpint (deriv order 2), transforms each block to !>         OpenQP AO ordering, and contracts with the symmetric density !>         `denab` (packed) to accumulate the fixed-density ECP skeleton into !>         the Cartesian Hessian `hess` (3*natm x 3*natm, atom-major layout !>         hess(3*(I-1)+a, 3*(J-1)+b)). !> !>         libecpint returns the packed upper triangle of atom-coordinate !>         pairs: matrix index H_START(I,J,natm) (0-based) starts each (I<=J) !>         atom block.  Diagonal blocks (I==J) store 6 matrices in the order !>         {xx,xy,xz,yy,yz,zz}; off-diagonal blocks (I<J) store 9 matrices in !>         row-major {xx,xy,xz,yx,yy,yz,zx,zy,zz} (first index = coordinate of !>         atom I, second = coordinate of atom J).  Each block is the AO matrix !>         packed M(k,l) = (k-1)*nbf + l.  We scatter symmetrically so the !>         returned Hessian is exactly symmetric. !> @param[in]    basis  Basis set (with ECP params). !> @param[in]    coord  Nuclear coordinates (3 x natm). !> @param[in]    denab  Packed AO density (size nbf*(nbf+1)/2), upper triangle. !> @param[inout] hess   Cartesian Hessian (3*natm x 3*natm), incremented by ECP. !> @note No-op if basis%ecp_params%is_ecp == .false. subroutine add_ecphess ( basis , coord , denab , hess ) real ( real64 ), contiguous , intent ( in ) :: coord (:,:) type ( basis_set ), intent ( in ) :: basis real ( kind = dp ), intent ( in ) :: denab (:) real ( kind = dp ), intent ( inout ) :: hess (:,:) type ( ecp_result ) :: result_ptr type ( c_ptr ) :: integrator real ( c_double ), pointer :: libecp_res (:) real ( c_double ), allocatable :: raw_block (:), ecp_mat (:) integer :: nbf , nbf_raw , natm integer :: iat , jat , ia0 , ja0 , hstart , base , ncomp , n integer :: a , b , i , j , c , prim ! 64-bit: block offsets reach 3N(3N+1)/2 * nbf&#94;2 and overflow default integers integer ( c_int64_t ) :: mat_sz integer ( c_int ) :: driv_order integer :: amap ( 9 ), bmap ( 9 ) real ( real64 ) :: val if (. not .( basis % ecp_params % is_ecp )) then return end if driv_order = 2 nbf = basis % nbf nbf_raw = ecp_cart_nbf ( basis ) mat_sz = int ( nbf_raw , c_int64_t ) * nbf_raw natm = size ( coord , dim = 2 ) allocate ( raw_block ( mat_sz )) call set_integrator ( integrator , basis , coord , driv_order ) result_ptr = compute_second_derivs ( integrator ) call c_f_pointer ( result_ptr % data , libecp_res , [ result_ptr % size ]) do iat = 1 , natm do jat = iat , natm ia0 = iat - 1 ja0 = jat - 1 ! 0-based starting matrix index of the (iat,jat) atom block hstart = 9 * ja0 + 3 * ( 3 * natm - 1 ) * ia0 - ( 9 * ia0 * ( ia0 + 1 )) / 2 - 3 if ( iat == jat ) then base = hstart + 3 ncomp = 6 amap ( 1 : 6 ) = [ 1 , 1 , 1 , 2 , 2 , 3 ] bmap ( 1 : 6 ) = [ 1 , 2 , 3 , 2 , 3 , 3 ] else base = hstart ncomp = 9 amap ( 1 : 9 ) = [ 1 , 1 , 1 , 2 , 2 , 2 , 3 , 3 , 3 ] bmap ( 1 : 9 ) = [ 1 , 2 , 3 , 1 , 2 , 3 , 1 , 2 , 3 ] end if do n = 1 , ncomp raw_block = libecp_res (( base + n - 1 ) * mat_sz + 1 : ( base + n - 1 ) * mat_sz + mat_sz ) call transform_ecp_matrix ( basis , raw_block , ecp_mat ) val = 0.0_dp do j = 1 , nbf do i = 1 , j c = j * ( j - 1 ) / 2 + i if ( i == j ) then prim = 1 else prim = 2 end if val = val + prim * ecp_mat (( i - 1 ) * nbf + j ) * denab ( c ) end do end do a = amap ( n ) b = bmap ( n ) hess ( 3 * ( iat - 1 ) + a , 3 * ( jat - 1 ) + b ) = & hess ( 3 * ( iat - 1 ) + a , 3 * ( jat - 1 ) + b ) + val ! symmetric partner (skip if it is the same matrix element) if (. not . ( iat == jat . and . a == b )) then hess ( 3 * ( jat - 1 ) + b , 3 * ( iat - 1 ) + a ) = & hess ( 3 * ( jat - 1 ) + b , 3 * ( iat - 1 ) + a ) + val end if end do end do end do ! free the C-side buffer BEFORE nulling the local handle (see add_ecpint) call free_result ( result_ptr ) result_ptr % data = c_null_ptr result_ptr % size = 0 nullify ( libecp_res ) if ( allocated ( ecp_mat )) deallocate ( ecp_mat ) call free_integrator ( integrator ) deallocate ( raw_block ) end subroutine add_ecphess !> @brief Construct and initialize a libecpint integrator instance. !> @detail Marshals Gaussian basis (centers, exponents, contractions, AMs) and !>         ECP basis (centers, exponents, coefficients, AMs, powers) from !>         OpenQP’s `basis_set` into libecpint arrays, assigns the ECP data, !>         and finalizes the integrator for the requested derivative order. !> @param[out] integrator    Opaque libecpint handle (C pointer). !> @param[in]  basis         Basis + ECP data. !> @param[in]  coord         Nuclear coordinates (3×natm). !> @param[in]  deriv_order   0 = value, 1 = first derivatives. !> @pre `basis%ecp_params` fields are allocated when is_ecp is true. !> @author Mohsen Mazaherifar !> @date January 2025 subroutine set_integrator ( integrator , basis , coord , deriv_order ) real ( c_double ), intent ( in ), contiguous :: coord (:,:) type ( basis_set ), intent ( in ) :: basis integer ( c_int ), intent ( in ) :: deriv_order type ( c_ptr ) :: integrator real ( c_double ), allocatable :: g_coords (:), g_exps (:), g_coefs (:) integer ( c_int ), allocatable :: g_ams (:), g_lengths (:) real ( c_double ), allocatable :: u_coords (:), u_exps (:), u_coefs (:) integer ( c_int ), allocatable :: u_ams (:), u_ns (:), u_lengths (:) integer ( c_int ) :: num_ecps , num_gaussians , n_coord , f_expo_len integer :: tri_size , full_size , natm tri_size = basis % nbf * ( basis % nbf + 1 ) / 2 full_size = basis % nbf * basis % nbf f_expo_len = sum ( basis % ecp_params % n_expo ) natm = size ( coord , dim = 2 ) num_gaussians = basis % nshell n_coord = num_gaussians * 3 allocate ( g_coords ( n_coord ), g_exps ( basis % nprim ), g_coefs ( basis % nprim )) allocate ( g_ams ( basis % nshell ), g_lengths ( basis % nshell )) allocate ( u_coords ( size ( basis % ecp_params % ecp_coord )), u_exps ( f_expo_len )) allocate ( u_coefs ( f_expo_len ), u_ams ( f_expo_len )) allocate ( u_ns ( f_expo_len ), u_lengths ( size ( basis % ecp_params % n_expo ))) call libecp_g_coords ( basis , coord , g_coords ) g_exps = real ( basis % ex , kind = c_double ) g_coefs = real ( basis % cc , kind = c_double ) g_ams = int ( basis % am , kind = c_int ) g_lengths = int ( basis % ncontr , kind = c_int ) num_ecps = int ( size ( basis % ecp_params % n_expo ), kind = c_int ) u_coords = real ( basis % ecp_params % ecp_coord , kind = c_double ) u_exps = real ( basis % ecp_params % ecp_ex , kind = c_double ) u_coefs = real ( basis % ecp_params % ecp_cc , kind = c_double ) u_ams = int ( basis % ecp_params % ecp_am , kind = c_int ) u_ns = int ( basis % ecp_params % ecp_r_ex , kind = c_int ) u_lengths = int ( basis % ecp_params % n_expo , kind = c_int ) integrator = init_integrator ( num_gaussians , g_coords , g_exps , g_coefs , & g_ams , g_lengths ) call set_ecp_basis ( integrator , num_ecps , u_coords , u_exps , u_coefs , & u_ams , u_ns , u_lengths ) call init_integrator_instance ( integrator , deriv_order ) end subroutine set_integrator !> @brief Build AO index remapping from libecpint canonical order to OpenQP AO order. !> @detail Fills `label_map(i_old)=i_new` using shell origins and angular-momentum !>         layout so that full-square AO matrices can be permuted consistently. !> @param[in]    basis     Basis set (AO layout and shell metadata). !> @param[inout] label_map Integer array of length nbf receiving the permutation. !> @see transform_ecp_matrix !> @author Mohsen Mazaherifar !> @date January 2025 integer function ecp_cart_nbf ( basis ) result ( nbf_cart ) type ( basis_set ), intent ( in ) :: basis integer :: ish nbf_cart = 0 do ish = 1 , basis % nshell nbf_cart = nbf_cart + NUM_CART_BF ( basis % am ( ish )) end do end function ecp_cart_nbf subroutine ecp_cart_offsets ( basis , cart_off , nbf_cart ) type ( basis_set ), intent ( in ) :: basis integer , allocatable , intent ( out ) :: cart_off (:) integer , intent ( out ) :: nbf_cart integer :: ish allocate ( cart_off ( basis % nshell )) nbf_cart = 0 do ish = 1 , basis % nshell cart_off ( ish ) = nbf_cart + 1 nbf_cart = nbf_cart + NUM_CART_BF ( basis % am ( ish )) end do end subroutine ecp_cart_offsets subroutine libecpint_map ( basis , cart_off , label_map ) use basis_tools , only : basis_set use constants , only : map_canonical type ( basis_set ), intent ( in ) :: basis integer , dimension (:), intent ( in ) :: cart_off integer , dimension (:), intent ( inout ) :: label_map integer :: ish , i , old label_map = 0 do ish = 1 , basis % nshell do i = 1 , NUM_CART_BF ( basis % am ( ish )) old = cart_off ( ish ) + i - 1 label_map ( old + map_canonical ( i , basis % am ( ish ))) = old end do end do end  subroutine libecpint_map !> @brief Pack Gaussian-center coordinates per shell for libecpint. !> @detail Writes (x,y,z) per shell index using `basis%origin(shell)` to select !>         the parent atom for the shell center as expected by libecpint. !> @param[in]  basis    Basis set. !> @param[in]  coord    Nuclear coordinates (3×natm). !> @param[out] g_coords Flat array of size 3*nshell: [x1,y1,z1, x2,y2,z2, ...]. !> @note Coordinates are cast to C double precision for the C API. !> @author Mohsen Mazaherifar !> @date January 2025 subroutine libecp_g_coords ( basis , coord , g_coords ) type ( basis_set ), intent ( in ) :: basis real ( real64 ), intent ( in ) :: coord (:,:) real ( c_double ), intent ( out ) :: g_coords (:) integer :: shell do shell = 1 , basis % nshell g_coords ( 3 * shell - 2 : 3 * shell ) = real ( coord ( 1 : 3 , basis % origin ( shell )), c_double ) end do end subroutine libecp_g_coords !> @brief Permute a full AO square matrix into OpenQP AO ordering. !> @detail Applies the mapping from @ref libecpint_map to reorder rows/cols !>         of `matrix` in-place (via a temporary copy). Expects size nbf×nbf. !> @param[in]    basis   Basis set (provides AO label map). !> @param[inout] matrix  Full AO square matrix flattened (size nbf*nbf). !> @throws Stops if `size(matrix) != nbf*nbf`. !> @see libecpint_map !> @author Mohsen Mazaherifar !> @date January 2025 subroutine transform_ecp_matrix ( basis , raw_matrix , matrix ) use basis_tools , only : basis_set use cart2sph , only : cart2sph_mat type ( basis_set ), intent ( in ) :: basis real ( c_double ), dimension (:), intent ( in ) :: raw_matrix real ( c_double ), dimension (:), allocatable , intent ( out ) :: matrix real ( c_double ), dimension (:), allocatable :: cart_matrix real ( c_double ), dimension (:), allocatable :: blk integer , dimension (:), allocatable :: label_map integer , allocatable :: cart_off (:) integer :: i , j , row , col , nbf_raw , nbf_sph integer :: ish , jsh , nci , ncj , nsi , nsj , coi , coj , soi , soj integer :: si , sj , max_blk , pure_i , pure_j call ecp_cart_offsets ( basis , cart_off , nbf_raw ) nbf_sph = basis % nbf allocate ( label_map ( nbf_raw )) if ( size ( raw_matrix ) /= nbf_raw * nbf_raw ) then print * , \"Error: original_matrix size does not match labels.\" stop end if call libecpint_map ( basis , cart_off , label_map ) allocate ( cart_matrix ( nbf_raw * nbf_raw )) allocate ( matrix ( nbf_sph * nbf_sph )) cart_matrix = 0.0_dp matrix = 0.0_dp do i = 1 , nbf_raw do j = 1 , nbf_raw row = label_map ( i ) col = label_map ( j ) cart_matrix (( row - 1 ) * nbf_raw + col ) = raw_matrix (( i - 1 ) * nbf_raw + j ) end do end do max_blk = 0 do ish = 1 , basis % nshell do jsh = 1 , basis % nshell max_blk = max ( max_blk , NUM_CART_BF ( basis % am ( ish )) * NUM_CART_BF ( basis % am ( jsh ))) end do end do allocate ( blk ( max_blk )) do ish = 1 , basis % nshell nci = NUM_CART_BF ( basis % am ( ish )) nsi = basis % naos ( ish ) coi = cart_off ( ish ) soi = basis % ao_offset ( ish ) if ( HARMONIC_ACTIVE ) then pure_i = basis % harmonic ( ish ) else pure_i = 0 end if do jsh = 1 , basis % nshell ncj = NUM_CART_BF ( basis % am ( jsh )) nsj = basis % naos ( jsh ) coj = cart_off ( jsh ) soj = basis % ao_offset ( jsh ) if ( HARMONIC_ACTIVE ) then pure_j = basis % harmonic ( jsh ) else pure_j = 0 end if do si = 1 , nci do sj = 1 , ncj blk (( si - 1 ) * ncj + sj ) = cart_matrix (( coi + si - 2 ) * nbf_raw + coj + sj - 1 ) end do end do ! libecpint blocks are in the same pure-power Cartesian convention as ! the native 1e primitives (bas_norm_matrix folds shells_pnrm2 for ! Cartesian shells later, but bfnrm = 1 for pure shells), so the ! transform must fold shells_pnrm2 along each pure index itself. call cart2sph_mat ( blk , basis % am ( jsh ), pure_j , basis % am ( ish ), pure_i ) do si = 1 , nsi do sj = 1 , nsj matrix (( soi + si - 2 ) * nbf_sph + soj + sj - 1 ) = blk (( si - 1 ) * nsj + sj ) end do end do end do end do end subroutine transform_ecp_matrix end module ecp_tool","tags":"","url":"sourcefile/ecp.f90.html"},{"title":"strings.F90 – OpenQP Fortran API","text":"Source Code module strings use , intrinsic :: iso_c_binding , only : c_ptr , c_int64_t implicit none private character ( * ), parameter , public :: & ALPHANUM = 'abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789_' & , AN_DASH = 'abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789_-' integer , parameter :: & A_LOWER = iachar ( 'a' ), & Z_LOWER = iachar ( 'z' ), & A_UPPER = iachar ( 'A' ), & Z_UPPER = iachar ( 'Z' ), & UPPER_TO_LOWER = A_LOWER - A_UPPER public :: to_upper , to_lower , count_substring , remove_spaces , index_ith , fstring public :: f_c_char public :: c_f_char character , target :: char_empty = '' type , public :: tokenizer_t character (:), pointer :: str => null () character (:), pointer :: delims => null () contains procedure :: get => next_token end type type , public , bind ( C ) :: Cstring integer ( c_int64_t ) :: length type ( c_ptr ) :: string end type Cstring contains !> @brief  Split string on tokens, delimiting by specified set of symbols !> @author Vladimir Mironov !> @date   Sept, 2021 !> @param  this   [inout] `tokenizer_t` instance !> @param  str    [in]    optional, input string !> @param  delim  [in]    optional, string containing delimiter symbols, default='' !> @param  result         pointer to the next token !> @note   Delimiter instance saves its state after `str` and `delim` has been set up. !>         At each successfull call user can redefine `delim` string !>         The behavior is similar to C `strtok` function. !>         Returns null pointer when line ends and resets `tokenizer_t` internal state. !>         Example usage: !>         ```fortran !>         type(tokenizer_t) :: tokz !>         character(:), pointer :: ptr !>         ptr => tokz%get(str, ' ;,') !>         do while (associated(ptr)) !>           print *, ptr !>           ptr => tokz%get() !>         end do !>         ``` !> @note   Do not use for csv reading! function next_token ( this , str , delim ) result ( res ) class ( tokenizer_t ) :: this character ( * ), target , intent ( in ), optional :: str character ( * ), target , intent ( in ), optional :: delim character (:), pointer :: res integer :: pos_start , res_len , pos_end character (:), pointer :: temp_str res => null () if ( present ( str )) then nullify ( this % str ) this % str => str end if if ( present ( delim )) then if ( len ( delim ) /= 0 ) then this % delims => delim end if end if if ( len ( this % str ) == 0 ) then nullify ( this % str ) this % delims => char_empty return end if if (. not . associated ( this % str )) return if (. not . associated ( this % delims )) then this % delims => char_empty end if pos_start = verify ( this % str , this % delims ) if ( pos_start == 0 ) then nullify ( this % str ) this % delims => char_empty return end if res_len = scan ( this % str ( pos_start :), this % delims ) - 1 temp_str => this % str ( pos_start :) if ( res_len < 0 ) res_len = len ( temp_str ) nullify ( temp_str ) pos_end = pos_start + res_len res => this % str ( pos_start : pos_end - 1 ) this % str => this % str ( pos_end + 1 :) end function next_token !> @brief  return string in upper case !> @author Igor S. Gerasimov !> @date   Sep, 2019 --Initial release-- !> @date   May, 2021 Moved to strings !> @date   Sep, 2021 subroutine -> function !> @param  line - (in) pure function to_upper ( input_string ) result ( output_string ) character ( * ), intent ( in ) :: input_string character (:), allocatable :: output_string integer :: i , ic output_string = input_string do i = 1 , len ( output_string ) ic = iachar ( output_string ( i : i )) if ( ic <= Z_LOWER . and . ic >= A_LOWER ) then output_string ( i : i ) = achar ( ic - UPPER_TO_LOWER ) end if end do end function to_upper !> @brief  return string in lower case !> @author Igor S. Gerasimov !> @date   Sep, 2021 --Initial release-- !> @param  line - (inout) pure function to_lower ( input_string ) result ( output_string ) character ( * ), intent ( in ) :: input_string character (:), allocatable :: output_string integer :: i , ic output_string = input_string do i = 1 , len ( output_string ) ic = iachar ( output_string ( i : i )) if ( ic <= Z_UPPER . and . ic >= A_UPPER ) then output_string ( i : i ) = achar ( ic + UPPER_TO_LOWER ) end if end do end function to_lower !> @brief  This function return count of substring in string !> @author Igor S. Gerasimov !> @date   Sep, 2019 --Initial release-- !> @date   May, 2021 Moved to strings !> @param  substring - (in) !> @param  string    - (in) pure integer function count_substring ( substring , string ) result ( res ) character ( len =* ), intent ( in ) :: substring , string ! internal variables character ( len = :), allocatable :: tmp_string res = 0 tmp_string = string do if ( index ( tmp_string , substring ) == 0 ) exit res = res + 1 tmp_string = tmp_string ( index ( tmp_string , substring ) + 1 :) end do return end function count_substring !> @brief  This routine remove not needed spaces from section line !> @detail This routine used revert reading of lines. !>         Example, that this routine do: !>       > DFTTYP = PBE0 BASNAM=APC4 , ACC5 !>       < DFTTYP=PBE0 BASNAM=APC4,ACC5 !> @author Igor S. Gerasimov !> @date   Sep, 2019 --Initial release-- !> @date   May, 2021 Moved to strings !> @param  line - (inout) worked line pure subroutine remove_spaces ( line ) character ( len = :), allocatable , intent ( inout ) :: line ! internal variables character ( len = :), allocatable :: tmp_line , res_line integer :: i , ind , ind_end logical :: skip , first tmp_line = line line = \"\" do res_line = \"\" ind_end = index ( tmp_line , \"=\" ) first = . true . skip = . false . ind = ind_end if ( ind == 0 ) ind = len ( tmp_line ) do i = ind , 1 , - 1 if ( tmp_line ( i : i ) /= \" \" ) then res_line = tmp_line ( i : i ) // res_line if ( tmp_line ( i : i ) /= \"=\" . and . first . and . ind_end /= 0 ) then skip = . true . first = . false . end if else if ( skip ) then res_line = \" \" // res_line skip = . false . end if end do line = line // trim ( adjustl ( res_line )) if ( ind_end == 0 ) exit tmp_line = tmp_line ( ind + 1 :) end do end subroutine remove_spaces !> @brief   This function return index of i'th substring in string !> @details if ind is negative, backward search will be !>          result is equal 0 if search was failed !> @author  Igor S. Gerasimov !> @date    May, 2021 --Initial release-- !> @param   substring - (in) !> @param   string    - (in) !> @param   ith       - (in) index of needed substring pure integer function index_ith ( substring , string , ith ) result ( res ) character ( len =* ), intent ( in ) :: substring , string integer , intent ( in ) :: ith ! internal variables character ( len = :), allocatable :: tmp_string integer :: i , diff res = 0 tmp_string = string if ( ith > 0 ) then do i = 1 , ith diff = index ( tmp_string , substring ) res = res + diff if ( diff == 0 ) then res = 0 exit end if tmp_string = tmp_string ( index ( tmp_string , substring ) + 1 :) end do else if ( ith < 0 ) then do i = - 1 , ith , - 1 res = index ( tmp_string , substring , back = . true .) if ( res == 0 ) exit tmp_string = tmp_string (: index ( tmp_string , substring , back = . true .) - 1 ) end do else res = 0 end if end function index_ith !> @brief   This function return fortran allocatable string !> @author  Igor S. Gerasimov !> @date    April, 2022 --Initial release-- !> @param   string    - (in) C-like string function fstring ( string ) result ( res ) use , intrinsic :: iso_c_binding , only : c_f_pointer , c_char type ( Cstring ), intent ( in ) :: string character ( len = :), allocatable :: res character ( len = 1 , kind = c_char ), pointer :: fpstring (:) ! internal variables integer :: i allocate ( character ( len = string % length ) :: res ) call c_f_pointer ( string % string , fpstring , shape = [ string % length ]) do i = 1 , string % length res ( i : i ) = fpstring ( i ) end do end function fstring !> @brief Convert Fortran string to a raw null-terminated C-string !> @note No real boundary checks for c-string are performed, use at your own risk! !> @note C-string should be already allocated !> @param[in]   from    fortran string !> @param[out]  to      null-terminated c-string, len(to) should be at least numchar+1 !> @param[in]   numchar maximum number of characters to pass from fortran to c-string subroutine f_c_char ( from , to , numchar ) use , intrinsic :: iso_c_binding , only : c_char , c_null_char character ( len =* ), intent ( in ) :: from character ( kind = c_char , len = 1 ) :: to ( * ) integer , intent ( in ) :: numchar integer :: i do i = 1 , min ( len ( from ), numchar ) to ( i ) = from ( i : i ) end do to ( i ) = c_null_char end subroutine f_c_char !> @brief Convert raw null-terminated C-string to Fortran string !> @note No boundary checks for c-string are performed, use at your own risk! function c_f_char ( cchar ) result ( fstr ) use , intrinsic :: iso_c_binding , only : c_char , c_null_char character ( kind = c_char ), intent ( in ) :: cchar ( * ) character (:), allocatable :: fstr integer :: i , strlen strlen = 0 do if ( cchar ( strlen + 1 ) == c_null_char ) exit strlen = strlen + 1 end do allocate ( character ( strlen ) :: fstr ) do i = 1 , strlen fstr ( i : i ) = cchar ( i ) end do end function c_f_char end module strings","tags":"","url":"sourcefile/strings.f90.html"},{"title":"cart2sph.F90 – OpenQP Fortran API","text":"Source Code !> @brief   Cartesian -> pure spherical-harmonic (c2s) transforms for shells. !> !> @details Provides the per-shell transform matrices B(l) that map the !>          unit-normalized Cartesian components of a shell (OpenQP's !>          canonical bf_names order; see constants::CART_X/Y/Z) onto the !>          2l+1 real solid harmonics in CCA/libint order (m = -l..+l). !> !>          Convention is identical to the validated Python reference in !>          pyoqp/oqp/library/symmetry.py (_solid_harmonic_coefficients): !>          each column of C2S_x holds the Cartesian coefficients of one !>          spherical component, orthonormal against the intra-shell metric !>          S of unit-normalized Cartesian Gaussians (B S B&#94;T = I). The !>          matrices below were generated from that reference and are !>          re-verified at runtime by c2s_selftest(). !> !>          The transform is applied to integrals that are already in the !>          unit-normalized Cartesian basis (e.g. 2e blocks AFTER the !>          rotation/Rys/libint normalization in int2::shellquartet, where !>          all backends agree). s and p shells are passed through unchanged !>          (Cartesian == spherical up to the trivial 1:1 / 3:3 mapping). module cart2sph use precision , only : dp use constants , only : NUM_CART_BF , NUM_SPH_BF , BAS_MXANG implicit none private public :: c2s_ncomp public :: cart2sph_eri public :: cart2sph_mat public :: cart2sph_mat_unit public :: cart2sph_vec public :: c2s_expand_block public :: c2s_expansion_matrix public :: c2s_selftest ! l=2 (D): Cart(6) -> Sph(5); column i = Cartesian coeffs of spherical i (m=-l..+l) real ( dp ), parameter :: C2S_D ( 6 , 5 ) = reshape ([ & 0.000000000000000e+00_dp , 0.000000000000000e+00_dp , 0.000000000000000e+00_dp , 1.000000000000000e+00_dp , 0.000000000000000e+00_dp , 0.000000000000000e+00_dp , & 0.000000000000000e+00_dp , 0.000000000000000e+00_dp , 0.000000000000000e+00_dp , 0.000000000000000e+00_dp , 0.000000000000000e+00_dp , 1.000000000000000e+00_dp , & - 4.999999999999999e-01_dp , - 4.999999999999999e-01_dp , 9.999999999999999e-01_dp , 0.000000000000000e+00_dp , 0.000000000000000e+00_dp , 0.000000000000000e+00_dp , & 0.000000000000000e+00_dp , 0.000000000000000e+00_dp , 0.000000000000000e+00_dp , 0.000000000000000e+00_dp , 1.000000000000000e+00_dp , 0.000000000000000e+00_dp , & 8.660254037844386e-01_dp , - 8.660254037844386e-01_dp , 0.000000000000000e+00_dp , 0.000000000000000e+00_dp , 0.000000000000000e+00_dp , 0.000000000000000e+00_dp & ], shape = [ 6 , 5 ]) ! l=3 (F): Cart(10) -> Sph(7); column i = Cartesian coeffs of spherical i (m=-l..+l) real ( dp ), parameter :: C2S_F ( 10 , 7 ) = reshape ([ & 0.000000000000000e+00_dp , - 7.905694150420950e-01_dp , 0.000000000000000e+00_dp , 1.060660171779821e+00_dp , 0.000000000000000e+00_dp , 0.000000000000000e+00_dp , 0.000000000000000e+00_dp , 0.000000000000000e+00_dp , 0.000000000000000e+00_dp , 0.000000000000000e+00_dp , & 0.000000000000000e+00_dp , 0.000000000000000e+00_dp , 0.000000000000000e+00_dp , 0.000000000000000e+00_dp , 0.000000000000000e+00_dp , 0.000000000000000e+00_dp , 0.000000000000000e+00_dp , 0.000000000000000e+00_dp , 0.000000000000000e+00_dp , 1.000000000000000e+00_dp , & 0.000000000000000e+00_dp , - 6.123724356957946e-01_dp , 0.000000000000000e+00_dp , - 2.738612787525830e-01_dp , 0.000000000000000e+00_dp , 0.000000000000000e+00_dp , 0.000000000000000e+00_dp , 0.000000000000000e+00_dp , 1.095445115010332e+00_dp , 0.000000000000000e+00_dp , & 0.000000000000000e+00_dp , 0.000000000000000e+00_dp , 1.000000000000000e+00_dp , 0.000000000000000e+00_dp , - 6.708203932499369e-01_dp , 0.000000000000000e+00_dp , - 6.708203932499369e-01_dp , 0.000000000000000e+00_dp , 0.000000000000000e+00_dp , 0.000000000000000e+00_dp , & - 6.123724356957946e-01_dp , 0.000000000000000e+00_dp , 0.000000000000000e+00_dp , 0.000000000000000e+00_dp , 0.000000000000000e+00_dp , - 2.738612787525830e-01_dp , 0.000000000000000e+00_dp , 1.095445115010332e+00_dp , 0.000000000000000e+00_dp , 0.000000000000000e+00_dp , & 0.000000000000000e+00_dp , 0.000000000000000e+00_dp , 0.000000000000000e+00_dp , 0.000000000000000e+00_dp , 8.660254037844385e-01_dp , 0.000000000000000e+00_dp , - 8.660254037844385e-01_dp , 0.000000000000000e+00_dp , 0.000000000000000e+00_dp , 0.000000000000000e+00_dp , & 7.905694150420950e-01_dp , 0.000000000000000e+00_dp , 0.000000000000000e+00_dp , 0.000000000000000e+00_dp , 0.000000000000000e+00_dp , - 1.060660171779821e+00_dp , 0.000000000000000e+00_dp , 0.000000000000000e+00_dp , 0.000000000000000e+00_dp , 0.000000000000000e+00_dp & ], shape = [ 10 , 7 ]) ! l=4 (G): Cart(15) -> Sph(9); column i = Cartesian coeffs of spherical i (m=-l..+l) real ( dp ), parameter :: C2S_G ( 15 , 9 ) = reshape ([ & 0.000000000000000e+00_dp , 0.000000000000000e+00_dp , 0.000000000000000e+00_dp , 1.118033988749895e+00_dp , 0.000000000000000e+00_dp , - 1.118033988749895e+00_dp , 0.000000000000000e+00_dp , 0.000000000000000e+00_dp , 0.000000000000000e+00_dp , 0.000000000000000e+00_dp , 0.000000000000000e+00_dp , 0.000000000000000e+00_dp , 0.000000000000000e+00_dp , 0.000000000000000e+00_dp , 0.000000000000000e+00_dp , & 0.000000000000000e+00_dp , 0.000000000000000e+00_dp , 0.000000000000000e+00_dp , 0.000000000000000e+00_dp , 0.000000000000000e+00_dp , 0.000000000000000e+00_dp , - 7.905694150420950e-01_dp , 0.000000000000000e+00_dp , 0.000000000000000e+00_dp , 0.000000000000000e+00_dp , 0.000000000000000e+00_dp , 0.000000000000000e+00_dp , 1.060660171779821e+00_dp , 0.000000000000000e+00_dp , 0.000000000000000e+00_dp , & 0.000000000000000e+00_dp , 0.000000000000000e+00_dp , 0.000000000000000e+00_dp , - 4.225771273642583e-01_dp , 0.000000000000000e+00_dp , - 4.225771273642583e-01_dp , 0.000000000000000e+00_dp , 0.000000000000000e+00_dp , 0.000000000000000e+00_dp , 0.000000000000000e+00_dp , 0.000000000000000e+00_dp , 0.000000000000000e+00_dp , 0.000000000000000e+00_dp , 0.000000000000000e+00_dp , 1.133893419027681e+00_dp , & 0.000000000000000e+00_dp , 0.000000000000000e+00_dp , 0.000000000000000e+00_dp , 0.000000000000000e+00_dp , 0.000000000000000e+00_dp , 0.000000000000000e+00_dp , - 8.964214570007953e-01_dp , 0.000000000000000e+00_dp , 1.195228609334394e+00_dp , 0.000000000000000e+00_dp , 0.000000000000000e+00_dp , 0.000000000000000e+00_dp , - 4.008918628686365e-01_dp , 0.000000000000000e+00_dp , 0.000000000000000e+00_dp , & 3.749999999999999e-01_dp , 3.749999999999999e-01_dp , 9.999999999999998e-01_dp , 0.000000000000000e+00_dp , 0.000000000000000e+00_dp , 0.000000000000000e+00_dp , 0.000000000000000e+00_dp , 0.000000000000000e+00_dp , 0.000000000000000e+00_dp , 2.195775164134199e-01_dp , - 8.783100656536798e-01_dp , - 8.783100656536798e-01_dp , 0.000000000000000e+00_dp , 0.000000000000000e+00_dp , 0.000000000000000e+00_dp , & 0.000000000000000e+00_dp , 0.000000000000000e+00_dp , 0.000000000000000e+00_dp , 0.000000000000000e+00_dp , - 8.964214570007953e-01_dp , 0.000000000000000e+00_dp , 0.000000000000000e+00_dp , 1.195228609334394e+00_dp , 0.000000000000000e+00_dp , 0.000000000000000e+00_dp , 0.000000000000000e+00_dp , 0.000000000000000e+00_dp , 0.000000000000000e+00_dp , - 4.008918628686365e-01_dp , 0.000000000000000e+00_dp , & - 5.590169943749475e-01_dp , 5.590169943749475e-01_dp , 0.000000000000000e+00_dp , 0.000000000000000e+00_dp , 0.000000000000000e+00_dp , 0.000000000000000e+00_dp , 0.000000000000000e+00_dp , 0.000000000000000e+00_dp , 0.000000000000000e+00_dp , 0.000000000000000e+00_dp , 9.819805060619657e-01_dp , - 9.819805060619657e-01_dp , 0.000000000000000e+00_dp , 0.000000000000000e+00_dp , 0.000000000000000e+00_dp , & 0.000000000000000e+00_dp , 0.000000000000000e+00_dp , 0.000000000000000e+00_dp , 0.000000000000000e+00_dp , 7.905694150420950e-01_dp , 0.000000000000000e+00_dp , 0.000000000000000e+00_dp , 0.000000000000000e+00_dp , 0.000000000000000e+00_dp , 0.000000000000000e+00_dp , 0.000000000000000e+00_dp , 0.000000000000000e+00_dp , 0.000000000000000e+00_dp , - 1.060660171779821e+00_dp , 0.000000000000000e+00_dp , & 7.395099728874520e-01_dp , 7.395099728874520e-01_dp , 0.000000000000000e+00_dp , 0.000000000000000e+00_dp , 0.000000000000000e+00_dp , 0.000000000000000e+00_dp , 0.000000000000000e+00_dp , 0.000000000000000e+00_dp , 0.000000000000000e+00_dp , - 1.299038105676658e+00_dp , 0.000000000000000e+00_dp , 0.000000000000000e+00_dp , 0.000000000000000e+00_dp , 0.000000000000000e+00_dp , 0.000000000000000e+00_dp & ], shape = [ 15 , 9 ]) contains !> @brief AO component count for a shell, honoring its harmonic flag. elemental integer function c2s_ncomp ( l , pure ) result ( n ) integer , intent ( in ) :: l , pure if ( pure == 1 . and . l >= 2 ) then n = NUM_SPH_BF ( l ) else n = NUM_CART_BF ( l ) end if end function c2s_ncomp !> @brief Return the c2s matrix B(l) (ncart x nsph) for a pure shell. !> @details Only l >= 2 carries a non-trivial transform. Caller guarantees !>          l >= 2 (s/p never reach here because c2s_ncomp keeps them !>          Cartesian). The result is a copy sized (NUM_CART_BF(l), 2l+1). subroutine c2s_get ( l , b ) integer , intent ( in ) :: l real ( dp ), allocatable , intent ( out ) :: b (:,:) real ( dp ), allocatable , save :: c2s_h (:,:), c2s_i (:,:) select case ( l ) case ( 2 ) b = C2S_D case ( 3 ) b = C2S_F case ( 4 ) b = C2S_G case ( 5 ) if (. not . allocated ( c2s_h )) c2s_h = c2s_build ( l ) b = c2s_h case ( 6 ) if (. not . allocated ( c2s_i )) c2s_i = c2s_build ( l ) b = c2s_i case default error stop 'cart2sph: requested angular momentum exceeds BAS_MXANG' end select end subroutine c2s_get !> @brief Build B(l) for higher shells from the closed-form real solid-harmonic !>        expansion used to generate the checked d/f/g tables above. function c2s_build ( l ) result ( b ) use constants , only : CART_X , CART_Y , CART_Z integer , intent ( in ) :: l real ( dp ), allocatable :: b (:,:) integer :: nc , ns , col , m , am , t , u , k , k_start , ax , ay , az integer :: sign_pow , cidx , ic , jc real ( dp ), allocatable :: metric (:,:), row (:) real ( dp ) :: coeff , norm2 nc = NUM_CART_BF ( l ) ns = NUM_SPH_BF ( l ) allocate ( b ( nc , ns ), metric ( nc , nc ), row ( nc )) do ic = 1 , nc do jc = 1 , nc metric ( ic , jc ) = cart_overlap ( CART_X ( ic , l ), CART_Y ( ic , l ), CART_Z ( ic , l ), & CART_X ( jc , l ), CART_Y ( jc , l ), CART_Z ( jc , l )) end do end do col = 0 do m = - l , l col = col + 1 am = abs ( m ) row = 0.0_dp do t = 0 , ( l - am ) / 2 do u = 0 , t k_start = merge ( 0 , 1 , m >= 0 ) do k = k_start , am , 2 sign_pow = t + ( k - k_start ) / 2 coeff = merge ( 1.0_dp , - 1.0_dp , mod ( sign_pow , 2 ) == 0 ) & * ( 0.25_dp ** t ) & * real ( ibinom ( l , t ), dp ) & * real ( ibinom ( l - t , am + t ), dp ) & * real ( ibinom ( t , u ), dp ) & * real ( ibinom ( am , k ), dp ) if ( coeff == 0.0_dp ) cycle ax = 2 * t + am - 2 * u - k ay = 2 * u + k az = l - 2 * t - am if ( ax < 0 . or . ay < 0 . or . az < 0 ) cycle cidx = cart_index ( l , ax , ay , az ) row ( cidx ) = row ( cidx ) + coeff / cart_component_norm ( ax , ay , az ) end do end do end do norm2 = dot_product ( row , matmul ( metric , row )) b (:, col ) = row / sqrt ( norm2 ) end do end function c2s_build integer function cart_index ( l , ax , ay , az ) result ( idx ) use constants , only : CART_X , CART_Y , CART_Z integer , intent ( in ) :: l , ax , ay , az integer :: i do i = 1 , NUM_CART_BF ( l ) if ( CART_X ( i , l ) == ax . and . CART_Y ( i , l ) == ay . and . CART_Z ( i , l ) == az ) then idx = i return end if end do error stop 'cart2sph: generated monomial is absent from CART_X/Y/Z' end function cart_index pure real ( dp ) function cart_component_norm ( ax , ay , az ) result ( n ) integer , intent ( in ) :: ax , ay , az n = 1.0_dp / sqrt ( real ( idfact ( 2 * ax - 1 ) * idfact ( 2 * ay - 1 ) * idfact ( 2 * az - 1 ), dp )) end function cart_component_norm pure integer function ibinom ( n , k ) result ( c ) integer , intent ( in ) :: n , k integer :: i if ( k < 0 . or . k > n ) then c = 0 return end if c = 1 do i = 1 , k c = c * ( n - i + 1 ) / i end do end function ibinom !> @brief Contract one index of a 3-way-folded block: out(il,is,ir) = !>        sum_ic B(ic,is) * a(il,ic,ir), with the index laid out as !>        (left, n_cart, right) in column-major order. subroutine contract_index ( a , left , ncart , right , b , nsph , out ) integer , intent ( in ) :: left , ncart , right , nsph real ( dp ), intent ( in ) :: a ( left , ncart , right ) real ( dp ), intent ( in ) :: b ( ncart , nsph ) real ( dp ), intent ( out ) :: out ( left , nsph , right ) integer :: il , is , ic , ir real ( dp ) :: bval out = 0.0_dp do ir = 1 , right do is = 1 , nsph do ic = 1 , ncart bval = b ( ic , is ) if ( bval == 0.0_dp ) cycle do il = 1 , left out ( il , is , ir ) = out ( il , is , ir ) + bval * a ( il , ic , ir ) end do end do end do end do end subroutine contract_index !> @brief Transform a 2e shell-quartet block from unit-normalized Cartesian !>        to pure spherical for any index whose shell is flagged harmonic. !> !> @param[inout] ints  flat ERI buffer; on entry holds the Cartesian block !>                     with storage dims [nbf(1)..nbf(4)] (column-major, !>                     index 1 fastest); on exit the spherical block with !>                     dims [nbf_out(1)..nbf_out(4)]. !> @param[in]    am    angular momentum of the four shells, in storage order !> @param[in]    pure  per-shell harmonic flag (1=spherical), storage order !> @param[in]    nbf   Cartesian component counts, storage order !> @param[out]   nbf_out spherical component counts, storage order !> !> Storage order means dimension k of `ints` corresponds to am(k)/pure(k). !> Callers in int2 pass these already in the flipped (stored) order. subroutine cart2sph_eri ( ints , am , pure , nbf , nbf_out ) real ( dp ), intent ( inout ) :: ints (:) integer , intent ( in ) :: am ( 4 ), pure ( 4 ), nbf ( 4 ) integer , intent ( out ) :: nbf_out ( 4 ) integer :: dims ( 4 ) ! running per-index sizes (Cartesian -> spherical) integer :: p , left , right , k , nc , ns real ( dp ), allocatable :: b (:,:), src (:), dst (:) nbf_out = nbf do p = 1 , 4 if ( pure ( p ) /= 1 . or . am ( p ) < 2 ) cycle nbf_out ( p ) = NUM_SPH_BF ( am ( p )) end do if ( all ( nbf_out == nbf )) return ! nothing pure -> leave Cartesian block dims = nbf allocate ( src ( product ( nbf ))) src ( 1 : product ( nbf )) = ints ( 1 : product ( nbf )) do p = 1 , 4 if ( pure ( p ) /= 1 . or . am ( p ) < 2 ) cycle nc = dims ( p ) ns = NUM_SPH_BF ( am ( p )) left = product ( dims ( 1 : p - 1 )) right = product ( dims ( p + 1 : 4 )) call c2s_get ( am ( p ), b ) allocate ( dst ( left * ns * right )) call contract_index ( src , left , nc , right , b , ns , dst ) call move_alloc ( dst , src ) dims ( p ) = ns deallocate ( b ) end do k = product ( dims ) ints ( 1 : k ) = src ( 1 : k ) deallocate ( src ) end subroutine cart2sph_eri !> @brief Transform a 1e shell-pair block (unit-normalized Cartesian) to !>        pure spherical for any harmonic-flagged shell. !> !> @details The block is laid out with the \"fast\" shell varying quickest, !>          i.e. blk(nn), nn over (slow outer, fast inner) -- the order !>          consumed by update_triang_matrix/update_rectangular_matrix !>          (fast = shj, slow = shi). On exit blk(1:n_out) holds the !>          spherical block in the same fast/slow layout and n_fast_out/ !>          n_slow_out give its extents. subroutine cart2sph_mat ( blk , l_fast , pure_fast , l_slow , pure_slow , n_fast_out , n_slow_out , iandj , antisym ) use constants , only : shells_pnrm2 real ( dp ), intent ( inout ) :: blk (:) integer , intent ( in ) :: l_fast , pure_fast , l_slow , pure_slow integer , intent ( out ), optional :: n_fast_out , n_slow_out logical , intent ( in ), optional :: iandj !< .true. for a same-shell block, !< stored as a lower triangle (fast<=slow) logical , intent ( in ), optional :: antisym !< .true. if the operator is !< antisymmetric (L, GIAO H10, SOC); !< affects the iandj unpacking only integer :: ncf , ncs , nsf , nss , k , ic , ir logical :: tri , anti real ( dp ), allocatable :: b (:,:), src (:), dst (:) ncf = NUM_CART_BF ( l_fast ) ncs = NUM_CART_BF ( l_slow ) nsf = c2s_ncomp ( l_fast , pure_fast ) nss = c2s_ncomp ( l_slow , pure_slow ) if ( present ( n_fast_out )) n_fast_out = nsf if ( present ( n_slow_out )) n_slow_out = nss if ( nsf == ncf . and . nss == ncs ) return ! nothing pure -> Cartesian block tri = . false . if ( present ( iandj )) tri = iandj anti = . false . if ( present ( antisym )) anti = antisym ! Same-shell blocks (update_triang_matrix iandj path) are stored as a lower ! triangle blk((i-1)i/2 + j), j<=i. Unpack to a full Cartesian block using ! the operator's parity, transform as a rectangle, then repack to the ! spherical triangle. if ( tri ) then call cart2sph_tri ( blk , l_fast , pure_fast , l_slow , pure_slow , ncf , ncs , nsf , nss , anti ) return end if allocate ( src ( ncf * ncs )) src ( 1 : ncf * ncs ) = blk ( 1 : ncf * ncs ) ! 1e blocks arrive in the pure-power Cartesian normalization (the ! shells_pnrm2 per-component factors are applied later by bas_norm_matrix ! for Cartesian shells). B is defined for unit-normalized Cartesians, so ! for each index we transform, first fold in shells_pnrm2 along that index; ! the resulting spherical components are unit-normalized (set_bfnorms then ! uses bfnrm = 1 for them). Non-pure indices are left pure-power untouched. ! Contract the fast index (storage layout (ncf, ncs), fast contiguous). if ( pure_fast == 1 . and . l_fast >= 2 ) then do ir = 1 , ncs do ic = 1 , ncf src (( ir - 1 ) * ncf + ic ) = src (( ir - 1 ) * ncf + ic ) * shells_pnrm2 ( ic , l_fast ) end do end do call c2s_get ( l_fast , b ) allocate ( dst ( nsf * ncs )) call contract_index ( src , 1 , ncf , ncs , b , nsf , dst ) call move_alloc ( dst , src ) deallocate ( b ) end if ! Contract the slow index ((nsf, ncs, 1); the slow index is the outer one). if ( pure_slow == 1 . and . l_slow >= 2 ) then do ir = 1 , ncs do ic = 1 , nsf src (( ir - 1 ) * nsf + ic ) = src (( ir - 1 ) * nsf + ic ) * shells_pnrm2 ( ir , l_slow ) end do end do call c2s_get ( l_slow , b ) allocate ( dst ( nsf * nss )) call contract_index ( src , nsf , ncs , 1 , b , nss , dst ) call move_alloc ( dst , src ) deallocate ( b ) end if k = nsf * nss blk ( 1 : k ) = src ( 1 : k ) deallocate ( src ) end subroutine cart2sph_mat !> @brief Transform a rectangular 1e shell-pair block that is already in the !>        unit-normalized Cartesian convention. !> @details This is used by backends such as libecpint that return normalized !>          Cartesian matrices directly. Unlike cart2sph_mat, this does not !>          fold in shells_pnrm2 before applying the c2s coefficients. subroutine cart2sph_mat_unit ( blk , l_fast , pure_fast , l_slow , pure_slow ) real ( dp ), intent ( inout ) :: blk (:) integer , intent ( in ) :: l_fast , pure_fast , l_slow , pure_slow integer :: ncf , ncs , nsf , nss , k real ( dp ), allocatable :: b (:,:), src (:), dst (:) ncf = NUM_CART_BF ( l_fast ) ncs = NUM_CART_BF ( l_slow ) nsf = c2s_ncomp ( l_fast , pure_fast ) nss = c2s_ncomp ( l_slow , pure_slow ) if ( nsf == ncf . and . nss == ncs ) return allocate ( src ( ncf * ncs )) src ( 1 : ncf * ncs ) = blk ( 1 : ncf * ncs ) if ( pure_fast == 1 . and . l_fast >= 2 ) then call c2s_get ( l_fast , b ) allocate ( dst ( nsf * ncs )) call contract_index ( src , 1 , ncf , ncs , b , nsf , dst ) call move_alloc ( dst , src ) deallocate ( b ) end if if ( pure_slow == 1 . and . l_slow >= 2 ) then call c2s_get ( l_slow , b ) allocate ( dst ( nsf * nss )) call contract_index ( src , nsf , ncs , 1 , b , nss , dst ) call move_alloc ( dst , src ) deallocate ( b ) end if k = nsf * nss blk ( 1 : k ) = src ( 1 : k ) deallocate ( src ) end subroutine cart2sph_mat_unit !> @brief Per-shell density-expansion matrix B'(l) = B(l) * shells_pnrm2, !>        shape (NUM_CART_BF(l), 2l+1). Maps a unit-spherical index back to !>        the pure-power Cartesian index for contraction with derivative !>        integrals: D_cart = B'_i D_sph B'_j&#94;T (see c2s_expand_block). subroutine c2s_expansion_matrix ( l , bp ) use constants , only : shells_pnrm2 integer , intent ( in ) :: l real ( dp ), allocatable , intent ( out ) :: bp (:,:) integer :: nc , ns , c , s call c2s_get ( l , bp ) ! bp = B(l), shape (nc, ns) nc = NUM_CART_BF ( l ) ns = NUM_SPH_BF ( l ) do s = 1 , ns do c = 1 , nc bp ( c , s ) = bp ( c , s ) * shells_pnrm2 ( c , l ) end do end do end subroutine c2s_expansion_matrix !> @brief Expand a spherical density block to the pure-power Cartesian !>        (\"effective\") density used by the gradient/Hessian kernels: !>        D_cart = B'_i D_sph B'_j&#94;T. Pure shells (l>=2) use B'; otherwise !>        the index passes through unchanged (Cartesian == spherical). !> @param[in]  dsph   (nsph_i, nsph_j) spherical density block (bfnrm-folded) !> @param[out] dcart  (ncart_i, ncart_j) Cartesian-effective density block subroutine c2s_expand_block ( dsph , dcart , l_i , pure_i , l_j , pure_j ) real ( dp ), intent ( in ) :: dsph (:,:) real ( dp ), intent ( out ) :: dcart (:,:) integer , intent ( in ) :: l_i , pure_i , l_j , pure_j real ( dp ), allocatable :: bi (:,:), bj (:,:), tmp (:,:) integer :: nci , ncj , nsi , nsj logical :: pi , pj nci = NUM_CART_BF ( l_i ); nsi = c2s_ncomp ( l_i , pure_i ) ncj = NUM_CART_BF ( l_j ); nsj = c2s_ncomp ( l_j , pure_j ) pi = ( pure_i == 1 . and . l_i >= 2 ) pj = ( pure_j == 1 . and . l_j >= 2 ) if (. not . pi . and . . not . pj ) then dcart ( 1 : nci , 1 : ncj ) = dsph ( 1 : nsi , 1 : nsj ) return end if ! Expand the i (row) index: tmp(nci, nsj) = B'_i (nci,nsi) . dsph (nsi,nsj) allocate ( tmp ( nci , nsj )) if ( pi ) then call c2s_expansion_matrix ( l_i , bi ) tmp = matmul ( bi , dsph ( 1 : nsi , 1 : nsj )) else tmp = dsph ( 1 : nci , 1 : nsj ) end if ! Expand the j (col) index: dcart(nci, ncj) = tmp (nci,nsj) . B'_j&#94;T (nsj,ncj) if ( pj ) then call c2s_expansion_matrix ( l_j , bj ) dcart ( 1 : nci , 1 : ncj ) = matmul ( tmp , transpose ( bj )) else dcart ( 1 : nci , 1 : ncj ) = tmp ( 1 : nci , 1 : ncj ) end if deallocate ( tmp ) end subroutine c2s_expand_block !> @brief Transform a 1-index AO vector (e.g. grid AO values or one !>        derivative component) from pure-power Cartesian to pure spherical. !> @details sph(s) = sum_c B(c,s) * shells_pnrm2(c,l) * cart(c). The pnrm !>          fold makes the spherical components unit-normalized (downstream !>          bfnrm = 1 for them, matching set_bfnorms). For l < 2 this is a !>          straight copy. cart has NUM_CART_BF(l) entries, sph has 2l+1. subroutine cart2sph_vec ( cart , sph , l ) use constants , only : shells_pnrm2 real ( dp ), intent ( in ) :: cart (:) real ( dp ), intent ( out ) :: sph (:) integer , intent ( in ) :: l real ( dp ), allocatable :: b (:,:) integer :: nc , ns , c , s real ( dp ) :: acc nc = NUM_CART_BF ( l ) if ( l < 2 ) then sph ( 1 : nc ) = cart ( 1 : nc ) return end if ns = NUM_SPH_BF ( l ) call c2s_get ( l , b ) do s = 1 , ns acc = 0.0_dp do c = 1 , nc acc = acc + b ( c , s ) * shells_pnrm2 ( c , l ) * cart ( c ) end do sph ( s ) = acc end do deallocate ( b ) end subroutine cart2sph_vec !> @brief Same-shell (iandj) variant: the block is a packed lower triangle !>        blk((i-1)i/2 + j), j<=i. Unpack to a full Cartesian block with the !>        operator's parity (full(j>i) = +/- blk, zero diagonal when !>        antisymmetric), transform as a rectangle, repack to the spherical !>        triangle. subroutine cart2sph_tri ( blk , l_fast , pure_fast , l_slow , pure_slow , ncf , ncs , nsf , nss , antisym ) real ( dp ), intent ( inout ) :: blk (:) integer , intent ( in ) :: l_fast , pure_fast , l_slow , pure_slow , ncf , ncs , nsf , nss logical , intent ( in ) :: antisym real ( dp ), allocatable :: full (:) integer :: i , j , nn real ( dp ) :: mirror mirror = 1.0_dp if ( antisym ) mirror = - 1.0_dp allocate ( full ( ncf * ncs )) do i = 1 , ncs ! slow index (shi) do j = 1 , ncf ! fast index (shj) if ( j < i ) then full (( i - 1 ) * ncf + j ) = blk ( i * ( i - 1 ) / 2 + j ) else if ( j > i ) then full (( i - 1 ) * ncf + j ) = mirror * blk ( j * ( j - 1 ) / 2 + i ) ! mirrored counterpart else if ( antisym ) then full (( i - 1 ) * ncf + j ) = 0.0_dp ! antisymmetric diagonal is exact zero else full (( i - 1 ) * ncf + j ) = blk ( i * ( i - 1 ) / 2 + j ) end if end do end do call cart2sph_mat ( full , l_fast , pure_fast , l_slow , pure_slow ) do i = 1 , nss do j = 1 , i blk ( i * ( i - 1 ) / 2 + j ) = full (( i - 1 ) * nsf + j ) end do end do deallocate ( full ) end subroutine cart2sph_tri !> @brief Self-test: rebuild the intra-shell metric S of unit-normalized !>        Cartesian Gaussians from the canonical exponents and verify !>        B(l) S B(l)&#94;T = I for every supported pure shell. Returns the !>        worst deviation. subroutine c2s_selftest ( max_err ) use constants , only : CART_X , CART_Y , CART_Z real ( dp ), intent ( out ) :: max_err integer :: l , nc , ns , i , j , is , js real ( dp ), allocatable :: b (:,:), s (:,:), g (:,:) real ( dp ) :: err max_err = 0.0_dp do l = 2 , BAS_MXANG nc = NUM_CART_BF ( l ) ns = NUM_SPH_BF ( l ) call c2s_get ( l , b ) allocate ( s ( nc , nc )) do i = 1 , nc do j = 1 , nc s ( i , j ) = cart_overlap ( CART_X ( i , l ), CART_Y ( i , l ), CART_Z ( i , l ), & CART_X ( j , l ), CART_Y ( j , l ), CART_Z ( j , l )) end do end do ! g = B&#94;T S B  (ns x ns), should be identity allocate ( g ( ns , ns )) g = matmul ( matmul ( transpose ( b ), s ), b ) do is = 1 , ns do js = 1 , ns err = abs ( g ( is , js ) - merge ( 1.0_dp , 0.0_dp , is == js )) if ( err > max_err ) max_err = err end do end do deallocate ( b , s , g ) end do end subroutine c2s_selftest !> @brief Overlap of two unit-normalized Cartesian Gaussians of the same !>        shell (same exponent), i.e. the intra-shell metric element. !>        For a normalized x&#94;a y&#94;b z&#94;c: <i|j> = prod_k (a_k+b_k-1)!! / !>        sqrt((2a_k-1)!! (2b_k-1)!!) over k in {x,y,z}; zero if any sum odd. pure real ( dp ) function cart_overlap ( ax , ay , az , bx , by , bz ) result ( s ) integer , intent ( in ) :: ax , ay , az , bx , by , bz if ( mod ( ax + bx , 2 ) /= 0 . or . mod ( ay + by , 2 ) /= 0 . or . mod ( az + bz , 2 ) /= 0 ) then s = 0.0_dp return end if s = ratio ( ax , bx ) * ratio ( ay , by ) * ratio ( az , bz ) end function cart_overlap !> @brief (a+b-1)!! / sqrt((2a-1)!! (2b-1)!!) for one Cartesian axis. pure real ( dp ) function ratio ( a , b ) result ( r ) integer , intent ( in ) :: a , b r = real ( idfact ( a + b - 1 ), dp ) / sqrt ( real ( idfact ( 2 * a - 1 ), dp ) * real ( idfact ( 2 * b - 1 ), dp )) end function ratio !> @brief Integer double factorial n!! with (-1)!! = 0!! = 1. pure integer function idfact ( n ) result ( r ) integer , intent ( in ) :: n integer :: k r = 1 k = n do while ( k > 1 ) r = r * k k = k - 2 end do end function idfact end module cart2sph","tags":"","url":"sourcefile/cart2sph.f90.html"},{"title":"scf_addons.F90 – OpenQP Fortran API","text":"Source Code !=============================================================================== ! MODULE: scf_addons !=============================================================================== ! ! DESCRIPTION: !   The scf_addons module provides specialized functionality to enhance SCF !   convergence for challenging electronic systems. It implements three major !   techniques: !       - pseudo-Fractional Occupation Numbers (pFON), !       - Maximum Overlap Method (MOM), and !       - level shifting. !   These methods help with systems exhibiting near-degeneracies, state flipping, !   or convergence difficulties. ! ! MEMBERS: !   - pfon_t [TYPE]: Encapsulates pFON functionality for managing fractional !                    occupations based on temperature-dependent Fermi-Dirac !                    distributions. ! ! DEPENDENCIES: !   - precision: Provides `dp` for double precision real numbers. !   - io_constants: Provides `iw` for output unit. !   - mathlib: For matrix operations including pack_matrix, unpack_matrix. !   - messages: For error handling. ! ! PUBLIC INTERFACES: !   - pfon_t: Type for managing pseudo-Fractional Occupation Numbers. !   - apply_mom: Implements Maximum Overlap Method for orbital tracking. !   - level_shift_fock: Applies level shifting to the Fock matrix. ! ! NOTES: !   - The module's functionality is designed to be used within SCF iterations. !   - Methods work with RHF, UHF, and ROHF wavefunctions. !   - The pFON implementation follows the approach described in: !     https://doi.org/10.1063/1.478177 ! ! HISTORY: !   - [2025] Initial Module Creation - Konstantin Komarov !     Established this module by extracting and refactoring auxiliary SCF !     functionality from the main `scf`` module for better code organization !     and maintainability. Implemented the `pfon_t`` type as a proper object !     to encapsulate the pFON functionality. !   - [January 2025] pFON Implementation - Alireza Lashkaripour !     Developed the pseudo-Fractional Occupation Number (pFON) method !     functionality that was later integrated into this module. !   - [2023-2025] Advanced Convergence Methods - Konstantin Komarov !     Implemented the Maximum Overlap Method (MOM) and level shifting !     techniques to improve convergence for challenging electronic systems. ! !=============================================================================== !=============================================================================== ! TYPE: pfon_t - PSEUDO-FRACTIONAL OCCUPATION NUMBERS !=============================================================================== ! ! DESCRIPTION: !   The `pfon_t` type encapsulates functionality for managing fractional !   occupation numbers in SCF calculations using a temperature-dependent !   Fermi-Dirac distribution. This technique smooths convergence for systems !   with near-degeneracies by allowing partial orbital occupations. ! ! MEMBERS: !   active         [LOGICAL]: Whether pFON is currently enabled. !   temp           [REAL(dp)]: Current temperature for Fermi-Dirac distribution. !   beta           [REAL(dp)]: Inverse temperature parameter (1/(kB*T)). !   last_cooled_temp [REAL(dp)]: Last temperature at which cooling occurred. !   cooling_rate   [REAL(dp)]: Rate of temperature decrease per iteration. !   nsmear         [INTEGER]: Number of orbitals to smear around the Fermi level. !   occ_a          [REAL(dp), POINTER]: Alpha orbital occupations array. !   occ_b          [REAL(dp), POINTER]: Beta orbital occupations array. !   scf_type       [INTEGER]: SCF calculation type (1=RHF, 2=UHF, 3=ROHF). !   nelec          [INTEGER]: Total number of electrons. !   nelec_a        [INTEGER]: Number of alpha electrons. !   nelec_b        [INTEGER]: Number of beta electrons. !   nbf            [INTEGER]: Number of basis functions. ! ! METHODS: !   init                 - Initializes pFON parameters based on control settings. !   adjust_temperature   - Dynamically adjusts temperature during iterations. !   compute_occupations  - Wrapper for helper `pfon_occupations` function. !                          Calculates fractional occupations from orbital energies. !   build_density        - Wrapper for helper `build_pfon_density` function. !                          Constructs density matrices using fractional occupations. ! ! HELPER FUNCTIONS: !   pfon_occupations     - Standalone function that computes fractional occupations !   build_pfon_density   - Constructs density matrices from MO coefficients and !                          fractional occupations. ! ! ALGORITHM: !   1. Start with high temperature (typically 2000K) to allow significant !      fractional occupation and smooth energy surface !   2. Gradually decrease temperature during iterations (cooling_rate parameter) !   3. Compute Fermi level as average of HOMO and LUMO energies !   4. Calculate occupations using Fermi-Dirac distribution: !      n_i = 2/(1+exp((ε_i-εF)/kT)) for RHF !      n_i = 1/(1+exp((ε_i-εF)/kT)) for UHF/ROHF !   5. Normalize occupations to preserve total electron count !   6. Use occupations to build weighted density matrices !   7. Set temperature to 1K for final iteration to obtain integer occupations ! ! USAGE NOTES: !   - Temperature gradually decreases during SCF iterations to facilitate convergence !   - Final iteration typically uses T=0K to obtain integer occupations !   - Works with all SCF types (RHF, UHF, ROHF) with appropriate occupation patterns !   - Particularly effective for systems with small HOMO-LUMO gaps or !     near-degenerate orbital energies ! !=============================================================================== !=============================================================================== ! TYPE: pfon_t - PSEUDO-FRACTIONAL OCCUPATION NUMBERS !=============================================================================== ! ! DESCRIPTION: !   The `pfon_t` type encapsulates functionality for managing fractional !   occupation numbers in SCF calculations using a temperature-dependent !   Fermi-Dirac distribution. This technique smooths convergence for systems !   with near-degeneracies by allowing partial orbital occupations. ! ! MEMBERS: !   active         [LOGICAL]: Whether pFON is currently enabled. !   temp           [REAL(dp)]: Current temperature for Fermi-Dirac distribution. !   beta           [REAL(dp)]: Inverse temperature parameter (1/(kB*T)). !   last_cooled_temp [REAL(dp)]: Last temperature at which cooling occurred. !   cooling_rate   [REAL(dp)]: Rate of temperature decrease per iteration. !   nsmear         [INTEGER]: Number of orbitals to smear around the Fermi level. !   occ_a          [REAL(dp), POINTER]: Alpha orbital occupations array. !   occ_b          [REAL(dp), POINTER]: Beta orbital occupations array. !   scf_type       [INTEGER]: SCF calculation type (1=RHF, 2=UHF, 3=ROHF). !   nelec          [INTEGER]: Total number of electrons. !   nelec_a        [INTEGER]: Number of alpha electrons. !   nelec_b        [INTEGER]: Number of beta electrons. !   nbf            [INTEGER]: Number of basis functions. ! ! METHODS: !   init                 - Initializes pFON parameters based on control settings. !   adjust_temperature   - Dynamically adjusts temperature during iterations. !   compute_occupations  - Calculates fractional occupations from orbital energies. !   build_density        - Constructs density matrices using fractional occupations. ! ! NOTES: !   - Works with RHF, UHF, ROHF with appropriate occupation patterns. !   - Works with Second-Order SCF convergence method. ! !=============================================================================== !=============================================================================== ! SUBROUTINE: apply_mom - MAXIMUM OVERLAP METHOD !=============================================================================== ! ! DESCRIPTION: !   Implements the Maximum Overlap Method (MOM) to maintain consistent orbital !   ordering between SCF iterations. This helps prevent oscillations and state !   flipping during convergence, especially for open-shell systems or cases !   with near-degeneracies. ! ! PARAMETERS: !   infos         [TYPE(information)]: System information. !   v_prev        [REAL(dp)]: Previous iteration's MO coefficients. !   e_prev        [REAL(dp)]: Previous iteration's orbital energies. !   v_curr        [REAL(dp)]: Current iteration's MO coefficients (reordered on output). !   e_curr        [REAL(dp)]: Current iteration's orbital energies (reordered on output). !   s_ao          [REAL(dp)]: Overlap matrix in AO basis. !   n_occ         [INTEGER]: Number of occupied orbitals. !   spin_label    [CHARACTER(*)]: Identifier for spin channel (\"Alpha\" or \"Beta\"). !   work          [REAL(dp)]: Work array for intermediate calculations. !   s_mo          [REAL(dp)]: Work array for MO overlap matrix. ! ! ALGORITHM: !   1. Computes overlap between previous and current MOs: S_MO = V_prev&#94;T * S * V_curr !   2. For each orbital (occupied+1), finds maximum overlap match !   3. Reorders current orbitals to maximize consistency with previous iteration !   4. Ensures proper tracking of HOMO/LUMO and other important orbitals ! ! HELPER ROUTINES: !   reorder_orbitals - Internal subroutine that performs the actual orbital swapping ! !=============================================================================== !=============================================================================== ! SUBROUTINE: level_shift_fock - VIRTUAL ORBITAL SHIFTING !=============================================================================== ! ! DESCRIPTION: !   Applies level shifting to the virtual orbitals in the Fock matrix to increase !   the HOMO-LUMO gap and improve SCF convergence. This technique is particularly !   useful for systems with small HOMO-LUMO gaps or near-degeneracies. ! ! PARAMETERS: !   fock_ao       [REAL(dp)]: Fock matrix in AO basis (triangular format). !   mo_coefs      [REAL(dp)]: MO coefficients. !   smat_full     [REAL(dp)]: Full overlap matrix. !   nocc          [INTEGER]: Number of occupied orbitals. !   nbf           [INTEGER]: Number of basis functions. !   vshift        [REAL(dp)]: Level shift parameter value. !   work1, work2  [REAL(dp)]: Work arrays for intermediate calculations. ! ! ALGORITHM: !   1. Transforms Fock from AO to MO basis: F_MO = C&#94;T * F_AO * C !   2. Adds shift to diagonal elements corresponding to virtual orbitals !   3. Transforms modified Fock back to AO basis for use in SCF ! ! USAGE NOTES: !   - Typically applied in early iterations and gradually reduced !   - Often combined with DIIS for optimal convergence ! ! NOTES: !   - Works with RHF and UHF calculations. The ROHF case is handled through !   the `form_rohf_fock` function in the `scf` module. ! !=============================================================================== module scf_addons use precision , only : dp character ( len =* ), parameter :: module_name = \"scf_addons\" private public :: pfon_t public :: apply_mom public :: level_shift_fock public :: fock_jk public :: calc_fock public :: scf_energy_t public :: get_solver_name public :: compute_energy public :: calc_jk_xc public :: get_response_packed public :: get_scf_name integer , parameter , public :: scf_rhf = 1 ! Restricted HF integer , parameter , public :: scf_uhf = 2 ! Unrestricted HF integer , parameter , public :: scf_rohf = 3 ! ROHF integer , parameter , public :: scf_diis = 0 , scf_bfgs = 1 , scf_trah = 2 !> @brief Type to encapsulate pFON (pseudo-Fractional Occupation Number) functionality !> @detail Provides methods for managing fractional occupation numbers in SCF calculations, !>         including temperature control, occupation computation, and density building. type :: pfon_t private logical :: active = . false . ! Whether pFON is enabled real ( kind = dp ), public :: temp ! Current temperature real ( kind = dp ), public :: beta ! Inverse temperature (1/(kB * temp)) real ( kind = dp ) :: last_cooled_temp = 0.0_dp ! Last temperature at which cooling occurred real ( kind = dp ) :: cooling_rate = 5 0.0_dp ! Temperature cooling rate integer :: nsmear = 0 ! Number of smearing steps real ( kind = dp ), pointer , public :: occ_a (:) => null () ! Alpha occupations real ( kind = dp ), pointer , public :: occ_b (:) => null () ! Beta occupations integer :: scf_type = 1 ! SCF calculation type (1=RHF, 2=UHF, 3=ROHF) integer :: nelec = 0 ! Total number of electrons integer :: nelec_a = 0 ! Number of alpha electrons integer :: nelec_b = 0 ! Number of beta electrons integer :: nbf = 0 ! Number of basis functions contains procedure :: init => pfon_init procedure :: adjust_temperature => pfon_adjust_temperature procedure :: compute_occupations => pfon_compute_occupations procedure :: build_density => pfon_build_density end type pfon_t type :: scf_energy_t real ( kind = dp ) :: ehf ! Electronic energy (HF part) real ( kind = dp ) :: ehf1 ! One-electron energy real ( kind = dp ) :: nenergy ! Nuclear repulsion energy real ( kind = dp ) :: etot ! Total SCF energy real ( kind = dp ) :: e_old ! Energy from previous iteration real ( kind = dp ) :: psinrm ! Wavefunction normalization real ( kind = dp ) :: vne ! Nucleus-electron potential energy real ( kind = dp ) :: vnn ! Nucleus-nucleus potential energy real ( kind = dp ) :: vee ! Electron-electron potential energy real ( kind = dp ) :: vtot ! Total potential energy real ( kind = dp ) :: virial ! Virial ratio (V/T) real ( kind = dp ) :: tkin ! Kinetic energy real ( kind = dp ) :: eexc ! Exchange-correlation energy for DFT real ( kind = dp ) :: totele ! Total electron density for DFT real ( kind = dp ) :: totkin ! Total kinetic energy for DFT real ( kind = dp ) :: e_pcm = 0.0_dp ! PCM solvent reaction-field energy (provisional; ddX path) contains procedure :: print_e => print_scf_energy end type scf_energy_t contains function get_solver_name ( solver_id ) result ( name ) implicit none integer , intent ( in ) :: solver_id character ( len = 16 ) :: name select case ( solver_id ) case ( scf_diis ) name = 'DIIS' case ( scf_bfgs ) name = 'BFGS/SOSCF' case ( scf_trah ) name = 'TRAH' case default name = 'UNKNOWN' end select end function get_solver_name pure function get_scf_name ( code ) result ( name ) integer , intent ( in ) :: code character ( len = :), allocatable :: name select case ( code ) case ( scf_rhf ); name = 'RHF' case ( scf_uhf ); name = 'UHF' case ( scf_rohf ); name = 'ROHF' case default ; name = 'UNKNOWN' end select end function get_scf_name !> @brief Prints the final energy components of the SCF calculation. !> @detail Outputs a detailed breakdown of energy terms, including one-electron, !>         two-electron, nuclear repulsion, and total energies, as well as potential !>         (electron-electron, nucleus-electron, nucleus-nucleus, total) and !>         kinetic contributions, and the virial ratio. subroutine print_scf_energy ( this ) use precision , only : dp use io_constants , only : iw implicit none class ( scf_energy_t ), intent ( in ) :: this write ( IW , \"(/10X,17('=')/10X,'Energy components'/10X,17('=')/)\" ) write ( IW , \"('         Wavefunction normalization =',F19.10)\" ) this % psinrm write ( IW , * ) write ( IW , \"('                One electron energy =',F19.10)\" ) this % ehf1 write ( IW , \"('                Two electron energy =',F19.10)\" ) this % vee write ( IW , \"('           Nuclear repulsion energy =',F19.10)\" ) this % nenergy if ( this % e_pcm /= 0.0_dp ) then write ( IW , \"('           PCM solvent energy        =',F19.10)\" ) this % e_pcm end if write ( IW , \"(38X,18('-'))\" ) write ( IW , \"('                       TOTAL energy =',F19.10)\" ) this % etot write ( IW , * ) write ( IW , \"(' Electron-electron potential energy =',F19.10)\" ) this % vee write ( IW , \"('  Nucleus-electron potential energy =',F19.10)\" ) this % vne write ( IW , \"('   Nucleus-nucleus potential energy =',F19.10)\" ) this % vnn write ( IW , \"(38X,18('-'))\" ) write ( IW , \"('             TOTAL potential energy =',F19.10)\" ) this % vtot write ( IW , \"('               TOTAL kinetic energy =',F19.10)\" ) this % tkin write ( IW , \"('                 Virial ratio (V/T) =',F19.10)\" ) this % virial write ( IW , * ) end subroutine print_scf_energy !> @brief Applies the Maximum Overlap Method (MOM) to reorder orbitals. !> @detail Reorders the current iteration’s orbitals to maximize overlap !>         with the previous iteration’s orbitals, !>         ensuring consistent electronic state tracking during SCF convergence !>         (useful for avoiding state flipping). !> @param[in] infos System information. !> @param[in] v_prev Previous iteration’s MO coefficients. !> @param[in] e_prev Previous iteration’s orbital energies. !> @param[inout] v_curr Current iteration’s MO coefficients (reordered on output). !> @param[inout] e_curr Current iteration’s orbital energies (reordered on output). !> @param[in] s_ao Overlap matrix in AO basis. !> @param[in] n_occ Number of occupied orbitals. !> @param[in] spin_label Identifier for spin channel (\"Alpha\" or \"Beta\"). !> @param[inout] work Work array for intermediate calculations (nbf x nbf). !> @param[inout] s_mo Work array for MO overlap matrix (nbf x nbf). subroutine apply_mom ( infos , v_prev , e_prev , v_curr , e_curr , s_ao , n_occ , & spin_label , work , s_mo ) use precision , only : dp use io_constants , only : iw use types , only : information implicit none ! Input/output parameters type ( information ), intent ( in ) :: infos real ( kind = dp ), intent ( in ), dimension (:,:) :: v_prev real ( kind = dp ), intent ( in ), dimension (:) :: e_prev real ( kind = dp ), intent ( inout ), dimension (:,:) :: v_curr real ( kind = dp ), intent ( inout ), dimension (:) :: e_curr real ( kind = dp ), intent ( in ), dimension (:,:) :: s_ao integer , intent ( in ) :: n_occ character ( * ), intent ( in ) :: spin_label real ( kind = dp ), intent ( inout ), dimension (:,:) :: work real ( kind = dp ), intent ( inout ), dimension (:,:) :: s_mo ! Local variables integer :: i , j , k , ip1 , nbf integer :: max_idx real ( kind = dp ) :: max_overlap , overlap logical , allocatable :: reordered (:) nbf = size ( v_curr , 1 ) if ( infos % control % verbose >= 1 ) then if ( infos % control % rstctmo ) then write ( IW , fmt = '(/,\"Applying Reodering for \",A,\" spin channel\")' ) trim ( spin_label ) else write ( IW , fmt = '(/,\"Applying MOM for \",A,\" spin channel\")' ) trim ( spin_label ) end if end if ! Allocate reordered flag array allocate ( reordered ( nbf ), source = . false .) ! Calculate overlap between previous and current MOs: s_mo = v_prev&#94;T * s_ao * v_curr call dgemm ( 't' , 'n' , nbf , nbf , nbf , 1.0_dp , v_prev , nbf , s_ao , nbf , 0.0_dp , work , nbf ) call dgemm ( 'n' , 'n' , nbf , nbf , nbf , 1.0_dp , work , nbf , v_curr , nbf , 0.0_dp , s_mo , nbf ) ! Normalize columns to ensure proper comparison do i = 1 , nbf s_mo (:, i ) = s_mo (:, i ) / max ( norm2 ( s_mo (:, i )), 1.0e-10_dp ) end do ! First, identify the best match for each orbital from the previous iteration ! Focus particularly on occupied orbitals and the HOMO-LUMO region ! Print information about important orbitals (HOMO, LUMO) if ( infos % control % verbose > 1 ) then write ( IW , fmt = '(1X,\"MOM reordering for \",A,\" orbitals:\")' ) trim ( spin_label ) write ( IW , fmt = '(1X,\"Old Index → New Index   | Overlap |  Status\")' ) write ( IW , fmt = '(1X,\"--------------------------------------------\")' ) end if ! First pass: check which orbitals need reordering do i = 1 , nbf max_overlap = 0.0_dp max_idx = i ! Default to no change ! Find the orbital with maximum overlap do j = 1 , nbf if (. not . reordered ( j )) then overlap = abs ( s_mo ( i , j )) if ( overlap > max_overlap ) then max_overlap = overlap max_idx = j end if end if end do ! Mark the orbital as reordered and print info for occupied orbitals reordered ( max_idx ) = . true . if ( infos % control % verbose > 1 ) then ! Print info for important orbitals or those being reordered if ((( i <= n_occ + 1 ) . or . ( i /= max_idx )). and . infos % control % verbose >= 1 ) then write ( IW , fmt = '(3X,I3,5X,\"→\",5X,I3,5X,\"| \",F7.5,\" |\")' , advance = 'no' ) & i , max_idx , max_overlap ! Add label for HOMO/LUMO if ( i == n_occ ) write ( IW , fmt = '(1X,\"HOMO\")' , advance = 'no' ) if ( i == n_occ + 1 ) write ( IW , fmt = '(1X,\"LUMO\")' , advance = 'no' ) ! Add status message if ( i /= max_idx . and . max_overlap < 0.9_dp ) then write ( IW , fmt = '(1X,\"Reordered (warning: low overlap)\")' ) else if ( i /= max_idx ) then write ( IW , fmt = '(1X,\"Reordered\")' ) else if ( max_overlap < 0.9_dp ) then write ( IW , fmt = '(1X,\"Unchanged (warning: low overlap)\")' ) else write ( IW , fmt = '(1X,\"Unchanged\")' ) end if end if end if end do ! Check if all orbitals were successfully assigned if (. not . all ( reordered )) then write ( IW , fmt = '(/,\"WARNING: Some orbitals could not be properly reordered!\")' ) write ( IW , fmt = '(\"This may indicate a significant change in electronic structure.\")' ) end if ! Apply the reordering call reorder_orbitals ( v_curr , e_curr , s_mo , nbf , & start_mo = 1 , & end_mo = n_occ + 1 ) deallocate ( reordered ) end subroutine apply_mom !> @brief Reorders orbitals based on overlap with the previous iteration. !> @detail Internal helper routine for 'apply_mom' that swaps orbital !>         coefficients and energies to maximize overlap, !>         focusing on a specified range of molecular orbitals. !> @param[inout] v MO coefficients (reordered on output). !> @param[inout] e Orbital energies (reordered on output). !> @param[in] smo Overlap matrix between previous and current MOs. !> @param[in] nbf Number of basis functions. !> @param[in] start_mo First MO to reorder. !> @param[in] end_mo Last MO to reorder. subroutine reorder_orbitals ( v , e , smo , nbf , start_mo , end_mo ) use precision , only : dp implicit none real ( kind = dp ), intent ( inout ) :: v ( nbf , * ) real ( kind = dp ), intent ( inout ) :: e ( * ) real ( kind = dp ), intent ( in ) :: smo ( nbf , * ) integer , intent ( in ) :: nbf , start_mo , end_mo integer :: i , j , k , ip1 integer , allocatable :: reorder_idx (:) real ( kind = dp ) :: smax , tmp_e ! Allocate array for reordering indices allocate ( reorder_idx ( nbf ), source = 0 ) ! Determine the reordering indices based on maximum overlap do i = 1 , nbf smax = 0.0_dp reorder_idx ( i ) = 0 ! Find maximum overlap do j = 1 , nbf ! Skip already assigned orbitals if ( any ( reorder_idx ( 1 : i - 1 ) == j )) cycle if ( abs ( smo ( i , j )) > smax ) then smax = abs ( smo ( i , j )) reorder_idx ( i ) = j end if end do ! Ensure sign consistency if ( smo ( i , reorder_idx ( i )) < 0.0_dp ) then v (:, reorder_idx ( i )) = - v (:, reorder_idx ( i )) end if end do ! Apply reordering for the specified range do i = start_mo , end_mo j = reorder_idx ( i ) ! Swap orbital coefficients call dswap ( nbf , v ( 1 , i ), 1 , v ( 1 , j ), 1 ) ! Swap orbital energies tmp_e = e ( i ) e ( i ) = e ( j ) e ( j ) = tmp_e ! Update reordering indices for remaining swaps ip1 = i + 1 do k = ip1 , end_mo if ( reorder_idx ( k ) == i ) reorder_idx ( k ) = j end do end do deallocate ( reorder_idx ) end subroutine reorder_orbitals !> @brief Computes fractional occupation numbers using !>        the pseudo-Fractional Occupation Number (pFON) method. !> @detail Implements the pFON method to assign fractional occupations !>         via a Fermi-Dirac distribution, smoothing near-degenerate states. !>         Reference: https://doi.org/10.1063/1.478177 !> @author Alireza Lashkaripour, January 2025 !> @param[in] mo_energy Orbital energies. !> @param[in] nbf Number of basis functions. !> @param[in] nelec Total number of electrons. !> @param[inout] occ Occupation numbers (updated on output). !> @param[in] beta_pfon Inverse temperature parameter (1/(kB * T)). !> @param[in] scf_type SCF type (1=RHF, 2=UHF, 3=ROHF). !> @param[in] nsmear Number of orbitals to smear around the Fermi level. !> @param[in] is_beta Flag indicating beta spin calculation (optional). !> @param[in] nelec_a Number of alpha electrons (for UHF/ROHF). !> @param[in] nelec_b Number of beta electrons (for UHF/ROHF). subroutine pfon_occupations ( mo_energy , nbf , nelec , occ , beta_pfon , & scf_type , nsmear , is_beta , nelec_a , nelec_b ) use precision , only : dp implicit none integer , intent ( in ) :: nbf integer , intent ( in ) :: nelec , nsmear real ( kind = dp ), intent ( in ) :: beta_pfon real ( kind = dp ), intent ( in ) :: mo_energy ( nbf ) real ( kind = dp ), intent ( inout ) :: occ ( nbf ) integer , intent ( in ) :: scf_type ! 1,2,3 RHF,UHF,ROHF logical , intent ( in ), optional :: is_beta integer , intent ( in ), optional :: nelec_a , nelec_b real ( kind = dp ) :: eF , sum_occ integer :: i , i_homo , i_lumo , i_low , i_high real ( kind = dp ) :: tmp logical :: is_beta_calc integer :: n_electrons , n_double , n_single is_beta_calc = . false . if ( present ( is_beta )) is_beta_calc = is_beta select case ( scf_type ) case ( 1 ) ! RHF i_homo = max ( 1 , nelec / 2 ) n_electrons = nelec case ( 2 ) ! UHF if (. not . present ( nelec_a ) . or . . not . present ( nelec_b )) then stop 'UHF requires nelec_a and nelec_b' end if ! UHF: completely independent alpha and beta if ( is_beta_calc ) then i_homo = max ( 1 , nelec_b ) n_electrons = nelec_b else i_homo = max ( 1 , nelec_a ) n_electrons = nelec_a end if case ( 3 ) ! ROHF if (. not . present ( nelec_a ) . or . . not . present ( nelec_b )) then stop 'ROHF requires nelec_a and nelec_b' end if ! ROHF: same spatial orbitals, different occupations n_double = nelec_b n_single = nelec_a - nelec_b if ( is_beta_calc ) then i_homo = n_double n_electrons = nelec_b else i_homo = n_double + n_single n_electrons = nelec_a end if end select i_lumo = i_homo + 1 if ( i_lumo > nbf ) i_lumo = nbf ! Calculate Fermi level eF = 0.5_dp * ( mo_energy ( i_homo ) + mo_energy ( i_lumo )) if ( nsmear <= 0 ) then do i = 1 , nbf tmp = beta_pfon * ( mo_energy ( i ) - eF ) if ( scf_type == 1 ) then ! RHF occ ( i ) = 2.0_dp / ( 1.0_dp + exp ( tmp )) else ! UHF or ROHF occ ( i ) = 1.0_dp / ( 1.0_dp + exp ( tmp )) end if end do else i_low = max ( 1 , i_homo - nsmear ) i_high = min ( nbf , i_lumo + nsmear ) ! Special handling for ROHF if ( scf_type == 3 ) then if ( is_beta_calc ) then do i = 1 , n_double occ ( i ) = 1.0_dp end do do i = n_double + 1 , nbf occ ( i ) = 0.0_dp end do else do i = 1 , n_double occ ( i ) = 1.0_dp end do do i = n_double + 1 , n_double + n_single occ ( i ) = 1.0_dp end do do i = n_double + n_single + 1 , nbf occ ( i ) = 0.0_dp end do end if ! Apply smearing only around the Fermi level do i = i_low , i_high tmp = beta_pfon * ( mo_energy ( i ) - eF ) occ ( i ) = occ ( i ) / ( 1.0_dp + exp ( tmp )) end do else ! RHF/UHF handling do i = 1 , i_low - 1 if ( scf_type == 1 ) then occ ( i ) = 2.0_dp else occ ( i ) = 1.0_dp end if end do do i = i_high + 1 , nbf occ ( i ) = 0.0_dp end do do i = i_low , i_high tmp = beta_pfon * ( mo_energy ( i ) - eF ) if ( scf_type == 1 ) then occ ( i ) = 2.0_dp / ( 1.0_dp + exp ( tmp )) else occ ( i ) = 1.0_dp / ( 1.0_dp + exp ( tmp )) end if end do end if end if ! Normalize occupations sum_occ = sum ( occ ( 1 : nbf )) if ( sum_occ < 1.0e-14_dp ) then sum_occ = 1.0_dp end if occ ( 1 : nbf ) = occ ( 1 : nbf ) * ( real ( n_electrons , dp ) / sum_occ ) end subroutine pfon_occupations !> @brief Builds density matrices using fractional occupation numbers for the pFON method. !> @detail Constructs density matrices from molecular orbital coefficients !>         and fractional occupations. !> @param[inout] pdmat Density matrices (triangular format, updated on output). !> @param[in] mo_a Alpha MO coefficients. !> @param[in] mo_b Beta MO coefficients (UHF only). !> @param[in] occ_a Alpha occupation numbers. !> @param[in] occ_b Beta occupation numbers (UHF/ROHF). !> @param[in] scf_type SCF type (1=RHF, 2=UHF, 3=ROHF). !> @param[in] nbf Number of basis functions. !> @param[in] nelec_a Number of alpha electrons. !> @param[in] nelec_b Number of beta electrons. !> @param[inout] dtmp Work array for density matrix construction. !> @param[inout] work Additional work array. subroutine build_pfon_density ( pdmat_a , mo_a , occ_a , scf_type , nbf , dtmp , work , & pdmat_b , mo_b , occ_b , nelec_a , nelec_b ) use precision , only : dp use mathlib , only : pack_matrix implicit none real ( kind = dp ), intent ( inout ) :: pdmat_a (:) real ( kind = dp ), intent ( in ) :: mo_a (:,:) real ( kind = dp ), intent ( in ) :: occ_a (:) integer , intent ( in ) :: nbf , scf_type real ( kind = dp ), intent ( inout ) :: dtmp (:,:), work (:,:) real ( kind = dp ), intent ( inout ), optional :: pdmat_b (:) real ( kind = dp ), intent ( in ), optional :: mo_b (:,:) real ( kind = dp ), intent ( in ), optional :: occ_b (:) integer , intent ( in ), optional :: nelec_a , nelec_b integer :: i , mu , nu integer :: n_double , n_single real ( kind = dp ) :: occ_factor select case ( scf_type ) case ( 1 ) ! RHF ! Scale MO coefficients by square root of occupation numbers do i = 1 , nbf if ( occ_a ( i ) > 1.0e-14_dp ) then call dger ( nbf , nbf , occ_a ( i ), mo_a (:, i ), 1 , mo_a (:, i ), 1 , dtmp , nbf ) end if end do pdmat_a = 0.0_dp call pack_matrix ( dtmp , pdmat_a ) case ( 2 ) ! UHF do i = 1 , nbf if ( occ_a ( i ) > 1.0e-14_dp ) then call dger ( nbf , nbf , occ_a ( i ), mo_a (:, i ), 1 , mo_a (:, i ), 1 , dtmp , nbf ) end if end do pdmat_a = 0.0_dp call pack_matrix ( dtmp , pdmat_a ) dtmp (:,:) = 0.0_dp do i = 1 , nbf if ( occ_b ( i ) > 1.0e-14_dp ) then call dger ( nbf , nbf , occ_b ( i ), mo_b (:, i ), 1 , mo_b (:, i ), 1 , dtmp , nbf ) end if end do pdmat_b = 0.0_dp call pack_matrix ( dtmp , pdmat_b ) case ( 3 ) ! ROHF n_double = nelec_b n_single = nelec_a - nelec_b dtmp (:,:) = 0.0_dp do i = 1 , nbf if ( occ_a ( i ) > 1.0e-14_dp ) then if ( i <= n_double ) then occ_factor = occ_a ( i ) else if ( i <= n_double + n_single ) then occ_factor = 1.0_dp else occ_factor = occ_a ( i ) ! Virtual orbitals end if ! dtmp += occ_factor * mo_a(:,i) * mo_a(:,i)&#94;T !         call dger(nbf, nbf, occ_factor, mo_a(:,i), 1, mo_a(:,i), 1, dtmp, nbf) do mu = 1 , nbf do nu = 1 , nbf dtmp ( mu , nu ) = dtmp ( mu , nu ) + occ_factor * mo_a ( mu , i ) * mo_a ( nu , i ) end do end do end if end do pdmat_a = 0.0_dp call pack_matrix ( dtmp , pdmat_a ) dtmp (:,:) = 0.0_dp do i = 1 , nbf if ( occ_b ( i ) > 1.0e-14_dp ) then if ( i <= n_double ) then occ_factor = occ_b ( i ) else occ_factor = 0.0_dp end if ! dtmp += occ_factor * mo_a(:,i) * mo_a(:,i)&#94;T !         call dger(nbf, nbf, occ_factor, mo_a(:,i), 1, mo_a(:,i), 1, dtmp, nbf) do mu = 1 , nbf do nu = 1 , nbf dtmp ( mu , nu ) = dtmp ( mu , nu ) + occ_factor * mo_a ( mu , i ) * mo_a ( nu , i ) end do end do end if end do pdmat_b = 0.0_dp call pack_matrix ( dtmp , pdmat_b ) end select end subroutine build_pfon_density !> @brief Applies level shifting to the Fock matrix for improved SCF convergence. !> @detail Modifies the diagonal elements of the Fock matrix in the MO basis !>         for virtual orbitals by adding a shift parameter, !>         then transforms the result back to the AO basis. !> @param[inout] fock_ao Fock matrix in AO basis (triangular format, updated on output). !> @param[in] mo_coefs MO coefficients. !> @param[in] smat_full Full overlap matrix. !> @param[in] nocc Number of occupied orbitals. !> @param[in] nbf Number of basis functions. !> @param[in] vshift Level shift parameter value. subroutine level_shift_fock ( fock_ao , mo_coefs , smat_full , nocc , nbf , vshift , & work1 , work2 ) use precision , only : dp use mathlib , only : orthogonal_transform_sym , & orthogonal_transform2 , & unpack_matrix , & pack_matrix implicit none integer , intent ( in ) :: nocc , nbf real ( kind = dp ), intent ( inout ) :: fock_ao (:) real ( kind = dp ), intent ( in ) :: mo_coefs (:,:) real ( kind = dp ), intent ( in ) :: smat_full (:,:) real ( kind = dp ), intent ( in ) :: vshift real ( kind = dp ), intent ( inout ) :: work1 (:,:) real ( kind = dp ), intent ( inout ) :: work2 (:,:) ! Local variables real ( kind = dp ), allocatable :: fock_mo_full (:,:), fock_mo (:), work_matrix (:,:) integer :: i , nbf_tri nbf_tri = nbf * ( nbf + 1 ) / 2 work1 = 0.0_dp work2 = 0.0_dp ! Allocate work arrays allocate ( fock_mo_full ( nbf , nbf ), & fock_mo ( nbf_tri ), & work_matrix ( nbf , nbf ), & source = 0.0_dp ) ! Transform Fock from AO to MO basis: F_MO = C&#94;T * F_AO * C call orthogonal_transform_sym ( nbf , nbf , fock_ao , mo_coefs , nbf , fock_mo ) ! Unpack triangular matrices to full format call unpack_matrix ( fock_mo , fock_mo_full ) ! Apply level shift to virtual orbitals in F_MO do i = nocc + 1 , nbf fock_mo_full ( i , i ) = fock_mo_full ( i , i ) + vshift end do ! Back-transform ROHF Fock matrix to AO basis call dsymm ( 'l' , 'u' , nbf , nbf , & 1.0_dp , smat_full , nbf , & mo_coefs , nbf , & 0.0_dp , work1 , nbf ) call orthogonal_transform2 ( 't' , nbf , nbf , work1 , nbf , fock_mo_full , nbf , & work_matrix , nbf , work2 ) ! Pack the result back to triangular form call pack_matrix ( work_matrix , fock_ao ) deallocate ( fock_mo_full , fock_mo , work_matrix ) end subroutine level_shift_fock !> @brief Initialize pFON parameters !> @detail Sets up temperature, inverse temperature (beta), !>         and other pFON parameters based on input controls. !> @param[in] control Control structure containing pFON settings !> @param[in] nbf Number of basis functions !> @param[in] nelec Total number of electrons !> @param[in] nelec_a Number of alpha electrons !> @param[in] nelec_b Number of beta electrons !> @param[in] scf_type SCF type (1=RHF, 2=UHF, 3=ROHF) !> @param[inout] occ_a Pointer to alpha occupations array !> @param[inout] occ_b Pointer to beta occupations array (only for UHF/ROHF) subroutine pfon_init ( this , control , nbf , nelec , nelec_a , nelec_b , scf_type , occ_a , occ_b ) use types , only : control_parameters use constants , only : kB_HaK implicit none class ( pfon_t ), intent ( inout ) :: this type ( control_parameters ), intent ( in ) :: control integer , intent ( in ) :: nbf , nelec , nelec_a , nelec_b , scf_type real ( dp ), target , intent ( inout ) :: occ_a (:) real ( dp ), target , optional , intent ( inout ) :: occ_b (:) this % active = control % pfon if (. not . this % active ) return this % nbf = nbf this % nelec = nelec this % nelec_a = nelec_a this % nelec_b = nelec_b this % scf_type = scf_type ! Set temperature parameters this % temp = control % pfon_start_temp if ( this % temp <= 0.0_dp ) this % temp = 200 0.0_dp ! Default temperature this % beta = 1.0_dp / ( kB_HaK * this % temp ) this % cooling_rate = control % pfon_cooling_rate if ( this % cooling_rate <= 0.0_dp ) this % cooling_rate = 5 0.0_dp ! Set number of orbitals to smear this % nsmear = int ( control % pfon_nsmear ) ! Set pointers to occupation arrays this % occ_a => occ_a if ( present ( occ_b )) this % occ_b => occ_b end subroutine pfon_init !> @brief Adjust pFON temperature based on convergence status !> @detail Dynamically modifies the temperature and beta parameters during SCF !>         iterations, reducing temperature as convergence improves. !> @param[in] iter Current SCF iteration !> @param[in] maxit Maximum number of SCF iterations !> @param[in] diis_error Current DIIS error !> @param[in] conv Convergence threshold subroutine pfon_adjust_temperature ( this , iter , maxit , diis_error , conv , do_pfon , do_final ) use constants , only : kB_HaK use io_constants , only : iw class ( pfon_t ), intent ( inout ) :: this integer , intent ( in ) :: iter , maxit real ( dp ), intent ( in ) :: diis_error , conv logical , intent ( in ) :: do_final , do_pfon if (. not . do_pfon ) return if (. not . this % active ) return if ( do_final ) then this % temp = 1.0_dp this % beta = 1.0_dp / ( kB_HaK * this % temp ) write ( IW , \"(10x, 'Extra SCF iteration with Temp = 1K')\" ) end if if ( iter == maxit ) then ! Final iteration: set temperature to zero for pure integer occupations this % temp = 0.0_dp else if ( abs ( diis_error ) < 1 0.0_dp * conv ) then ! Near convergence: set to minimum temperature (1K) if ( this % temp > 1.0_dp ) then this % last_cooled_temp = this % temp end if this % temp = 1.0_dp else ! Not converged yet: continue cooling temperature if ( this % temp == 1.0_dp . and . this % last_cooled_temp > 1.0_dp ) then this % temp = this % last_cooled_temp end if this % temp = this % temp - this % cooling_rate if ( this % temp < 1.0_dp ) then this % temp = 1.0_dp end if this % last_cooled_temp = this % temp end if ! Calculate beta = 1/(kB*T) for Fermi-Dirac distribution if ( this % temp > 1.0e-12_dp ) then this % beta = 1.0_dp / ( kB_HaK * this % temp ) else this % beta = 1.0e20_dp ! Zero temperature end if end subroutine pfon_adjust_temperature !> @brief Compute fractional occupation numbers using pFON method !> @detail Uses current orbital energies to calculate occupations !>         via a Fermi-Dirac distribution. !> @param[in] mo_energy_a Alpha orbital energies !> @param[in] mo_energy_b Beta orbital energies (only for UHF) subroutine pfon_compute_occupations ( this , mo_energy_a , do_pfon , mo_energy_b ) class ( pfon_t ), intent ( inout ) :: this real ( dp ), intent ( in ) :: mo_energy_a (:) real ( dp ), intent ( in ), optional :: mo_energy_b (:) logical , intent ( in ) :: do_pfon if (. not . do_pfon ) return if (. not . this % active ) return ! Calculate alpha occupations call pfon_occupations ( mo_energy_a , this % nbf , this % nelec , this % occ_a , & this % beta , this % scf_type , this % nsmear , & is_beta = . false ., nelec_a = this % nelec_a , nelec_b = this % nelec_b ) ! Calculate beta occupations if needed if ( this % scf_type > 1 . and . associated ( this % occ_b )) then if ( this % scf_type == 2 . and . present ( mo_energy_b )) then ! UHF case - use separate beta orbital energies call pfon_occupations ( mo_energy_b , this % nbf , this % nelec , this % occ_b , & this % beta , this % scf_type , this % nsmear , & is_beta = . true ., nelec_a = this % nelec_a , nelec_b = this % nelec_b ) else ! ROHF case - use same orbital energies for alpha and beta call pfon_occupations ( mo_energy_a , this % nbf , this % nelec , this % occ_b , & this % beta , this % scf_type , this % nsmear , & is_beta = . true ., nelec_a = this % nelec_a , nelec_b = this % nelec_b ) end if end if end subroutine pfon_compute_occupations !> @brief Build density matrices using fractional occupation numbers !> @detail Constructs density matrices for the current SCF iteration !>         using fractional occupations and MO coefficients. !> @param[inout] this pFON type instance. !> @param[out] pdmat Density matrices (triangular format). !> @param[in] mo_a Alpha MO coefficients. !> @param[inout] work1 Work array 1. !> @param[inout] work2 Work array 2. !> @param[in] mo_b Beta MO coefficients (optional for UHF). subroutine pfon_build_density ( this , pdmat_a , mo_a , work1 , work2 , do_pfon , pdmat_b , mo_b ) class ( pfon_t ), intent ( inout ) :: this real ( kind = dp ), intent ( out ) :: pdmat_a (:) real ( kind = dp ), intent ( in ) :: mo_a (:,:) real ( kind = dp ), intent ( inout ) :: work1 (:,:) real ( kind = dp ), intent ( inout ) :: work2 (:,:) real ( kind = dp ), intent ( out ), optional :: pdmat_b (:) real ( kind = dp ), intent ( in ), optional :: mo_b (:,:) logical , intent ( in ) :: do_pfon if (. not . do_pfon ) return if (. not . this % active ) return ! Nullify work arrays work1 = 0.0_dp work2 = 0.0_dp ! Call the existing build_pfon_density function with appropriate parameters select case ( this % scf_type ) case ( 1 ) ! RHF call build_pfon_density ( pdmat_a , mo_a , this % occ_a , this % scf_type , this % nbf , & work1 , work2 ) case ( 2 ) ! UHF call build_pfon_density ( pdmat_a , mo_a , this % occ_a , this % scf_type , this % nbf , & work1 , work2 , pdmat_b , mo_b , this % occ_b ) case ( 3 ) ! ROHF call build_pfon_density ( pdmat_a , mo_a , this % occ_a , this % scf_type , this % nbf , & work1 , work2 , pdmat_b , mo_b , this % occ_b , this % nelec_a , this % nelec_b ) end select end subroutine pfon_build_density !> @brief Computes the two-electron part (Coulomb and exchange) of the Fock matrix. !> @detail Forms the Coulomb (J) and exchange (K) contributions to the Fock matrix !>         using two-electron integrals, !>         with optional scaling of the exchange term for hybrid DFT methods. !> @param[in] basis Basis set information. !> @param[in] d Density matrices (triangular format). !> @param[inout] f Fock matrices to be updated (triangular format). !> @param[in] scalefactor Optional scaling factor for exchange (default = 1.0). !> @param[inout] infos System information. subroutine fock_jk ( basis , d , f , infos , scale_exch , nschwz , f_old , scale_coul , petite ) use precision , only : dp use io_constants , only : iw use util , only : measure_time use basis_tools , only : basis_set use types , only : information use int2_compute , only : int2_compute_t , int2_fock_data_t , & int2_rhf_data_t , int2_urohf_data_t implicit none type ( basis_set ), intent ( in ) :: basis type ( information ), intent ( inout ) :: infos real ( kind = dp ), optional , intent ( in ) :: scale_exch integer , optional , intent ( inout ) :: nschwz real ( kind = dp ), optional , intent ( in ) :: scale_coul real ( kind = dp ), target , intent ( in ) :: d (:,:) real ( kind = dp ), intent ( inout ) :: f (:,:) real ( kind = dp ), optional , intent ( inout ) :: f_old (:,:) !> Opt into the symmetry petite-list reduction. Only valid for totally !> symmetric densities (SCF Fock); response/CPHF/Hessian callers with !> perturbed densities must not set this. logical , optional , intent ( in ) :: petite integer :: i , ii , nf real ( kind = dp ) :: scale_e , scale_c logical :: is_dft type ( int2_compute_t ) :: int2_driver class ( int2_fock_data_t ), allocatable :: int2_data ! Initial Settings scale_e = 1.0d0 scale_c = 1.0d0 if ( present ( scale_exch )) scale_e = scale_exch if ( present ( scale_coul )) scale_c = scale_coul is_dft = ( infos % control % hamilton == 20 ) ! Initialize ERI calculations call int2_driver % init ( basis , infos ) if ( present ( petite )) then ! Petite-list reduction: only valid for totally symmetric densities ! (SCF Fock); the skeleton matrix is symmetrized below. if ( petite ) call int2_driver % enable_petite ( infos ) end if call int2_driver % set_screening () select case ( infos % control % scftype ) case ( 1 ) int2_data = int2_rhf_data_t ( nfocks = 1 , d = d , scale_exchange = scale_e , scale_coulomb = scale_c ) case ( 2 ) int2_data = int2_urohf_data_t ( nfocks = 2 , d = d , scale_exchange = scale_e , scale_coulomb = scale_c ) case ( 3 ) int2_data = int2_urohf_data_t ( nfocks = 2 , d = d , scale_exchange = scale_e , scale_coulomb = scale_c ) end select ! Constructing two electron Fock matrix call int2_driver % run ( int2_data , & cam = is_dft . and . infos % dft % cam_flag , & alpha = infos % dft % cam_alpha , & beta = infos % dft % cam_beta ,& mu = infos % dft % cam_mu ) if ( present ( nschwz )) nschwz = int2_driver % skipped ! Scaling (everything except diagonal is halved) if ( present ( f_old )) then int2_data % f (:,:, 1 ) = int2_data % f (:,:, 1 ) + f_old f_old = int2_data % f (:,:, 1 ) end if f = 0.5 * int2_data % f (:,:, 1 ) do nf = 1 , ubound ( f , 2 ) ii = 0 do i = 1 , basis % nbf ii = ii + i f ( ii , nf ) = 2 * f ( ii , nf ) end do end do ! Petite-list runs produce a skeleton matrix; project onto the ! totally symmetric component: F <- (1/|G|) sum_op T_op F T_op&#94;T. if ( int2_driver % petite ) call symmetrize_skeleton_fock ( infos , basis , f ) call int2_driver % clean () end subroutine fock_jk !-------------------------------------------------------------------------------- !> @brief Symmetrize a packed-triangular skeleton Fock matrix. !> @detail Applies F <- (1/|G|) sum_op T_op F T_op&#94;T where T_op is the !>   signed AO permutation of each abelian symmetry operation (standard !>   orientation), using the maps written by pyoqp. No-op if the maps are !>   missing. subroutine symmetrize_skeleton_fock ( infos , basis , f ) use precision , only : dp use types , only : information use basis_tools , only : basis_set use oqp_tagarray_driver use tagarray , only : TA_OK implicit none type ( information ), target , intent ( inout ) :: infos type ( basis_set ), intent ( in ) :: basis real ( kind = dp ), intent ( inout ) :: f (:,:) real ( kind = dp ), contiguous , pointer :: blocks (:) integer ( 4 ) :: status integer :: nbf nbf = basis % nbf call tagarray_get_data ( infos % dat , OQP_sym_op_blocks , blocks , status = status ) if ( status == TA_OK ) then call symmetrize_skeleton_blocked ( infos , basis , f , blocks ) else call symmetrize_skeleton_signed ( infos , nbf , f ) end if end subroutine symmetrize_skeleton_fock !-------------------------------------------------------------------------------- !> @brief Full-group skeleton symmetrization with dense per-shell blocks. !> @detail F <- (1/|G|) sum_op T_op F T_op&#94;T where T_op permutes shells and !>   mixes components within each shell (non-abelian operations such as the !>   C6 rotations of D6h). Blocks staged by pyoqp, column-major per shell, !>   concatenated shell-by-shell then op-by-op. subroutine symmetrize_skeleton_blocked ( infos , basis , f , blocks ) use precision , only : dp use types , only : information use basis_tools , only : basis_set use oqp_tagarray_driver use tagarray , only : TA_OK implicit none type ( information ), target , intent ( inout ) :: infos type ( basis_set ), intent ( in ) :: basis real ( kind = dp ), intent ( inout ) :: f (:,:) real ( kind = dp ), contiguous , intent ( in ) :: blocks (:) integer ( 8 ), contiguous , pointer :: shell_map (:) integer ( 4 ) :: status integer :: nbf , nshell , nops , iop , nf , k , j , s , off_k , off_j integer :: mu , nu , idx , blk0 , blk_per_op real ( kind = dp ), allocatable :: fsq (:,:), y (:,:), acc (:,:) call tagarray_get_data ( infos % dat , OQP_sym_shell_map , shell_map , status = status ) if ( status /= TA_OK ) return nbf = basis % nbf nshell = basis % nshell if ( mod ( size ( shell_map ), nshell ) /= 0 ) return nops = int ( size ( shell_map ) / nshell ) if ( nops < 2 ) return blk_per_op = 0 do k = 1 , nshell s = shell_size ( basis , k , nbf ) blk_per_op = blk_per_op + s * s end do if ( size ( blocks ) /= nops * blk_per_op ) return allocate ( fsq ( nbf , nbf ), y ( nbf , nbf ), acc ( nbf , nbf )) do nf = 1 , ubound ( f , 2 ) ! unpack the packed lower triangle idx = 0 do mu = 1 , nbf do nu = 1 , mu idx = idx + 1 fsq ( mu , nu ) = f ( idx , nf ) fsq ( nu , mu ) = f ( idx , nf ) end do end do acc = 0.0_dp do iop = 1 , nops ! Operator transform: F <- T&#94;T F T (T maps shell k to shell j with ! block B_k; T is metric-orthogonal, not orthogonal, so the ! transpose side matters once d shells mix under rotations). ! Y = T&#94;T F : rows of source shell k get B_k&#94;T @ rows of shell j. blk0 = ( iop - 1 ) * blk_per_op do k = 1 , nshell s = shell_size ( basis , k , nbf ) j = int ( shell_map (( iop - 1 ) * nshell + k )) off_k = basis % ao_offset ( k ) - 1 off_j = basis % ao_offset ( j ) - 1 associate ( b => reshape ( blocks ( blk0 + 1 : blk0 + s * s ), [ s , s ])) y ( off_k + 1 : off_k + s , :) = matmul ( transpose ( b ), fsq ( off_j + 1 : off_j + s , :)) end associate blk0 = blk0 + s * s end do ! acc += Y T : columns of source shell k get Y cols j @ B_k. blk0 = ( iop - 1 ) * blk_per_op do k = 1 , nshell s = shell_size ( basis , k , nbf ) j = int ( shell_map (( iop - 1 ) * nshell + k )) off_k = basis % ao_offset ( k ) - 1 off_j = basis % ao_offset ( j ) - 1 associate ( b => reshape ( blocks ( blk0 + 1 : blk0 + s * s ), [ s , s ])) acc (:, off_k + 1 : off_k + s ) = acc (:, off_k + 1 : off_k + s ) & + matmul ( y (:, off_j + 1 : off_j + s ), b ) end associate blk0 = blk0 + s * s end do end do acc = acc / real ( nops , dp ) idx = 0 do mu = 1 , nbf do nu = 1 , mu idx = idx + 1 f ( idx , nf ) = acc ( mu , nu ) end do end do end do contains integer function shell_size ( basis , k , nbf ) result ( s ) type ( basis_set ), intent ( in ) :: basis integer , intent ( in ) :: k , nbf if ( k < basis % nshell ) then s = basis % ao_offset ( k + 1 ) - basis % ao_offset ( k ) else s = nbf - basis % ao_offset ( k ) + 1 end if end function shell_size end subroutine symmetrize_skeleton_blocked !-------------------------------------------------------------------------------- !> @brief Abelian (signed-permutation) skeleton symmetrization. subroutine symmetrize_skeleton_signed ( infos , nbf , f ) use precision , only : dp use types , only : information use oqp_tagarray_driver use tagarray , only : TA_OK implicit none type ( information ), target , intent ( inout ) :: infos integer , intent ( in ) :: nbf real ( kind = dp ), intent ( inout ) :: f (:,:) integer ( 8 ), contiguous , pointer :: target_map (:) real ( kind = dp ), contiguous , pointer :: sign_map (:) real ( kind = dp ), allocatable :: acc (:) integer ( 4 ) :: status integer :: nops , iop , nf , mu , nu , tm , tn , a , b , idx , tidx , base call tagarray_get_data ( infos % dat , OQP_sym_ao_target , target_map , status = status ) if ( status /= TA_OK ) return call tagarray_get_data ( infos % dat , OQP_sym_ao_sign , sign_map , status = status ) if ( status /= TA_OK ) return if ( size ( sign_map ) /= size ( target_map )) return if ( mod ( size ( target_map ), nbf ) /= 0 ) return ! Flat layout, AO index fastest: target(mu, op) = target_map((op-1)*nbf+mu). nops = int ( size ( target_map ) / nbf ) if ( nops < 2 ) return allocate ( acc ( nbf * ( nbf + 1 ) / 2 )) do nf = 1 , ubound ( f , 2 ) acc = 0.0_dp do iop = 1 , nops base = ( iop - 1 ) * nbf idx = 0 do mu = 1 , nbf tm = int ( target_map ( base + mu )) do nu = 1 , mu idx = idx + 1 tn = int ( target_map ( base + nu )) a = max ( tm , tn ) b = min ( tm , tn ) tidx = a * ( a - 1 ) / 2 + b acc ( tidx ) = acc ( tidx ) & + sign_map ( base + mu ) * sign_map ( base + nu ) * f ( idx , nf ) end do end do end do f (:, nf ) = acc / real ( nops , dp ) end do end subroutine symmetrize_skeleton_signed !> @brief Builds AO-space linear response vector(s) in packed (triangular) form. !> @detail Forms the Coulomb/exchange response and, when using DFT, the !>         exchange–correlation kernel contribution in AO space. !>         For RHF: v1 = J/K(dm1) + f_xc(dm1). !>         For UHF/ROHF: spin-separated v1α, v1β using dm1α, dm1β. !>         Uses `fock_jk` for J/K and `tddft_fxc` / `utddft_fxc` for the XC kernel. !>         All AO matrices are in packed (upper-triangular) storage unless noted. !> @param[in]  basis     Basis set information. !> @param[inout] infos   System/control information (used to detect SCF type and DFT flags). !> @param[in]  molGrid   DFT molecular grid (required if DFT/XC kernel is used). !> @param[inout] mo_a    AO→MO coefficients for α (nbf×nbf). May be updated by XC routines. !> @param[in]  dm1_tri   First-order AO density in packed form: !>                       RHF: (nbf*(nbf+1)/2, 1) !>                       U/R: (nbf*(nbf+1)/2, 2) for α,β. !> @param[out] v1_tri    Packed AO response vector(s), same shape as dm1_tri. !> @param[inout,opt] mo_b AO→MO coefficients for β (nbf×nbf). Required for UHF; !>                        for ROHF it may be absent, in which case α is reused. !> @author Mohsen Mazaherifar !> @date August 2025 subroutine get_response_packed ( basis , infos , molGrid , mo_a , dm1_tri , v1_tri , mo_b ) use precision , only : dp use basis_tools , only : basis_set use types , only : information use mathlib , only : unpack_matrix , pack_matrix , symmetrize_matrix use mod_dft_molgrid , only : dft_grid_t use mod_dft_gridint_fxc , only : tddft_fxc , utddft_fxc implicit none type ( basis_set ), intent ( in ) :: basis type ( information ), intent ( inout ) :: infos type ( dft_grid_t ), intent ( in ) :: molGrid real ( dp ), intent ( inout ) :: mo_a (:,:) ! nbf x nbf  (AO->MO) real ( dp ), intent ( in ) :: dm1_tri (:,:) ! nbf*(nbf+1)/2  (packed) real ( dp ), intent ( out ) :: v1_tri (:,:) ! packed AO response real ( dp ), optional , intent ( inout ) :: mo_b (:,:) integer :: nbf , nbf2 , ok logical :: is_dft ! Packed work for int2 real ( dp ), allocatable :: d_pack (:,:) ! Full AO work for XC response real ( dp ), allocatable :: dm1_full (:,:), fx_full (:,:), fx_pack (:) real ( dp ), allocatable :: dx3 (:,:,:), fx3 (:,:,:) ! rank-3 wrappers for tddft_fxc real ( kind = dp ), allocatable :: dxa (:,:,:), dxb (:,:,:) real ( kind = dp ), allocatable :: fxa (:,:,:), fxb (:,:,:) real ( dp ) :: scalefactor nbf = basis % nbf nbf2 = nbf * ( nbf + 1 ) / 2 is_dft = ( infos % control % hamilton == 20 ) if ( is_dft ) then scalefactor = infos % dft % HFscale else scalefactor = 1.0_dp end if ! --- (2) XC-kernel part (DFT only): v_xc&#94;(1) --- select case ( infos % control % scftype ) case ( scf_rhf ) call fock_jk ( basis , d = dm1_tri , f = v1_tri , scale_exch = scalefactor , infos = infos ) if ( is_dft ) then allocate ( dm1_full ( nbf , nbf ), fx_full ( nbf , nbf ), fx_pack ( nbf2 ), stat = ok ) if ( ok /= 0 ) stop \"alloc fail full\" call unpack_matrix ( dm1_tri (:, 1 ), dm1_full ) allocate ( dx3 ( nbf , nbf , 1 ), fx3 ( nbf , nbf , 1 ), stat = ok ); if ( ok /= 0 ) stop \"alloc fail dx3/fx3\" dx3 (:,:, 1 ) = dm1_full fx3 (:,:, 1 ) = 0.0_dp call tddft_fxc ( basis = basis , molGrid = molGrid , isVecs = . true ., wf = mo_a , & fx = fx3 , dx = dx3 , nmtx = 1 , threshold = 0.0_dp , infos = infos ) fx_full = fx3 (:,:, 1 ) * 0.5 call pack_matrix ( fx_full , fx_pack ) v1_tri (:, 1 ) = v1_tri (:, 1 ) + fx_pack end if case ( scf_rohf , scf_uhf ) call fock_jk ( basis , d = dm1_tri , f = v1_tri , scale_exch = scalefactor , infos = infos ) if ( is_dft ) then allocate ( dxa ( nbf , nbf , 1 ), dxb ( nbf , nbf , 1 ), fxa ( nbf , nbf , 1 ), fxb ( nbf , nbf , 1 ), fx_pack ( nbf2 ), fx_full ( nbf , nbf ), stat = ok ) if ( ok /= 0 ) stop \"alloc fail full\" call unpack_matrix ( dm1_tri (:, 1 ), dxa (:,:, 1 )) call unpack_matrix ( dm1_tri (:, 2 ), dxb (:,:, 1 )) fxa = 0 fxb = 0 call utddft_fxc ( basis = basis , molGrid = molGrid , isVecs = . true ., & wfa = mo_a , wfb = mo_b , & fxa = fxa , fxb = fxb , & dxa = dxa , dxb = dxb , & nMtx = 1 , threshold = 0.0_dp , infos = infos ) fx_full = fxa (:,:, 1 ) fx_pack = 0.0_dp call pack_matrix ( fx_full , fx_pack ) v1_tri (:, 1 ) = v1_tri (:, 1 ) + fx_pack fx_full = fxb (:,:, 1 ) fx_pack = 0.0_dp call pack_matrix ( fx_full , fx_pack ) v1_tri (:, 2 ) = v1_tri (:, 2 ) + fx_pack deallocate ( dxa , dxb , fxa , fxb , fx_pack , fx_full ) end if end select end subroutine get_response_packed !> @brief Computes DFT exchange–correlation contributions (matrix and energies). !> @detail Calls `dftexcor` to form the packed AO XC matrix pfxc and the !>         XC/total electron/kinetic energies. Handles RHF, UHF, and ROHF: !>         - RHF: single packed matrix used for both spins. !>         - UHF: separate α/β packed matrices. !>         - ROHF: β MOs are taken equal to α (mo_b := mo_a) for the call. !> @param[inout] infos   System/control information (reads SCF type). !> @param[in]    basis   Basis set information. !> @param[in]    molgrid DFT molecular grid and quadrature weights. !> @param[out]   pfxc    Packed AO XC matrix/matrices: !>                       RHF: (nbf_tri,1) !>                       U/R: (nbf_tri,2) for α,β. !> @param[out]   eexc    Exchange–correlation energy. !> @param[out]   totele  Total electron energy on the grid (xc driver report). !> @param[out]   totkin  Kinetic energy on the grid (xc driver report). !> @param[inout] mo_a    AO→MO coefficients for α (nbf×nbf). !> @param[inout] mo_b    AO→MO coefficients for β (nbf×nbf). For ROHF, set to mo_a. !> @author Mohsen Mazaherifar !> @date August 2025 subroutine calc_dft_xc ( infos , basis , molgrid , pfxc , eexc , totele , totkin , mo_a , mo_b ) use precision , only : dp use types , only : information use dft , only : dftexcor use mod_dft_molgrid , only : dft_grid_t use basis_tools , only : basis_set use oqp_tagarray_driver use tagarray , only : TA_OK implicit none type ( basis_set ), intent ( in ) :: basis type ( dft_grid_t ), intent ( in ) :: molgrid real ( kind = dp ), intent ( inout ) :: mo_a (:,:) real ( kind = dp ), intent ( inout ) :: mo_b (:,:) real ( kind = dp ), intent ( out ) :: pfxc (:,:) real ( kind = dp ), contiguous , pointer :: sym_atom_weight (:) integer ( 8 ), contiguous , pointer :: sym_petite_flag (:) integer ( 4 ) :: sym_status logical :: sym_active real ( kind = dp ), intent ( out ) :: eexc real ( kind = dp ), intent ( out ) :: totele real ( kind = dp ), intent ( out ) :: totkin type ( information ), intent ( inout ) :: infos integer :: scf_type , nbf , nbf_tri ! Local parameters for SCF type integer , parameter :: scf_rhf = 1 , scf_uhf = 2 , scf_rohf = 3 ! Initialize exchange-correlation contribution pfxc = 0.0_dp eexc = 0.0_dp totele = 0.0_dp totkin = 0.0_dp scf_type = infos % control % scftype nbf = basis % nbf nbf_tri = nbf * ( nbf + 1 ) / 2 ! Symmetry XC reduction: integrate only unique atoms' grid slices ! (orbit-weighted) and symmetrize the resulting skeleton XC matrix. ! Gated by the same petite flag as the two-electron reduction, so the ! stability-stage fail-safe applies here as well. sym_active = . false . sym_atom_weight => null () call tagarray_get_data ( infos % dat , OQP_sym_petite , sym_petite_flag , status = sym_status ) if ( sym_status == TA_OK ) then if ( sym_petite_flag ( 1 ) /= 0 ) then call tagarray_get_data ( infos % dat , OQP_sym_atom_weight , sym_atom_weight , & status = sym_status ) sym_active = sym_status == TA_OK if ( sym_active ) sym_active = size ( sym_atom_weight ) == infos % mol_prop % natom end if end if ! Calculate exchange-correlation based on SCF type if ( sym_active ) then if ( scf_type == scf_rhf ) then call dftexcor ( basis , molgrid , 1 , pfxc , pfxc , mo_a , mo_a , & nbf , nbf_tri , eexc , totele , totkin , infos , sym_atom_weight ) else if ( scf_type == scf_uhf ) then call dftexcor ( basis , molgrid , 2 , pfxc (:, 1 ), pfxc (:, 2 ), mo_a , mo_b , & nbf , nbf_tri , eexc , totele , totkin , infos , sym_atom_weight ) else if ( scf_type == scf_rohf ) then mo_b = mo_a call dftexcor ( basis , molgrid , 2 , pfxc (:, 1 ), pfxc (:, 2 ), mo_a , mo_b , & nbf , nbf_tri , eexc , totele , totkin , infos , sym_atom_weight ) end if ! The reduced-grid XC matrix is a skeleton: project onto the totally ! symmetric component (the XC energy/electron count are already exact). call symmetrize_skeleton_fock ( infos , basis , pfxc ) else if ( scf_type == scf_rhf ) then ! Restricted calculation - same matrix for alpha and beta call dftexcor ( basis , molgrid , 1 , pfxc , pfxc , mo_a , mo_a , & nbf , nbf_tri , eexc , totele , totkin , infos ) else if ( scf_type == scf_uhf ) then ! Unrestricted calculation - separate matrices for alpha and beta call dftexcor ( basis , molgrid , 2 , pfxc (:, 1 ), pfxc (:, 2 ), mo_a , mo_b , & nbf , nbf_tri , eexc , totele , totkin , infos ) else if ( scf_type == scf_rohf ) then ! Restricted open-shell calculation ! ROHF does not have MO_B, so we copy MO_A to MO_B mo_b = mo_a call dftexcor ( basis , molgrid , 2 , pfxc (:, 1 ), pfxc (:, 2 ), mo_a , mo_b , & nbf , nbf_tri , eexc , totele , totkin , infos ) end if end subroutine calc_dft_xc !> @brief Computes DFT exchange-correlation contributions from explicit AO density matrices. subroutine calc_dft_xc_density ( infos , basis , molgrid , dmat , pfxc , eexc , totele , totkin ) use precision , only : dp use types , only : information use mod_dft_molgrid , only : dft_grid_t use basis_tools , only : basis_set use mod_dft_gridint_energy , only : dmatd_density_blk use mathlib , only : unpack_matrix implicit none type ( information ), intent ( inout ) :: infos type ( basis_set ), intent ( in ) :: basis type ( dft_grid_t ), intent ( in ) :: molgrid real ( kind = dp ), intent ( in ) :: dmat (:,:) real ( kind = dp ), intent ( out ) :: pfxc (:,:) real ( kind = dp ), intent ( out ) :: eexc , totele , totkin integer :: scf_type , nbf , nbf_tri , nang logical :: urohf real ( kind = dp ), allocatable :: da (:,:), db (:,:) scf_type = infos % control % scftype urohf = scf_type /= scf_rhf nbf = basis % nbf nbf_tri = nbf * ( nbf + 1 ) / 2 nang = maxval ( basis % am ) + 1 + 1 allocate ( da ( nbf , nbf ), source = 0.0_dp ) call unpack_matrix ( dmat (:, 1 ), da , nbf , \"U\" ) allocate ( db ( nbf , nbf ), source = 0.0_dp ) if ( urohf . and . size ( dmat , 2 ) > 1 ) then call unpack_matrix ( dmat (:, 2 ), db , nbf , \"U\" ) else db = da end if pfxc = 0.0_dp call dmatd_density_blk ( basis , molgrid , da , db , pfxc (:, 1 ), pfxc (:, min ( 2 , size ( pfxc , 2 ))), & eexc , totele , totkin , nang , nbf , infos % dft % grid_density_cutoff , & urohf , infos ) deallocate ( da , db ) end subroutine calc_dft_xc_density !> @brief Builds J/K (and optional DFT XC) Fock contribution(s) and energies. !> @detail Forms two-electron Fock using `fock_jk`, adds the one-electron core !>         Hamiltonian, and accumulates SCF energy components: !>         E_hf1 = Tr[D·Hcore], E_hf = ½·Σ_i Tr[D_i·F_i] + ½·E_hf1, E_tot = E_hf + E_nuc. !>         If DFT (infos%control%hamilton ≥ 20), adds packed XC matrix (via `calc_dft_xc`) !>         and XC energy to F and E. !>         Supports incremental updates when both d_old and f_old are provided: !>         builds F for ΔD = D − D_old, accumulates into F (and updates D_old,F_old). !> @param[in]     basis    Basis set information. !> @param[inout]  infos    System/control information and runtime data. !> @param[inout]  d        Packed AO density(ies), shape (nbf_tri,nfocks). !> @param[in]     hcore    Packed one-electron core Hamiltonian (nbf_tri). !> @param[in]     nfocks   Number of spin blocks: 1 (RHF) or 2 (UHF/ROHF). !> @param[inout]  f        Packed Fock matrix(ces) to fill (nbf_tri,nfocks). !> @param[inout]  E        SCF energy accumulator (ehf1, ehf, etot, … are updated). !> @param[in,opt] molgrid  DFT grid (required if DFT is active). !> @param[inout,opt] mo_a  AO→MO α (nbf×nbf); required if DFT is active. !> @param[inout,opt] mo_b  AO→MO β (nbf×nbf); required for UHF. For ROHF α is reused. !> @param[inout]  nschwz   (Output) number of Schwarz-screened quartets (from ERI driver). !> @param[inout,opt] f_old Previously accumulated packed Fock(ces) for incremental build. !> @param[inout,opt] d_old Previous packed density(ies) for incremental build. !> @note For DFT hybrids, exchange scaling is taken from infos%dft%HFscale. !> @note Continuum solvent (PCM) is the single canonical runtime path: gated on !>       infos%control%pcm_enabled, applied via add_pcm_reaction_field, and !>       reported in E%e_pcm. There is no second reaction-field hook. !> @throws error stop if DFT is requested but molgrid/mo_a are not provided. !> @author Mohsen Mazaherifar !> @date August 2025 subroutine calc_jk_xc ( basis , infos , d , hcore , nfocks , f , E , & molgrid , mo_a , mo_b , nschwz , f_old , d_old , density_xc , xc_reuse ) use precision , only : dp use basis_tools , only : basis_set use types , only : information use mod_dft_molgrid , only : dft_grid_t use mathlib , only : traceprod_sym_packed use solvent_pcm , only : add_pcm_reaction_field use mod_dft_incdft , only : g_xc_ref , incdft_store implicit none type ( basis_set ), intent ( in ) :: basis type ( information ), intent ( inout ) :: infos real ( dp ), intent ( inout ) :: d (:,:) ! (nbf_tri, nfocks) real ( dp ), intent ( in ) :: hcore (:) type ( scf_energy_t ), intent ( inout ) :: E type ( dft_grid_t ), intent ( in ), optional :: molgrid real ( dp ), intent ( inout ), optional :: mo_a (:,:) ! (nbf, nbf) real ( dp ), intent ( inout ), optional :: mo_b (:,:) ! (nbf, nbf) real ( dp ), intent ( inout ) :: f (:,:) ! (nbf_tri, nfocks) real ( dp ), intent ( inout ), optional :: d_old (:,:), f_old (:,:) logical , intent ( in ), optional :: density_xc integer , intent ( inout ) :: nschwz integer , intent ( in ) :: nfocks !> Opt 2 (IncDFT): when present and .true., reuse the stored reference XC !> matrix/energy instead of rebuilding from the density this iteration. logical , intent ( in ), optional :: xc_reuse real ( dp ) :: scale_factor integer :: scf_type , nbf integer :: ii real ( dp ), allocatable :: pfxc (:,:) logical :: is_dft = . false ., use_density_xc logical :: xc_reused ! Env-gated (OQP_XC_TIMING) per-iteration wall split: J/K vs XC build. logical :: do_t character ( len = 8 ) :: tenv integer :: tst , tln integer ( 8 ) :: clk0 , clk1 , clkr real ( dp ) :: wall_jk , wall_xc call get_environment_variable ( 'OQP_XC_TIMING' , tenv , length = tln , status = tst ) do_t = ( tst == 0 . and . tln > 0 . and . & ( tenv ( 1 : 1 ) == '1' . or . tenv ( 1 : 1 ) == 't' . or . tenv ( 1 : 1 ) == 'T' . or . & tenv ( 1 : 1 ) == 'y' . or . tenv ( 1 : 1 ) == 'Y' . or . tenv ( 1 : 1 ) == 'o' . or . tenv ( 1 : 1 ) == 'O' )) wall_jk = 0.0_dp ; wall_xc = 0.0_dp call system_clock ( count_rate = clkr ) is_dft = infos % control % hamilton >= 20 use_density_xc = . false . if ( present ( density_xc )) use_density_xc = density_xc if ( is_dft ) then scale_factor = infos % dft % HFscale else scale_factor = 1.0_dp end if nbf = basis % nbf if ( do_t ) call system_clock ( count = clk0 ) if ( present ( d_old ) . and . present ( f_old )) then d = d - d_old call fock_jk ( basis , d , f , infos , scale_factor , nschwz , f_old , petite = . true .) d = d + d_old d_old = d else call fock_jk ( basis , d , f , infos , scale_factor , nschwz , petite = . true .) end if if ( do_t ) then call system_clock ( count = clk1 ) wall_jk = real ( clk1 - clk0 , dp ) / real ( clkr , dp ) end if ii = 0 do ii = 1 , nfocks f (:, ii ) = f (:, ii ) + hcore end do !---------------------------------------------------------------------------- ! Compute HF Energy Components !---------------------------------------------------------------------------- E % ehf = 0.0_dp E % ehf1 = 0.0_dp ! compute one and two-electron energies do ii = 1 , nfocks E % ehf1 = E % ehf1 + traceprod_sym_packed ( d (:, ii ), hcore , nbf ) E % ehf = E % ehf + traceprod_sym_packed ( d (:, ii ), f (:, ii ), nbf ) end do E % ehf = 0.5_dp * ( E % ehf + E % ehf1 ) E % etot = E % ehf + E % nenergy ! PCM solvent reaction field (provisional energy-only path; ddX backend). ! Mirrors the XC pattern below: the V_pcm operator is added to the Fock ! blocks used for the next density update, and a distinct E_pcm term is ! added to the total energy. It is applied AFTER the vacuum HF energy is ! formed so the reaction field is not double-counted in E%ehf. Gated on ! pcm_enabled; aborts at runtime if built without ddX (OQP_ENABLE_DDX). E % e_pcm = 0.0_dp if ( infos % control % pcm_enabled ) then call add_pcm_reaction_field ( basis , infos , d , nfocks , f , E % e_pcm ) E % etot = E % etot + E % e_pcm end if if (. not . is_dft ) return if (. not . present ( molgrid ) . or . . not . present ( mo_a )) then error stop 'calc_jk_xc: DFT requested but molgrid/mo_a/mo_b not provided.' end if allocate ( pfxc ( nbf * ( nbf + 1 ) / 2 , nfocks )) pfxc = 0.0_dp if ( do_t ) call system_clock ( count = clk0 ) ! Opt 2 (IncDFT): reuse the reference XC matrix/energy when the caller signals ! the density has effectively stopped changing (controlled, late-SCF window). xc_reused = . false . if ( present ( xc_reuse )) xc_reused = xc_reuse . and . g_xc_ref % valid & . and . g_xc_ref % ntri == nbf * ( nbf + 1 ) / 2 . and . g_xc_ref % nf == nfocks if ( xc_reused ) then pfxc = g_xc_ref % vxc E % eexc = g_xc_ref % eexc E % totele = g_xc_ref % totele E % totkin = g_xc_ref % totkin g_xc_ref % reuse_run = g_xc_ref % reuse_run + 1 g_xc_ref % n_reuse = g_xc_ref % n_reuse + 1 else if ( use_density_xc ) then call calc_dft_xc_density ( infos , basis , molgrid , d , pfxc , E % eexc , E % totele , E % totkin ) else call calc_dft_xc ( infos , basis , molgrid , pfxc , E % eexc , E % totele , E % totkin , mo_a , mo_b ) end if ! Refresh the IncDFT reference from this full build (only when IncDFT is on). if ( infos % control % xc_incdft /= 0 ) call incdft_store ( pfxc , E % eexc , E % totele , E % totkin ) end if if ( do_t ) then call system_clock ( count = clk1 ) wall_xc = real ( clk1 - clk0 , dp ) / real ( clkr , dp ) write ( * , '(1x,a,f9.4,a,f9.4,a,f6.1,a,l2)' ) '[SCFTIME] wall_JK=' , wall_jk , & 's  wall_XCbuild=' , wall_xc , 's  XC_frac=' , & 10 0.0_dp * wall_xc / max ( 1.0d-12 , wall_jk + wall_xc ), '%  xc_reused=' , xc_reused end if f = f + pfxc E % etot = E % etot + E % eexc deallocate ( pfxc ) end subroutine calc_jk_xc !> @brief High-level AO-Fock builder and energy evaluation. !> @detail Retrieves required matrices/vectors from the internal tagarray !>         (Hcore, T, S, D_α[,_β], MO_α[,_β]) and constructs the packed AO !>         Fock matrix(ces) via `calc_jk_xc`. Computes one- and two-electron !>         energy components, nuclear repulsion, virial ratio, and stores !>         the packed Fock back to tagarray (FOCK_A[, FOCK_B]). !>         Supports optional overrides for MO/Density and incremental updates. !> @param[in]     basis     Basis set information. !> @param[inout]  infos     System/control information and tagarray store. !> @param[in]     molgrid   DFT molecular grid (used when DFT is active). !> @param[inout]  fock_ao   Packed AO Fock output: (nbf_tri, nfocks). !> @param[inout]  E         SCF energy structure (fields updated). !> @param[inout,opt] mo_a_in Override AO→MO α (nbf×nbf). !> @param[inout,opt] mo_b_in Override AO→MO β (nbf×nbf). !> @param[inout,opt] dens_in Override packed AO density(ies) (nbf_tri, nfocks). !> @param[inout,opt] dens_old Previous packed density(ies) for incremental build. !> @param[inout,opt] f_old    Previous packed Fock(ces) for incremental build. !> @param[inout,opt] nschwz   (Output) count of Schwarz-screened quartets. !> @note Continuum solvent (PCM) is driven entirely inside calc_jk_xc via the !>       single infos%control%pcm_enabled gate; calc_fock takes no PCM argument. !> @author Mohsen Mazaherifar !> @date August 2025 subroutine calc_fock ( basis , infos , molgrid , fock_ao , E , mo_a_in , dens_in , mo_b_in , nschwz , f_old , dens_old , xc_reuse ) use precision , only : dp use oqp_tagarray_driver use types , only : information use mod_dft_molgrid , only : dft_grid_t use basis_tools , only : basis_set use util , only : e_charge_repulsion use mathlib , only : traceprod_sym_packed , unpack_matrix implicit none type ( basis_set ), intent ( in ) :: basis type ( information ), target , intent ( inout ) :: infos type ( dft_grid_t ), intent ( in ) :: molgrid real ( dp ), intent ( inout ), target :: fock_ao (:,:) type ( scf_energy_t ), intent ( inout ) :: E ! optionals real ( dp ), intent ( inout ), optional :: mo_a_in (:,:) real ( dp ), intent ( inout ), optional :: mo_b_in (:,:) real ( dp ), intent ( inout ), optional :: dens_in (:,:) real ( dp ), intent ( inout ), optional :: dens_old (:,:) real ( dp ), intent ( inout ), optional :: f_old (:,:) integer , intent ( inout ), optional :: nschwz !> Opt 2 (IncDFT): reuse the reference XC matrix this iteration (caller-decided) logical , intent ( in ), optional :: xc_reuse ! locals integer :: nbf , nbf_tri , nfocks , nelec , scf_type , ii logical :: is_dft real ( dp ), allocatable :: pdmat (:,:), pfock (:,:) real ( dp ), contiguous , pointer :: hcore (:), tmat (:), smat (:) real ( dp ), contiguous , pointer :: dmat_a (:), dmat_b (:), fock_a (:), fock_b (:) real ( dp ), contiguous , pointer :: mo_a (:,:), mo_b (:,:) ! SCF type & sizes select case ( infos % control % scftype ) case ( 1 ); scf_type = 1 ; nfocks = 1 case ( 2 , 3 ); scf_type = 2 ; nfocks = 2 end select nelec = infos % mol_prop % nelec nbf = basis % nbf nbf_tri = nbf * ( nbf + 1 ) / 2 is_dft = infos % control % hamilton >= 20 ! tag arrays call tagarray_get_data ( infos % dat , OQP_Hcore , hcore ) call tagarray_get_data ( infos % dat , OQP_TM , tmat ) call tagarray_get_data ( infos % dat , OQP_SM , smat ) call tagarray_get_data ( infos % dat , OQP_DM_A , dmat_a ) call tagarray_get_data ( infos % dat , OQP_FOCK_A , fock_a ) call tagarray_get_data ( infos % dat , OQP_VEC_MO_A , mo_a ) if ( nfocks > 1 ) then call tagarray_get_data ( infos % dat , OQP_DM_B , dmat_b ) call tagarray_get_data ( infos % dat , OQP_FOCK_B , fock_b ) call tagarray_get_data ( infos % dat , OQP_VEC_MO_B , mo_b ) end if if ( present ( mo_a_in )) mo_a = mo_a_in if ( present ( mo_b_in ) . and . nfocks > 1 ) mo_b = mo_b_in allocate ( pdmat ( nbf_tri , nfocks )); pdmat (:, 1 ) = dmat_a if ( nfocks > 1 ) pdmat (:, 2 ) = dmat_b if ( present ( dens_in )) pdmat = dens_in E % nenergy = e_charge_repulsion ( infos % atoms % xyz , infos % atoms % zn - infos % basis % ecp_zn_num ) fock_ao = 0.0_dp if ( present ( dens_old )) then call calc_jk_xc ( basis , infos , pdmat , hcore , nfocks , & fock_ao , E , molgrid , mo_a , mo_b , nschwz , f_old , dens_old , density_xc = present ( dens_in ), & xc_reuse = xc_reuse ) else call calc_jk_xc ( basis , infos , pdmat , hcore , nfocks , & fock_ao , E , molgrid , mo_a , mo_b , nschwz , density_xc = present ( dens_in ), & xc_reuse = xc_reuse ) end if E % psinrm = 0.0_dp E % tkin = 0.0_dp do ii = 1 , nfocks E % psinrm = E % psinrm + traceprod_sym_packed ( pdmat (:, ii ), smat , nbf ) / nelec E % tkin = E % tkin + traceprod_sym_packed ( pdmat (:, ii ), tmat , nbf ) end do E % vne = E % ehf1 - E % tkin E % vee = E % etot - E % ehf1 - E % nenergy E % vnn = E % nenergy E % vtot = E % vne + E % vnn + E % vee E % virial = - E % vtot / E % tkin ! store Fock back fock_a = fock_ao (:, 1 ) if ( nfocks > 1 ) then fock_b = fock_ao (:, 2 ) end if infos % mol_energy % energy = E % etot deallocate ( pdmat ) end subroutine calc_fock function compute_energy ( energy ) result ( etot ) implicit none type ( scf_energy_t ), pointer :: energy real ( dp ) :: etot etot = energy % etot end function end module scf_addons","tags":"","url":"sourcefile/scf_addons.f90.html"},{"title":"dftd4_interface.F90 – OpenQP Fortran API","text":"Source Code !> Native DFT-D4 dispersion interface for OpenQP. !> !> Thin bind(C) shim over the dftd4 Fortran library (statically linked into !> liboqp). Replaces the former `dftd4` Python (cffi) package, which is capped !> at Python <= 3.12. This routine has no Python dependency and is called !> directly through the existing cffi boundary (see include/oqp.h). ! Kind of the integer that the dftd4 stack (mctc-lib) was compiled with for its ! `num` argument: it tracks OpenQP's BLAS integer size (BLA_SIZEOF_INTEGER) so ! the dftd4 deps are built LP64/ILP64 to match the host. OpenQP compiles this ! file with -fdefault-integer-8, so we must hand mctc the right-kind integer ! explicitly rather than relying on the default. Set in source/CMakeLists.txt. #ifndef OQP_D4_INT_KIND #define OQP_D4_INT_KIND 4 #endif module dftd4_interface use iso_c_binding use iso_fortran_env , only : wp => real64 use mctc_io , only : structure_type , new use dftd4 , only : d4_model , new_d4_model , damping_param , & get_rational_damping , get_dispersion , realspace_cutoff implicit none private public :: oqp_dftd4_disp contains !> Compute the DFT-D4 dispersion energy and (optionally) nuclear gradient. !> !>  nat      number of atoms !>  z        atomic numbers, z(nat) !>  xyz      Cartesian coordinates in Bohr, xyz(3, nat) !>  func     functional name (e.g. \"pbe0\"), not null-terminated !>  lfunc    number of characters in func !>  do_grad  /= 0 to also evaluate the gradient !>  energy   dispersion energy in Hartree !>  grad     dispersion gradient in Hartree/Bohr, grad(3, nat) (zeroed if no grad) !>  ier      0 on success, 1 if the functional has no D4 damping parameters subroutine oqp_dftd4_disp ( nat , z , xyz , func , lfunc , do_grad , energy , grad , ier ) & bind ( C , name = \"oqp_dftd4_disp\" ) integer ( c_int ), value :: nat , lfunc , do_grad integer ( c_int ), intent ( in ) :: z ( nat ) real ( c_double ), intent ( in ) :: xyz ( 3 , nat ) character ( kind = c_char ), intent ( in ) :: func ( lfunc ) real ( c_double ), intent ( out ) :: energy real ( c_double ), intent ( out ) :: grad ( 3 , nat ) integer ( c_int ), intent ( out ) :: ier type ( structure_type ) :: mol type ( d4_model ) :: disp class ( damping_param ), allocatable :: param character ( len = :), allocatable :: fname real ( wp ), allocatable :: g (:, :) real ( wp ) :: e , sig ( 3 , 3 ) integer :: i ier = 0 energy = 0.0_c_double grad = 0.0_c_double fname = '' do i = 1 , lfunc fname = fname // func ( i ) end do call new ( mol , num = int ( z , OQP_D4_INT_KIND ), xyz = real ( xyz , wp )) call new_d4_model ( disp , mol ) call get_rational_damping ( trim ( fname ), param , s9 = 1.0_wp ) if (. not . allocated ( param )) then ier = 1 return end if if ( do_grad /= 0 ) then allocate ( g ( 3 , nat )) ! NB: dftd4's get_dispersion writes to `sigma` unconditionally whenever a ! gradient is requested, despite it being declared optional (see the dftd4 ! C API in src/dftd4/api.f90). It MUST be supplied here or it SIGBUSes. call get_dispersion ( mol , disp , param , realspace_cutoff (), e , gradient = g , sigma = sig ) grad = real ( g , c_double ) else call get_dispersion ( mol , disp , param , realspace_cutoff (), e ) end if energy = real ( e , c_double ) end subroutine oqp_dftd4_disp end module dftd4_interface","tags":"","url":"sourcefile/dftd4_interface.f90.html"},{"title":"hf_energy.f90 – OpenQP Fortran API","text":"Source Code module hf_energy_mod implicit none character ( len =* ), parameter :: module_name = \"hf_energy_mod\" private public hf_energy contains subroutine hf_energy_C ( c_handle ) bind ( C , name = \"hf_energy\" ) use c_interop , only : oqp_handle_t , oqp_handle_get_info use types , only : information type ( oqp_handle_t ) :: c_handle type ( information ), pointer :: inf inf => oqp_handle_get_info ( c_handle ) call hf_energy ( inf ) end subroutine hf_energy_C subroutine hf_energy ( infos ) use io_constants , only : iw use basis_tools , only : basis_set use messages , only : show_message use scf , only : scf_driver use dft , only : dft_initialize , dftclean , dft_setup_descent_grid use types , only : information use oqp_tagarray_driver use strings , only : Cstring , fstring use mod_dft_molgrid , only : dft_grid_t use printing , only : print_module_info use , intrinsic :: iso_c_binding , only : c_int32_t , c_int64_t implicit none character ( len =* ), parameter :: subroutine_name = \"hf_energy_mod\" type ( information ), target , intent ( inout ) :: infos integer :: nbf2 , nbf , nsh2 integer ( c_int32_t ) :: ierr logical :: urohf , dft type ( basis_set ), pointer :: basis type ( dft_grid_t ) :: molGrid ! Coarse->fine XC grid ramp: optional coarse \"descent\" grid (built by the ! unified policy in dft_setup_descent_grid; scf_driver ramps it to the ! production grid in the convergence tail). type ( dft_grid_t ) :: coarseGrid logical :: have_coarse urohf = infos % control % scftype == 2 . or . infos % control % scftype == 3 dft = infos % control % hamilton == 20 !   3. LOG: Write: Main output file open ( unit = iw , file = infos % log_filename , position = \"append\" ) ! call print_module_info ( 'HF_DFT_Energy' , 'Computing HF/DFT SCF Energy' ) !   Load basis set basis => infos % basis basis % atoms => infos % atoms !   Allocate memory nbf = basis % nbf nbf2 = nbf * ( nbf + 1 ) / 2 nsh2 = ( basis % nshell ** 2 + basis % nshell ) / 2 ! clean data ierr = infos % dat % create ( OQP_FOCK_A , TA_TYPE_REAL64 , int ([ nbf2 ], c_int64_t ), description = OQP_FOCK_A_comment , override = . true .) if ( urohf ) then ierr = infos % dat % create ( OQP_FOCK_B , TA_TYPE_REAL64 , int ([ nbf2 ], c_int64_t ), description = OQP_FOCK_B_comment , override = . true .) end if !   Prepare dft grid if ( dft ) call dft_initialize ( infos , basis , molGrid , verbose = . true .) !   Coarse->fine XC grid ramp: build the optional coarse \"descent\" grid under the !   single unified policy (default-on coarse-to-fine, or an opt-in progressive- !   screening request). scf_driver picks coarse vs production per iteration and !   pins to the production grid in the convergence tail. have_coarse = . false . if ( dft ) call dft_setup_descent_grid ( infos , basis , molGrid , coarseGrid , have_coarse ) !   Run HF/DFT calculation if ( have_coarse ) then call scf_driver ( basis , infos , molGrid , coarseGrid ) else call scf_driver ( basis , infos , molGrid ) end if !   Cleanup if ( dft ) call dftclean ( infos ) close ( iw ) end subroutine hf_energy end module hf_energy_mod","tags":"","url":"sourcefile/hf_energy.f90.html"},{"title":"tdhf_sf_gradient.F90 – OpenQP Fortran API","text":"Source Code module tdhf_sf_gradient_mod use precision , only : dp use grd2 , only : grd2_driver , grd2_compute_data_t use basis_tools , only : basis_set , bas_norm_matrix , build_cart_density use constants , only : HARMONIC_ACTIVE , NUM_CART_BF use types , only : information implicit none character ( len =* ), parameter :: module_name = \"tdhf_sf_gradient_mod\" public tdhf_sf_gradient type , extends ( grd2_compute_data_t ) :: grd2_sf_compute_data_t real ( kind = dp ), pointer :: d2 (:,:,:) => null () real ( kind = dp ), pointer :: p2 (:,:,:) => null () real ( kind = dp ), pointer :: v2 (:,:) => null () ! Cartesian-effective (bfnrm-folded) copies + offsets for HARMONIC_ACTIVE. real ( kind = dp ), allocatable :: d2a_c (:,:), d2b_c (:,:), p2a_c (:,:), p2b_c (:,:), v2_c (:,:) integer , allocatable :: cart_off (:) integer :: nbf = 0 contains procedure :: init => grd2_sf_compute_data_t_init procedure :: clean => grd2_sf_compute_data_t_clean procedure :: get_density => grd2_sf_compute_data_t_get_density procedure :: build_cart => grd2_sf_build_cart end type contains subroutine sf_gradient_C ( c_handle ) bind ( C , name = \"tdhf_sf_gradient\" ) use c_interop , only : oqp_handle_t , oqp_handle_get_info use types , only : information type ( oqp_handle_t ) :: c_handle type ( information ), pointer :: inf inf => oqp_handle_get_info ( c_handle ) call tdhf_sf_gradient ( inf ) end subroutine sf_gradient_c subroutine tdhf_sf_gradient ( infos ) use io_constants , only : iw use oqp_tagarray_driver use types , only : information use strings , only : Cstring , fstring use basis_tools , only : basis_set use messages , only : show_message , with_abort use grd1 , only : eijden , print_gradient use util , only : measure_time use tdhf_lib , only : & iatogen , mntoia use tdhf_sf_lib , only : & sfrorhs , & sfromcal , sfrogen , sfrolhs , & pcgb , sfropcal , sfrowcal use dft , only : dft_initialize , dftclean use mathlib , only : symmetrize_matrix use mod_dft_molgrid , only : dft_grid_t use mod_dft_gridint_tdxc_grad , only : utddft_xc_gradient use mathlib , only : unpack_matrix use printing , only : print_module_info implicit none character ( len =* ), parameter :: subroutine_name = \"tdhf_sf_gradient\" type ( basis_set ), pointer :: basis type ( information ), target , intent ( inout ) :: infos integer :: s_size integer :: nbf , nbf_tri logical :: roref = . false . type ( dft_grid_t ) :: molGrid ! General data logical :: dft integer :: scf_type , mol_mult real ( kind = dp ), allocatable :: p (:,:,:), v (:,:,:), d (:,:,:) ! tagarray real ( kind = dp ), contiguous , pointer :: & dmat_a (:), dmat_b (:), td_abxc (:,:), td_p (:,:) character ( len =* ), parameter :: tags_general ( * ) = ( / character ( len = 80 ) :: & OQP_DM_A , OQP_DM_B , OQP_td_abxc , OQP_td_p / ) mol_mult = infos % mol_prop % mult !    if (.not. (mol_mult == 3 .or. mol_mult == 4)) then !      call show_message( & !        'SF-TDDFT only supports mult=3 (triplet) or mult=4 (quartet) references', & !        with_abort) !    end if scf_type = infos % control % scftype if ( scf_type == 3 ) roref = . true . dft = infos % control % hamilton == 20 ! Files open open ( unit = IW , file = infos % log_filename , position = \"append\" ) ! call print_module_info ( 'SF_Grad' , 'Computing Gradient of SF-TDDFT' ) ! write ( iw , '(/5X,\"Gradient options\"/& &5X,18(\"-\")/& &5X,\"Target State: \",I8/& &,5X,\"*Note that the ground state of SF-TDDFT is 1.*\"/)' )& & infos % tddft % target_state ! Load basis set basis => infos % basis basis % atoms => infos % atoms call data_has_tags ( infos % dat , tags_general , module_name , subroutine_name , WITH_ABORT ) call tagarray_get_data ( infos % dat , OQP_DM_A , dmat_a ) call tagarray_get_data ( infos % dat , OQP_DM_B , dmat_b ) call tagarray_get_data ( infos % dat , OQP_td_abxc , td_abxc ) call tagarray_get_data ( infos % dat , OQP_td_p , td_p ) ! Allocate H, S ,T and D matrices nbf = basis % nbf nbf_tri = nbf * ( nbf + 1 ) / 2 s_size = ( basis % nshell ** 2 + basis % nshell ) / 2 !   Compute 1e gradient call flush ( iw ) call sf_1e_grad ( infos , basis ) write ( iw , \"(' ..... End Of 1-Eelectron Gradient ......')\" ) call measure_time ( print_total = 1 , log_unit = iw ) call flush ( iw ) allocate ( d ( nbf , nbf , 2 ), source = 0.0d0 ) allocate ( p ( nbf , nbf , 2 ), source = 0.0d0 ) call unpack_matrix ( td_p (:, 1 ), p (:,:, 1 )) call unpack_matrix ( td_p (:, 2 ), p (:,:, 2 )) call unpack_matrix ( dmat_a , d (:,:, 1 )) call unpack_matrix ( dmat_b , d (:,:, 2 )) !   Compute xc gradient if ( dft ) then call dft_initialize ( infos , basis , molGrid , verbose = . true .) call utddft_xc_gradient ( basis = basis , & molGrid = molGrid , & dedft = infos % atoms % grad , & da = d (:,:, 1 ), & db = d (:,:, 2 ), & pa = p (:,:, 1 : 1 ), & pb = p (:,:, 2 : 2 ), & nmtx = 1 , & !threshold=1.0d-15, & threshold = 0.0d0 , & infos = infos ) call dftclean ( infos ) call measure_time ( print_total = 1 , log_unit = iw ) call flush ( iw ) end if !   Compute 2e gradient allocate ( v ( nbf , nbf , 2 ), source = 0.0d0 ) v (:,:, 1 ) = td_abxc call sf_2e_grad ( basis , infos , d , p , v (:,:, 1 )) call print_gradient ( infos ) !   Print timings call measure_time ( print_total = 1 , log_unit = iw ) close ( iw ) end subroutine tdhf_sf_gradient !############################################################################### subroutine sf_1e_grad ( infos , basis ) use oqp_tagarray_driver use types , only : information use basis_tools , only : basis_set use util , only : measure_time use messages , only : show_message , WITH_ABORT use precision , only : dp use constants , only : tol_int use grd1 , only : eijden , print_gradient , & grad_nn , grad_ee_overlap , & grad_ee_kinetic , grad_en_hellman_feynman , grad_en_pulay , grad_1e_ecp use mathlib , only : symmetrize_matrix implicit none character ( len =* ), parameter :: subroutine_name = \"sf_1e_grad\" type ( information ), intent ( inout ) :: infos type ( basis_set ), intent ( inout ) :: basis real ( kind = dp ), allocatable :: dens (:) real ( kind = dp ) :: tol integer :: nbf , nbf_tri , ok ! tagarray real ( kind = dp ), pointer :: dmat_a (:), dmat_b (:), wao (:), td_p (:,:) character ( len =* ), parameter :: tags_general ( 4 ) = ( / character ( len = 80 ) :: & OQP_DM_A , OQP_DM_B , OQP_WAO , OQP_td_p / ) nbf = basis % nbf nbf_tri = nbf * ( nbf + 1 ) / 2 tol = tol_int * log ( 1 0.0_dp ) !   initial memory allocation allocate ( dens ( nbf_tri ), source = 0.0_dp , stat = ok ) if ( ok /= 0 ) call show_message ( 'Cannot allocate memory' , WITH_ABORT ) call data_has_tags ( infos % dat , tags_general , module_name , subroutine_name , WITH_ABORT ) call tagarray_get_data ( infos % dat , OQP_DM_A , dmat_a ) call tagarray_get_data ( infos % dat , OQP_DM_B , dmat_b ) call tagarray_get_data ( infos % dat , OQP_WAO , wao ) call tagarray_get_data ( infos % dat , OQP_td_p , td_p ) associate ( grad => infos % atoms % grad & , xyz => infos % atoms % xyz & , zn => infos % atoms % zn & , p => td_p & , w => wao & , urohf => infos % control % scftype >= 2 & ) !     Zero out gradient grad = 0.0d0 !     Nuclear repulsion force call grad_nn ( infos % atoms , infos % basis % ecp_zn_num ) !     Obtain Lagrangian matrix (`dens`) call eijden ( dens , nbf , infos ) !     Add W matrix: dens = dens + 2 * w !     Overlap gradient call grad_ee_overlap ( basis , dens , grad , logtol = tol ) !     Compute total density matrix, discard Lagrangian dens = dmat_a + p (:, 1 ) if ( infos % control % scftype >= 2 ) then dens = dens + dmat_b + p (:, 2 ) end if !     Hellmann-Feynman force call grad_en_hellman_feynman ( basis , xyz , zn , dens , grad , logtol = tol ) !     KE gradient call grad_ee_kinetic ( basis , dens , grad , logtol = tol ) !     Pulay force call grad_en_pulay ( basis , xyz , zn , dens , grad , logtol = tol ) !     Effective core potential gradient call grad_1e_ecp ( infos , basis , xyz , dens , grad , logtol = tol ) end associate end subroutine !############################################################################### ! @brief The driver for the two electron gradient subroutine sf_2e_grad ( basis , infos , d , p , v ) use basis_tools , only : basis_set use precision , only : dp use messages , only : show_message , WITH_ABORT use types , only : information implicit none type ( information ), target , intent ( inout ) :: infos type ( basis_set ) :: basis real ( kind = dp ), contiguous , target :: p (:,:,:), d (:,:,:), v (:,:) logical :: urohf , dft real ( kind = dp ) :: scale_exch ! HF scale in Reference real ( kind = dp ) :: scale_exch2 ! HF scale in Response integer :: ok real ( kind = dp ), allocatable :: de (:,:) class ( grd2_compute_data_t ), allocatable :: gcomp dft = infos % control % hamilton == 20 ! dft or hf urohf = infos % control % scftype >= 2 scale_exch = 1.0_dp scale_exch2 = 1.0_dp if ( dft ) then scale_exch = infos % dft % HFscale scale_exch2 = infos % tddft % HFscale end if allocate ( de ( 3 , ubound ( infos % atoms % zn , 1 )), & source = 0.0d0 , & stat = ok ) if ( ok /= 0 ) call show_message ( 'cannot allocate memory' , WITH_ABORT ) write ( * , '(/7x,\"Fitting parameters\")' ) if (. not . infos % dft % cam_flag ) then write ( * , '(10x,\"Exact HF exchange:\")' ) write ( * , '(5x,\"Reference: |\", t20, f6.3, t29, \"|\")' ) scale_exch write ( * , '(5x,\"Response:  |\", t20, f6.3, t29, \"|\")' ) scale_exch2 else write ( * , '(10x,\"CAM parametres:\")' ) write ( * , '(16x,\"|   alpha   |    beta   |     mu    |\")' ) write ( * , '(5x,\"Reference: |\", t20, f6.3, t29, \"|\", t32, f6.3, t41, \"|\", t44, f6.3, t53, \"|\")' ) & infos % dft % cam_alpha , infos % dft % cam_beta , infos % dft % cam_mu write ( * , '(5x,\"Response:  |\", t20, f6.3, t29, \"|\", t32, f6.3, t41, \"|\", t44, f6.3, t53, \"|\")' ) & infos % tddft % cam_alpha , infos % tddft % cam_beta , infos % tddft % cam_mu end if write ( * , '(10x,\"Spin-pair coupling parametres:\")' ) write ( * , '(16x,\"|   CO-CO   |   OV-OV   |   CO-OV   |\")' ) write ( * , '(16x,\"|\", t20, f6.3, t29, \"|\", t32, f6.3, t41, \"|\", t44, f6.3, t53, \"|\")' ) & infos % tddft % HFscale , infos % tddft % HFscale , infos % tddft % HFscale gcomp = grd2_sf_compute_data_t ( d2 = d & , p2 = p & , v2 = v & , nbf = basis % nbf ) call gcomp % init () select type ( gcomp ) class is ( grd2_sf_compute_data_t ) call gcomp % build_cart ( basis ) end select call grd2_driver ( infos , basis , de , gcomp , & cam = dft . and . infos % dft % cam_flag , & alpha = infos % tddft % cam_alpha , & beta = infos % tddft % cam_beta , & mu = infos % tddft % cam_mu ) infos % atoms % grad = infos % atoms % grad + de call gcomp % clean () end subroutine !############################################################################### subroutine grd2_sf_compute_data_t_init ( this ) implicit none class ( grd2_sf_compute_data_t ), target , intent ( inout ) :: this call this % clean () this % d2 (:,:, 1 ) = this % d2 (:,:, 1 ) + this % d2 (:,:, 2 ) this % d2 (:,:, 2 ) = this % d2 (:,:, 1 ) - 2 * this % d2 (:,:, 2 ) this % p2 (:,:, 1 ) = this % p2 (:,:, 1 ) + this % p2 (:,:, 2 ) this % p2 (:,:, 2 ) = this % p2 (:,:, 1 ) - 2 * this % p2 (:,:, 2 ) end subroutine !############################################################################### ! @brief Cartesian-effective copies of the SF gradient densities (alpha/beta !   d and p, transition v) for HARMONIC_ACTIVE. Call AFTER init (which !   combines the spin densities). subroutine grd2_sf_build_cart ( this , basis ) class ( grd2_sf_compute_data_t ), intent ( inout ) :: this type ( basis_set ), intent ( in ) :: basis integer , allocatable :: od (:) integer :: nc if (. not . HARMONIC_ACTIVE ) return call sf_cart_one ( basis , this % d2 (:,:, 1 ), this % d2a_c , this % cart_off , nc ) call sf_cart_one ( basis , this % d2 (:,:, 2 ), this % d2b_c , od , nc ) call sf_cart_one ( basis , this % p2 (:,:, 1 ), this % p2a_c , od , nc ) call sf_cart_one ( basis , this % p2 (:,:, 2 ), this % p2b_c , od , nc ) call sf_cart_one ( basis , this % v2 , this % v2_c , od , nc ) end subroutine grd2_sf_build_cart subroutine sf_cart_one ( basis , m , m_cart , off , nc ) type ( basis_set ), intent ( in ) :: basis real ( kind = dp ), intent ( in ) :: m (:,:) real ( kind = dp ), allocatable , intent ( out ) :: m_cart (:,:) integer , allocatable , intent ( out ) :: off (:) integer , intent ( out ) :: nc real ( kind = dp ), allocatable :: tmp (:,:) tmp = m call bas_norm_matrix ( tmp , basis % bfnrm , basis % nbf ) call build_cart_density ( basis , tmp , m_cart , off , nc ) end subroutine sf_cart_one !############################################################################### subroutine grd2_sf_compute_data_t_clean ( this ) implicit none class ( grd2_sf_compute_data_t ), target , intent ( inout ) :: this end subroutine !############################################################################### ! @brief This routine forms the product of density !        matrices for use in forming the two electron !        gradient. Valid for closed and open shell SCF. subroutine grd2_sf_compute_data_t_get_density ( this , basis , id , dab , dabmax ) implicit none class ( grd2_sf_compute_data_t ), target , intent ( inout ) :: this type ( basis_set ), intent ( in ) :: basis integer , intent ( in ) :: id ( 4 ) real ( kind = dp ), target , intent ( out ) :: dab ( * ) real ( kind = dp ), intent ( out ) :: dabmax real ( kind = dp ) :: df1 , dq1 , dt2 , bfn real ( kind = dp ) :: coulfact , xcfact , xcfact2 integer :: i , j , k , l integer :: loc ( 4 ) integer :: nbf ( 4 ) real ( kind = dp ), pointer :: ab (:,:,:,:) real ( kind = dp ), pointer :: d2a (:,:), d2b (:,:), p2a (:,:), p2b (:,:), v2 (:,:) logical :: usecart integer :: i1 , j1 , k1 , l1 coulfact = 4 * this % coulscale xcfact = this % hfscale xcfact2 = this % hfscale2 dabmax = 0 usecart = HARMONIC_ACTIVE if ( usecart ) then d2a => this % d2a_c ; d2b => this % d2b_c p2a => this % p2a_c ; p2b => this % p2b_c ; v2 => this % v2_c loc = this % cart_off ( id ) - 1 nbf = NUM_CART_BF ( basis % am ( id )) else d2a => this % d2 (:,:, 1 ); d2b => this % d2 (:,:, 2 ) p2a => this % p2 (:,:, 1 ); p2b => this % p2 (:,:, 2 ); v2 => this % v2 loc = basis % ao_offset ( id ) - 1 nbf = basis % naos ( id ) end if ab ( 1 : nbf ( 4 ), 1 : nbf ( 3 ), 1 : nbf ( 2 ), 1 : nbf ( 1 )) => dab ( 1 : product ( nbf )) do i = 1 , nbf ( 1 ) i1 = loc ( 1 ) + i do j = 1 , nbf ( 2 ) j1 = loc ( 2 ) + j do k = 1 , nbf ( 3 ) k1 = loc ( 3 ) + k do l = 1 , nbf ( 4 ) l1 = loc ( 4 ) + l df1 = ( d2a ( i1 , j1 ) + p2a ( i1 , j1 )) * d2a ( k1 , l1 ) & + d2a ( i1 , j1 ) * p2a ( k1 , l1 ) df1 = df1 * coulfact if ( xcfact /= 0.0_dp . or . xcfact2 /= 0.0_dp ) then dq1 = ( d2a ( i1 , k1 ) + p2a ( i1 , k1 )) * d2a ( j1 , l1 ) & + d2a ( i1 , k1 ) * p2a ( j1 , l1 ) & + ( d2a ( i1 , l1 ) + p2a ( i1 , l1 )) * d2a ( j1 , k1 ) & + d2a ( i1 , l1 ) * p2a ( j1 , k1 ) & + ( d2b ( i1 , k1 ) + p2b ( i1 , k1 )) * d2b ( j1 , l1 ) & + d2b ( i1 , k1 ) * p2b ( j1 , l1 ) & + ( d2b ( i1 , l1 ) + p2b ( i1 , l1 )) * d2b ( j1 , k1 ) & + d2b ( i1 , l1 ) * p2b ( j1 , k1 ) dt2 = v2 ( i1 , k1 ) * v2 ( j1 , l1 ) & + v2 ( k1 , i1 ) * v2 ( l1 , j1 ) & + v2 ( i1 , l1 ) * v2 ( j1 , k1 ) & + v2 ( l1 , i1 ) * v2 ( k1 , j1 ) df1 = df1 - xcfact * dq1 - xcfact2 * 2.0_dp * dt2 end if dabmax = max ( dabmax , abs ( df1 )) bfn = 1.0_dp if (. not . usecart ) bfn = product ( basis % bfnrm ([ i1 , j1 , k1 , l1 ])) ab ( l , k , j , i ) = df1 * bfn end do end do end do end do end subroutine grd2_sf_compute_data_t_get_density !############################################################################### end module tdhf_sf_gradient_mod","tags":"","url":"sourcefile/tdhf_sf_gradient.f90.html"},{"title":"int1.F90 – OpenQP Fortran API","text":"Source Code !#define DEBUG 1 !> @author  Vladimir Mironov ! !> @brief This module contains subroutines for 1-electron integrals !>  calculation. ! !  REVISION HISTORY: !> @date _Sep, 2018_ Initial release ! module int1 use , intrinsic :: iso_fortran_env , only : real64 use basis_tools , only : basis_set , & bas_norm_matrix , & bas_denorm_matrix , & build_cart_density use constants , only : HARMONIC_ACTIVE , NUM_CART_BF use cart2sph , only : cart2sph_mat use mod_1e_primitives , only : & update_triang_matrix , & update_rectangular_matrix , & comp_coulomb_int1_prim , & comp_ewaldlr_int1_prim , & comp_kin_ovl_int1_prim , & comp_lz_int1_prim , & comp_amom_int1_prim , & comp_giao_overlap_deriv_prim , & comp_giao_h10_core_prim , & comp_nmr_dia_int1_prim , & comp_pso_int1_prim , & MAX_EL_MOM , & comp_mult_int1_prim , & comp_allmult_int1_prim , & comp_coulpot_prim use mod_shell_tools , only : shell_t , shpair_t use messages , only : show_message , with_abort implicit none !<  size of shell pair block (square of max.num. basis functions in max.ang.m.) integer , parameter :: blocksize = 28 * 28 integer , parameter :: mult_bs ( 0 : MAX_EL_MOM ) = [ 1 , 3 , 6 , 10 ] integer , parameter :: mult_all_bs ( MAX_EL_MOM ) = [ 3 , 9 , 19 ] interface int1_coul module procedure int1_coul_xyzc module procedure int1_coul_x_y_z_c module procedure int1_coul_xyz_c end interface private public omp_hst public omp_qmmm public multipole_integrals public angular_momentum_integrals public giao_overlap_derivative public giao_h10_core public nmr_dia_shielding public giao_a11part_corr public giao_a01gp_contract public pso_integrals public electrostatic_potential public electrostatic_potential_unweighted public external_charge_potential public basis_overlap public overlap contains subroutine prepare_density_matrix ( basis , denab , dens , off , apply_norm ) use mathlib , only : unpack_matrix type ( basis_set ), intent ( in ) :: basis real ( real64 ), contiguous , intent ( in ) :: denab (:) real ( real64 ), allocatable , intent ( out ) :: dens (:,:) integer , allocatable , intent ( out ) :: off (:) logical , intent ( in ) :: apply_norm real ( real64 ), allocatable :: dcart (:,:) integer , allocatable :: cart_off (:) integer :: nbf_cart allocate ( dens ( basis % nbf , basis % nbf ), source = 0.0_real64 ) call unpack_matrix ( denab , dens , basis % nbf , 'U' ) if ( apply_norm ) call bas_norm_matrix ( dens , basis % bfnrm , basis % nbf ) if ( HARMONIC_ACTIVE ) then call build_cart_density ( basis , dens , dcart , cart_off , nbf_cart ) call move_alloc ( dcart , dens ) call move_alloc ( cart_off , off ) else allocate ( off ( basis % nshell )) off = basis % ao_offset ( 1 : basis % nshell ) end if end subroutine prepare_density_matrix subroutine density_ordered_matrix ( shi , shj , dij , dmat , off ) type ( shell_t ), intent ( in ) :: shi , shj real ( real64 ), contiguous , intent ( out ) :: dij (:) real ( real64 ), intent ( in ) :: dmat (:,:) integer , intent ( in ) :: off (:) integer :: ij , i , j , jmax , i0 , j0 , ni , nj real ( real64 ) :: den logical :: iandj iandj = shi % shid == shj % shid ni = merge ( NUM_CART_BF ( shi % ang ), shi % nao , HARMONIC_ACTIVE ) nj = merge ( NUM_CART_BF ( shj % ang ), shj % nao , HARMONIC_ACTIVE ) jmax = nj - 1 ij = 0 do i = 0 , ni - 1 if ( iandj ) jmax = i do j = 0 , jmax ij = ij + 1 i0 = off ( shi % shid ) + i j0 = off ( shj % shid ) + j den = 2.0_real64 * dmat ( i0 , j0 ) if ( iandj . and . i == j ) den = dmat ( i0 , j0 ) dij ( ij ) = den end do end do end subroutine density_ordered_matrix !> @brief Driver for conventional h, S, and T integrals ! !> @details  Compute one electron integrals and core Hamiltonian, !>  - S is evaluated by Gauss-Hermite quadrature, !>  - T is an overlap with -2,0,+2 angular momentum shifts, !>  - V is evaluated by Gauss-Rys quadrature, then \\f$ h = T+V \\f$ !>  Also, do \\f$ L_z \\f$ integrals if requested ! !> @note Based on `HSANDT` subroutine from file `INT1.SRC` ! !> @author Vladimir Mironov ! !   REVISION HISTORY: !> @date _Sep, 2018_ Initial release !> !> @param[in,out]   h       one-electron Hamiltonian matrix in packet format !> @param[in,out]   s       packed matrix of overlap integrals !> @param[in,out]   t       packed matrix of kinetic energy integrals !> @param[in,out]   z       packed matrix of z-angular momentum (Lz) integrals !> @param[in]       dbug    flag for debug output subroutine omp_hst ( basis , coord , zq , h , s , t , z , debug , logtol , comm , usempi ) use io_constants , only : iw use precision , only : dp use basis_tools , only : basis_set use printing , only : print_sym_labeled use ecp_tool , only : add_ecpint use parallel , only : par_env_t use iso_c_binding , only : c_bool use , intrinsic :: iso_fortran_env , only : int32 type ( basis_set ), intent ( in ) :: basis real ( real64 ), contiguous , intent ( in ) :: coord (:,:), zq (:) real ( real64 ), contiguous , intent ( inout ) :: h (:), s (:), t (:) real ( real64 ), contiguous , optional , intent ( inout ) :: z (:) real ( real64 ), optional , intent ( in ) :: logtol logical , optional , intent ( in ) :: debug integer :: ii real ( real64 ) :: tol logical :: lzint , dbug integer :: nbf , nbf_tri type ( par_env_t ) :: pe integer ( kind = int32 ) :: comm logical ( c_bool ), intent ( in ) :: usempi call pe % init ( comm , usempi ) lzint = present ( z ) dbug = . false . if ( present ( debug )) dbug = debug if ( present ( logtol )) then tol = logtol else tol = log ( 1 0.0_dp ) * 20 end if !   Exclude 1e potential in ESDIM, because density is used, !   not point charges nbf = basis % nbf nbf_tri = nbf * ( nbf + 1 ) / 2 !    Zero out all arrays s = 0.0 t = 0.0 h = 0.0 if ( lzint ) z = 0.0 call kin_ovl_ints ( s , t , basis , tol ) call nuc_ints ( basis , coord (:,:), zq , h , tol ) !   Add effective core potential if ( pe % rank == 0 ) then call add_ecpint ( basis , coord (:,:), h ) end if call pe % bcast ( h , nbf_tri ) !    IF (exterior%num_chg/=0) THEN !        SELECT CASE (pbc%method) !        CASE (OQP_PBC_METHOD_EWALD) !            IF (dbug) THEN !                WRITE(*,*) 'Computing Erfc-attenuated Coulomb 1e-integrals' !                WRITE(*,*) 'alpha=', pbc%alpha !            END IF !            CALL int1_coul_ext_chg_ewaldsr(h, basis, & !                    exterior%num_chg, & !                    exterior%chg(:,1), & !                    exterior%chg(:,2), & !                    exterior%chg(:,3), & !                    exterior%chg(:,4), & !                    tol, 1.0d-8, pbc%alpha) !        CASE (OQP_PBC_METHOD_OFF) !            IF (dbug) THEN !                WRITE(*,*) 'Computing regular Coulomb 1e-integrals' !            END IF !            CALL int1_coul_ext_chg(h, basis, & !                    exterior%num_chg, & !                    exterior%chg(:,1), & !                    exterior%chg(:,2), & !                    exterior%chg(:,3), & !                    exterior%chg(:,4), & !                    tol, 1.0d-8) !        CASE DEFAULT !            WRITE (iw,*) 'Unknown PBC method selected' !            CALL abrt !        END SELECT !    END IF if ( lzint ) call lzints ( z , basis , tol ) !   Normalize 1-e integrals all at once call bas_norm_matrix ( h , basis % bfnrm , nbf ) call bas_norm_matrix ( s , basis % bfnrm , nbf ) call bas_norm_matrix ( t , basis % bfnrm , nbf ) if ( lzint ) call bas_norm_matrix ( z , basis % bfnrm , nbf ) !   Form one electron Hamiltonian !   Hcore = Vne + Te h = h + t !   Optional debug printout if ( dbug ) then write ( iw , * ) 'Overlap matrix (S)' call print_sym_labeled ( s , nbf , basis ) write ( iw , * ) 'Bare nucleus Hamiltonian integrals (H=T+V)' call print_sym_labeled ( h , nbf , basis ) write ( iw , * ) 'Kinetic energy integrals (T)' call print_sym_labeled ( t , nbf , basis ) if ( lzint ) then write ( iw , * ) 'Z-angular momentum integrals' call print_sym_labeled ( z , nbf , basis ) end if end if end subroutine !------------------------------------------------------------------------------- !> @brief Driver for conventional ESP QM/MM integrals on a grid around QM atoms ! !> @details  Compute one electron integrals and core Hamiltonian, !>  - V is evaluated by Gauss-Rys quadrature, then \\f$ h = T+V \\f$ !>  Also, do \\f$ L_z \\f$ integrals for atoms and linear cases. !>  Also, do FMO ESP integrals if needed. !>  This subroutine is capable to do integrals in parallel using !>  both OpenMP and MPI. It it helpful when running large FMO jobs. ! !> @note Based on `HSANDT` subroutine from file `INT1.SRC` ! !> @author Miquel Huix-Rotllant ! !   REVISION HISTORY: !> @date _Jul, 2024_ Initial release !> !> @param[in]       i       QM center index !> @param[in]       ttt     ESP integral weight !> @param[in,out]   chg_op  one-electron ESP atomic charge operator in packet format subroutine omp_qmmm ( basis , i , coord , ttt , chg_op , nat , logtol ) use precision , only : dp use basis_tools , only : basis_set type ( basis_set ), intent ( in ) :: basis real ( real64 ), contiguous , intent ( in ) :: coord (:,:), ttt (:,:) real ( real64 ), contiguous , intent ( inout ) :: chg_op (:) real ( real64 ), optional , intent ( in ) :: logtol integer , intent ( in ) :: i , nat real ( real64 ) :: tol integer :: l1 , l2 if ( present ( logtol )) then tol = logtol else tol = log ( 1 0.0_dp ) * 20 end if !   Exclude 1e potential in ESDIM, because density is used, !   not point charges l1 = basis % nbf l2 = l1 * ( l1 + 1 ) / 2 chg_op (:) = 0 call nuc_ints ( basis , coord , ttt ( i ,:), chg_op (:), tol ) call bas_norm_matrix ( chg_op (:), basis % bfnrm , l1 ) end subroutine !------------------------------------------------------------------------------- !> @brief Driver for multipole integrals ! !> @details  Compute one electron multipole integrals !>  Integrals are evaluated by Gauss-Hermite quadrature, ! !> @author Vladimir Mironov ! !   REVISION HISTORY: !> @date _Feb, 2023_ Initial release !> !> @param[in,out]   ints    integrals, packed format !> @param[in]       dbug    flag for debug output subroutine multipole_integrals ( basis , ints , r , mxmom , debug , logtol ) use io_constants , only : iw use precision , only : dp use basis_tools , only : basis_set use printing , only : print_sym_labeled type ( basis_set ), intent ( in ) :: basis real ( real64 ), contiguous , intent ( inout ) :: ints (:,:) real ( real64 ), intent ( in ) :: r (:) integer , intent ( in ) :: mxmom real ( real64 ), optional , intent ( in ) :: logtol logical , optional , intent ( in ) :: debug character ( 2 ) :: mxmom_str real ( real64 ) :: tol logical :: dbug character ( len =* ), parameter :: labels ( 19 ) = [& 'X  ' , 'Y  ' , 'Z  ' , & 'XX ' , 'YY ' , 'ZZ ' , 'XY ' , 'XZ ' , 'YZ ' , & 'XXX' , 'YYY' , 'ZZZ' , & 'XXY' , 'XXZ' , & 'YYX' , 'YYZ' , & 'ZZX' , 'ZZY' , & 'XYZ' & ] integer :: nbf integer :: i if ( mxmom > 3 ) then write ( mxmom_str , '(I2)' ) MAX_EL_MOM call show_message ( 'Maximum order of multipole integrals is' // mxmom_str , with_abort ) end if if ( ubound ( ints , 2 ) < mult_all_bs ( mxmom )) then write ( iw , * ) 'Insufficient space for multipole moment integrals: [' , ubound ( ints ), ']' write ( mxmom_str , '(I2)' ) mult_all_bs ( MAX_EL_MOM ) call show_message ( 'Required:' // mxmom_str , with_abort ) end if dbug = . false . if ( present ( debug )) dbug = debug tol = log ( 1 0.0_dp ) * 20 if ( present ( logtol )) tol = logtol nbf = basis % nbf !   Zero out all arrays ints = 0.0 call mult_all_ints ( ints , mxmom , r , basis , tol ) !   Normalize 1-e integrals all at once do i = 1 , mult_all_bs ( mxmom ) call bas_norm_matrix ( ints (:, i ), basis % bfnrm , nbf ) end do !   Optional debug printout if ( dbug ) then do i = 1 , mult_all_bs ( mxmom ) write ( iw , * ) 'Multipole moment integrals (' // trim ( labels ( i )) // ')' call print_sym_labeled ( ints (:, i ), nbf , basis ) end do end if end subroutine !------------------------------------------------------------------------------- !> @brief Compute the three angular-momentum 1e integral matrices about a !>        gauge origin `o`, in packed (lower-triangular) storage. !> @details The orbital angular momentum operator is anti-Hermitian, so in a !>  real AO basis the matrices A_x, A_y, A_z returned here are antisymmetric !>  (A_qp = -A_pq, zero diagonal). Only the unique lower triangle is stored; !>  the caller is responsible for applying the antisymmetry when expanding to a !>  full square matrix. The physical angular momentum is L = -i * A. ! !> @param[in]       basis   basis set (without sp-shells) !> @param[in,out]   ints    packed integrals, dimension (nbf2, 3) for x,y,z !> @param[in]       o       gauge origin !> @param[in]       debug   optional flag for debug printout !> @param[in]       logtol  optional screening tolerance subroutine angular_momentum_integrals ( basis , ints , o , debug , logtol ) use io_constants , only : iw use precision , only : dp use basis_tools , only : basis_set use printing , only : print_sym_labeled type ( basis_set ), intent ( in ) :: basis real ( real64 ), contiguous , intent ( inout ) :: ints (:,:) real ( real64 ), intent ( in ) :: o (:) real ( real64 ), optional , intent ( in ) :: logtol logical , optional , intent ( in ) :: debug character ( len =* ), parameter :: labels ( 3 ) = [ 'Lx' , 'Ly' , 'Lz' ] real ( real64 ) :: tol logical :: dbug integer :: nbf , i if ( ubound ( ints , 2 ) < 3 ) then call show_message ( 'Insufficient space for angular momentum integrals' , with_abort ) end if dbug = . false . if ( present ( debug )) dbug = debug tol = log ( 1 0.0_dp ) * 20 if ( present ( logtol )) tol = logtol nbf = basis % nbf ints = 0.0 call amom_ints ( ints , o , basis , tol ) !   Normalize 1-e integrals do i = 1 , 3 call bas_norm_matrix ( ints (:, i ), basis % bfnrm , nbf ) end do if ( dbug ) then do i = 1 , 3 write ( iw , * ) 'Angular momentum integrals (' // trim ( labels ( i )) // '), lower triangle' call print_sym_labeled ( ints (:, i ), nbf , basis ) end do end if end subroutine !------------------------------------------------------------------------------- !> @brief Compute the GIAO/London AO overlap magnetic derivative S10. !> @details Returns the real coefficient of the imaginary first magnetic-field !>  derivative of the overlap matrix for the three Cartesian magnetic-field !>  components.  This is a native one-electron GIAO building block and remains !>  disconnected from production NMR shielding until h10, two-electron derivative !>  contractions, and GIAO CPHF/CPKS terms are implemented and benchmarked. subroutine giao_overlap_derivative ( basis , ints , debug , logtol ) use io_constants , only : iw use precision , only : dp use basis_tools , only : basis_set use printing , only : print_sym_labeled type ( basis_set ), intent ( in ) :: basis real ( real64 ), contiguous , intent ( inout ) :: ints (:,:) real ( real64 ), optional , intent ( in ) :: logtol logical , optional , intent ( in ) :: debug character ( len =* ), parameter :: labels ( 3 ) = [ 'Sx' , 'Sy' , 'Sz' ] real ( real64 ) :: tol logical :: dbug integer :: nbf , i if ( ubound ( ints , 2 ) < 3 ) then call show_message ( 'Insufficient space for GIAO overlap derivative integrals' , with_abort ) end if dbug = . false . if ( present ( debug )) dbug = debug tol = log ( 1 0.0_dp ) * 20 if ( present ( logtol )) tol = logtol nbf = basis % nbf ints = 0.0d0 call giao_overlap_deriv_ints ( ints , basis , tol ) do i = 1 , 3 call bas_norm_matrix ( ints (:, i ), basis % bfnrm , nbf ) end do if ( dbug ) then do i = 1 , 3 write ( iw , * ) 'GIAO overlap derivative integrals (' // trim ( labels ( i )) // '), lower triangle' call print_sym_labeled ( ints (:, i ), nbf , basis ) end do end if end subroutine !------------------------------------------------------------------------------- !> @brief Compute the one-electron part of the RHF GIAO h10 magnetic derivative. !> @details Returns packed lower-triangular real coefficients of the imaginary !>  first-order GIAO core-Hamiltonian derivative for x/y/z magnetic-field !>  components.  This routine intentionally contains only h10 one-electron !>  kinetic+nuclear-attraction terms; it does not include the GIAO two-electron !>  Fock derivative, CPHF/CPKS response, shielding assembly, or GIAO ungating. subroutine giao_h10_core ( basis , coord , zq , ints , debug , logtol ) use io_constants , only : iw use precision , only : dp use basis_tools , only : basis_set use printing , only : print_sym_labeled type ( basis_set ), intent ( in ) :: basis real ( real64 ), contiguous , intent ( in ) :: coord (:,:), zq (:) real ( real64 ), contiguous , intent ( inout ) :: ints (:,:) real ( real64 ), optional , intent ( in ) :: logtol logical , optional , intent ( in ) :: debug character ( len =* ), parameter :: labels ( 3 ) = [ 'Hx' , 'Hy' , 'Hz' ] real ( real64 ) :: tol logical :: dbug integer :: nbf , i if ( ubound ( ints , 2 ) < 3 ) then call show_message ( 'Insufficient space for GIAO h10 core derivative integrals' , with_abort ) end if dbug = . false . if ( present ( debug )) dbug = debug tol = log ( 1 0.0_dp ) * 20 if ( present ( logtol )) tol = logtol nbf = basis % nbf ints = 0.0d0 call giao_h10_core_ints ( ints , basis , coord , zq , size ( zq ), tol ) do i = 1 , 3 call bas_norm_matrix ( ints (:, i ), basis % bfnrm , nbf ) end do if ( dbug ) then do i = 1 , 3 write ( iw , * ) 'GIAO h10 core derivative integrals (' // trim ( labels ( i )) // '), lower triangle' call print_sym_labeled ( ints (:, i ), nbf , basis ) end do end if end subroutine !------------------------------------------------------------------------------- !> @brief Density-contracted NMR diamagnetic shielding integrals, all nuclei. !> @details Returns g_ab(N) = sum_{mu,nu} D_{mu,nu} <mu|(r-o)_a (r-c_N)_b/|r-c_N|&#94;3|nu> !>  for every nucleus N. The caller assembles the diamagnetic shielding tensor as !>    sigma&#94;dia_{ts}(N) = (alpha&#94;2/2) [ delta_ts (g_xx+g_yy+g_zz) - g_{s,t} ]. !> @param[in]   basis    basis set !> @param[in]   denab    total density matrix, packed (lower triangle) !> @param[in]   o        gauge origin !> @param[in]   coords   nuclear coordinates (3, nat) !> @param[in]   nat      number of nuclei !> @param[out]  gdia     contracted integrals (3, 3, nat) !> @param[in]   logtol   optional screening tolerance subroutine nmr_dia_shielding ( basis , denab , o , coords , nat , gdia , logtol ) use precision , only : dp type ( basis_set ), intent ( in ) :: basis real ( real64 ), contiguous , intent ( in ) :: denab (:) real ( real64 ), intent ( in ) :: o (:) real ( real64 ), contiguous , intent ( in ) :: coords (:,:) integer , intent ( in ) :: nat real ( real64 ), intent ( out ) :: gdia ( 3 , 3 , nat ) real ( real64 ), optional , intent ( in ) :: logtol real ( real64 ), allocatable :: dens (:,:) real ( real64 ) :: tol integer :: ii , jj , ic integer , allocatable :: off (:) type ( shell_t ) :: shi , shj type ( shpair_t ) :: cntp tol = log ( 1 0.0_dp ) * 20 if ( present ( logtol )) tol = logtol call prepare_density_matrix ( basis , denab , dens , off , apply_norm = . true .) gdia = 0.0d0 call cntp % alloc ( basis ) do ii = 1 , basis % nshell call shi % fetch_by_id ( basis , ii ) do jj = 1 , basis % nshell call shj % fetch_by_id ( basis , jj ) call cntp % shell_pair ( basis , shi , shj , tol ) if ( cntp % numpairs == 0 ) cycle do ic = 1 , nat call comp_nmr_dia_int1_prim ( cntp , coords (:, ic ), o , & dens ( off ( ii ):, off ( jj ):), gdia (:,:, ic )) end do end do end do deallocate ( dens , off ) end subroutine !------------------------------------------------------------------------------- !> @brief Compute PSO (paramagnetic spin-orbit) integral matrices for one nucleus. !> @details Returns the three matrices A_a = [(r-c) x grad]_a/|r-c|&#94;3 as FULL !>  (nbf x nbf) antisymmetric matrices; the physical PSO operator is -i*A. !>  The raw field+ket-derivative product acquires a small spurious symmetric !>  component for nuclei not centered on a basis function. Since the exact PSO !>  operator is anti-Hermitian (its real representation is antisymmetric with a !>  zero diagonal), the full block is assembled and the symmetric part is removed !>  via A = (M - M&#94;T)/2, which is exact and discards only the spurious error. !> @param[in]   basis    basis set !> @param[in]   c        nucleus coordinates !> @param[inout] ints    full integrals, dimension (nbf, nbf, 3), antisymmetric !> @param[in]   logtol   optional screening tolerance !> @brief GIAO a11part London correction, density-contracted. !> @details The GIAO diamagnetic a11part integral satisfies (verified vs libcint) !>   <mu|giao_a11part_{a,b}|nu> = <mu|cg_a11part(O=0)_{a,b}|nu> !>                              + 0.5 * <mu|(r-R_N)_a/|r-R_N|&#94;3|nu> * R_nu,b !>  where R_nu is the KET shell center.  This routine returns the density- !>  contracted correction tensor !>   corr_{a,b}(N) = 0.5 * sum_{mu,nu} <mu|(r-R_N)_a/|r-R_N|&#94;3|nu> * R_nu,b * D_{mu,nu} !>  using the validated Hellmann-Feynman field integral (comp_coulomb_helfeyder1) !>  on the density whose columns are pre-scaled by the ket-shell-center component. !>  The caller adds this (trace-corrected) to the CGO diamagnetic at gauge origin !>  0 (nmr_dia_shielding with o=0) to form the full GIAO a11part contribution. subroutine giao_a11part_corr ( basis , denab , coords , nat , corr , logtol ) use precision , only : dp use mod_1e_primitives , only : comp_coulomb_helfeyder1 type ( basis_set ), intent ( in ) :: basis real ( real64 ), contiguous , intent ( in ) :: denab (:) real ( real64 ), contiguous , intent ( in ) :: coords (:,:) integer , intent ( in ) :: nat real ( real64 ), intent ( out ) :: corr ( 3 , 3 , nat ) real ( real64 ), optional , intent ( in ) :: logtol real ( real64 ), allocatable :: dens (:,:), densb (:,:), aoc (:,:) real ( real64 ) :: tol , der ( 3 ) integer :: ii , jj , ic , b , ish , ao , k , ncomp integer , allocatable :: off (:) type ( shell_t ) :: shi , shj type ( shpair_t ) :: cntp tol = log ( 1 0.0_dp ) * 20 if ( present ( logtol )) tol = logtol call prepare_density_matrix ( basis , denab , dens , off , apply_norm = . true .) allocate ( densb ( size ( dens , 1 ), size ( dens , 2 )), aoc ( size ( dens , 1 ), 3 ), source = 0.0d0 ) ! AO -> shell center map do ish = 1 , basis % nshell ncomp = merge ( NUM_CART_BF ( basis % am ( ish )), basis % naos ( ish ), HARMONIC_ACTIVE ) do k = 1 , ncomp ao = off ( ish ) + k - 1 aoc ( ao , 1 : 3 ) = basis % shell_centers ( ish , 1 : 3 ) end do end do corr = 0.0d0 call cntp % alloc ( basis ) do b = 1 , 3 ! scale ket (column) by its shell-center b-component do ao = 1 , size ( dens , 1 ) densb (:, ao ) = dens (:, ao ) * aoc ( ao , b ) end do do ii = 1 , basis % nshell call shi % fetch_by_id ( basis , ii ) do jj = 1 , basis % nshell call shj % fetch_by_id ( basis , jj ) call cntp % shell_pair ( basis , shi , shj , tol ) if ( cntp % numpairs == 0 ) cycle do ic = 1 , nat der = 0.0d0 call comp_coulomb_helfeyder1 ( cntp , coords (:, ic ), 1.0d0 , & densb ( off ( ii ):, off ( jj ):), der ) corr ( 1 : 3 , b , ic ) = corr ( 1 : 3 , b , ic ) + 0.5d0 * der ( 1 : 3 ) end do end do end do end do deallocate ( dens , densb , aoc , off ) end subroutine !> @brief GIAO a01gp gauge-correction, density-contracted (9 comp -> 3x3). !> @details Returns e2_{a,col}(N) = sum_{mu,nu} <mu|a01gp_{a,col}|nu> D_{mu,nu} !>  for each nucleus N, with a01gp the GIAO derivative of the PSO operator !>  (comp_giao_a01gp_prim).  cvec = R_bra - R_ket per shell pair.  The caller !>  adds this (NOT trace-corrected, per the standard diamagnetic decomposition) to the trace-corrected !>  a11part contribution. subroutine giao_a01gp_contract ( basis , denab , coords , nat , e2 , logtol ) use precision , only : dp use mod_1e_primitives , only : comp_giao_a01gp_prim type ( basis_set ), intent ( in ) :: basis real ( real64 ), contiguous , intent ( in ) :: denab (:) real ( real64 ), contiguous , intent ( in ) :: coords (:,:) integer , intent ( in ) :: nat real ( real64 ), intent ( out ) :: e2 ( 3 , 3 , nat ) real ( real64 ), optional , intent ( in ) :: logtol real ( real64 ), allocatable :: dens (:,:) real ( real64 ) :: tol , cvec ( 3 ), blk ( blocksize , 9 ) integer :: ii , jj , ic , a , col , i , j , ij , oi , oj integer , allocatable :: off (:) type ( shell_t ) :: shi , shj type ( shpair_t ) :: cntp tol = log ( 1 0.0_dp ) * 20 if ( present ( logtol )) tol = logtol call prepare_density_matrix ( basis , denab , dens , off , apply_norm = . true .) e2 = 0.0d0 call cntp % alloc ( basis ) do ii = 1 , basis % nshell call shi % fetch_by_id ( basis , ii ) oi = off ( ii ) do jj = 1 , basis % nshell call shj % fetch_by_id ( basis , jj ) oj = off ( jj ) call cntp % shell_pair ( basis , shi , shj , tol ) if ( cntp % numpairs == 0 ) cycle cvec = basis % shell_centers ( ii , 1 : 3 ) - basis % shell_centers ( jj , 1 : 3 ) do ic = 1 , nat blk = 0.0d0 call comp_giao_a01gp_prim ( cntp , coords (:, ic ), cvec , blk ) ! contract: e2(a,col) += sum_ij den(bra,ket) * blk(ij, (a-1)*3+col) ij = 0 do i = 1 , cntp % inao do j = 1 , cntp % jnao ij = ij + 1 do a = 1 , 3 do col = 1 , 3 e2 ( a , col , ic ) = e2 ( a , col , ic ) & + dens ( oi + i - 1 , oj + j - 1 ) * blk ( ij ,( a - 1 ) * 3 + col ) end do end do end do end do end do end do end do deallocate ( dens , off ) end subroutine subroutine pso_integrals ( basis , c , ints , logtol ) use precision , only : dp type ( basis_set ), intent ( in ) :: basis real ( real64 ), intent ( in ) :: c (:) real ( real64 ), contiguous , intent ( inout ) :: ints (:,:,:) real ( real64 ), optional , intent ( in ) :: logtol real ( real64 ) :: tol integer :: ii , jj , m , nbf , p , q type ( shell_t ) :: shi , shj type ( shpair_t ) :: cntp real ( real64 ), dimension ( blocksize , 3 ) :: blk real ( real64 ) :: aij tol = log ( 1 0.0_dp ) * 20 if ( present ( logtol )) tol = logtol nbf = basis % nbf ints = 0.0d0 call cntp % alloc ( basis ) !   Assemble the full (both-triangle) matrix M_a[bra,ket] for all shell pairs. do ii = 1 , basis % nshell call shi % fetch_by_id ( basis , ii ) do jj = 1 , basis % nshell call shj % fetch_by_id ( basis , jj ) call cntp % shell_pair ( basis , shi , shj , tol ) if ( cntp % numpairs == 0 ) cycle blk = 0.0d0 call comp_pso_int1_prim ( cntp , c , blk ) do m = 1 , 3 if ( HARMONIC_ACTIVE . and . ( shi % harmonic == 1 . or . shj % harmonic == 1 )) & call cart2sph_mat ( blk (:, m ), shj % ang , shj % harmonic , shi % ang , shi % harmonic ) ! blk is ordered (bra=shi outer, ket=shj inner); update_rectangular_matrix ! then writes ints(ket_global, bra_global) = <bra|A|ket>. call update_rectangular_matrix ( shi , shj , blk (:, m ), ints (:,:, m )) end do end do end do !   Normalize, then antisymmetrize A = (M - M&#94;T)/2 (exact for the PSO operator). do m = 1 , 3 call bas_norm_matrix ( ints (:,:, m ), basis % bfnrm , nbf ) end do ! update_rectangular_matrix stored ints(a,b) = <b|A|a>; antisymmetrise into ! the <bra|A|ket> convention used by the paramagnetic assembly. do m = 1 , 3 do p = 1 , nbf do q = 1 , p aij = 0.5d0 * ( ints ( q , p , m ) - ints ( p , q , m )) ints ( p , q , m ) = aij ints ( q , p , m ) = - aij end do end do end do end subroutine !------------------------------------------------------------------------------- !> @brief Compute electronic contribution to electrostatic potential on a grid ! !> @author   Vladimir Mironov ! !     REVISION HISTORY: !> @date _Sep, 2023_ Initial release !> !> @param[in]       basis   basis w/ SP-shells separated !> @param[in]       x       array of X grid pts !> @param[in]       y       array of Y grid pts !> @param[in]       z       array of Z grid pts !> @param[in]       wt      array of grid weights !> @param[in]       d       density matrix !> @param[in]       tol     1-e exponential prefactor tolerance !> @param[out]      pot     electrostatic potential on a grid subroutine electrostatic_potential ( basis , x , y , z , wt , d , pot , logtol ) use precision , only : dp implicit none type ( basis_set ), intent ( inout ) :: basis real ( real64 ), contiguous , intent ( in ) :: x (:), y (:), z (:), wt (:) real ( real64 ), contiguous , intent ( inout ) :: d (:) real ( real64 ), contiguous , intent ( out ) :: pot (:) real ( real64 ), optional , intent ( in ) :: logtol real ( real64 ) :: tol call bas_norm_matrix ( d , basis % bfnrm , basis % nbf ) tol = log ( 1 0.0_dp ) * 20 if ( present ( logtol )) tol = logtol call int1_el_pot ( basis , x , y , z , d , pot , tol ) pot = pot * wt call bas_denorm_matrix ( d , basis % bfnrm , basis % nbf ) end subroutine !------------------------------------------------------------------------------- !> @brief Compute unweighted electronic electrostatic potential on arbitrary points. ! !> @details This is the safe public wrapper around the internal `int1_el_pot` !> kernel. Unlike `electrostatic_potential`, this routine does not multiply by !> quadrature weights. ddX expects `phi_cav` to be the unweighted electric !> potential at cavity points, so this is the intended OpenQP entry point for !> building ddX primal RHS data from an AO density. !> !> @param[inout] basis basis with SP-shells separated !> @param[in]    x     x coordinates of evaluation points, in Bohr !> @param[in]    y     y coordinates of evaluation points, in Bohr !> @param[in]    z     z coordinates of evaluation points, in Bohr !> @param[inout] d     packed AO density matrix; restored to input normalization !> @param[out]   pot   unweighted electronic potential on points !> @param[in]    logtol optional 1-e exponential prefactor tolerance !> subroutine electrostatic_potential_unweighted ( basis , x , y , z , d , pot , logtol ) use precision , only : dp implicit none type ( basis_set ), intent ( in ) :: basis real ( real64 ), contiguous , intent ( in ) :: x (:), y (:), z (:) real ( real64 ), contiguous , intent ( inout ) :: d (:) real ( real64 ), contiguous , intent ( out ) :: pot (:) real ( real64 ), optional , intent ( in ) :: logtol real ( real64 ) :: tol real ( real64 ), allocatable :: invnrm (:) call bas_norm_matrix ( d , basis % bfnrm , basis % nbf ) tol = log ( 1 0.0_dp ) * 20 if ( present ( logtol )) tol = logtol pot = 0.0_real64 call int1_el_pot ( basis , x , y , z , d , pot , tol ) ! Restore the input normalization of d. Use a local inverse of the basis ! norms rather than bas_denorm_matrix, which would transiently mutate ! basis%bfnrm and so force an intent(inout) basis on this otherwise ! read-only routine (it is called from the intent(in) SCF Fock build). invnrm = 1.0_real64 / basis % bfnrm call bas_norm_matrix ( d , invnrm , basis % nbf ) end subroutine electrostatic_potential_unweighted !------------------------------------------------------------------------------- !> @brief Compute packed one-electron Coulomb potential from external point charges. ! !> @details This is the normalized public wrapper around the internal !> `int1_coul_ext_chg` kernel. It is intended for environment/solvent reaction !> fields such as ddX apparent charges: given point charges q_k at coordinates !> r_k, return the packed AO matrix sum_k q_k <mu|1/|r-r_k||nu>. !> !> @param[in]     basis  basis with SP-shells separated !> @param[out]    v      packed normalized AO potential matrix !> @param[in]     x      x coordinates of point charges, in Bohr !> @param[in]     y      y coordinates of point charges, in Bohr !> @param[in]     z      z coordinates of point charges, in Bohr !> @param[in]     chg    point charges !> @param[in]     logtol optional 1-e exponential prefactor tolerance !> @param[in]     chgtol optional charge screening threshold !> subroutine external_charge_potential ( basis , v , x , y , z , chg , logtol , chgtol ) use precision , only : dp implicit none type ( basis_set ), intent ( in ) :: basis real ( real64 ), contiguous , intent ( out ) :: v (:) real ( real64 ), contiguous , intent ( in ) :: x (:), y (:), z (:), chg (:) real ( real64 ), optional , intent ( in ) :: logtol , chgtol real ( real64 ) :: tol , qtol tol = log ( 1 0.0_dp ) * 20 if ( present ( logtol )) tol = logtol qtol = 1.0d-12 if ( present ( chgtol )) qtol = chgtol v = 0.0_real64 call int1_coul_ext_chg ( v , basis , size ( chg ), x , y , z , chg , tol , qtol ) call bas_norm_matrix ( v , basis % bfnrm , basis % nbf ) end subroutine external_charge_potential !------------------------------------------------------------------------------- !> @brief Compute overlap matrix between two basis sets ! !> @details Overlap integrals are computed using Gauss-Hermite quadrature formula ! !> @author   Igor S. Gerasimov ! !     REVISION HISTORY: !> @date _Oct, 2022_ Initial release !> !> @param[in,out]   s       unpacked matrix of overlap integrals !> @param[in]       basis1  basis w/ SP-shells separated !> @param[in]       basis2  basis w/ SP-shells separated !> @param[in]       tol     1-e exponential prefactor tolerance (should be ~tol_int*log(10.0_dp)) SUBROUTINE basis_overlap ( s , basis1 , basis2 , tol ) REAL ( REAL64 ), CONTIGUOUS , INTENT ( INOUT ) :: s (:,:) TYPE ( basis_set ), INTENT ( IN ) :: basis1 , basis2 ! basis without sp-shells REAL ( REAL64 ), INTENT ( IN ) :: tol INTEGER :: ii , jj LOGICAL , PARAMETER :: dokinetic = . false . REAL ( REAL64 ), DIMENSION ( BLOCKSIZE ) :: sblk REAL ( REAL64 ), DIMENSION ( 1 ) :: tblk ! should be zero, but... !dir$ attributes align : 64 :: sblk !dir$ attributes align : 64 :: tblk TYPE ( shell_t ) :: shi , shj TYPE ( shpair_t ) :: cntp s = 0 !$omp parallel & !$omp   private( & !$omp       ii, jj, & !$omp       sblk, tblk, & !$omp       shi, shj, cntp & !$omp   ) CALL cntp % alloc2 ( basis1 , basis2 ) !   I shell DO ii = basis1 % nshell , 1 , - 1 CALL shi % fetch_by_id ( basis1 , ii ) !       J shell !$omp do schedule(dynamic) DO jj = basis2 % nshell , 1 , - 1 CALL shj % fetch_by_id ( basis2 , jj ) CALL cntp % shell_pair2 ( basis1 , basis2 , shi , shj , tol ) IF ( cntp % numpairs == 0 ) CYCLE sblk = 0.0 CALL int1_kin_ovl ( cntp , dokinetic , sblk , tblk ) IF ( HARMONIC_ACTIVE . AND . ( shi % harmonic == 1 . OR . shj % harmonic == 1 )) & CALL cart2sph_mat ( sblk , shj % ang , shj % harmonic , shi % ang , shi % harmonic ) CALL update_rectangular_matrix ( shi , shj , sblk , s ) END DO !$omp end do END DO !$omp end parallel !   End of shell loops END SUBROUTINE !------------------------------------------------------------------------------- !> @brief Compute overlap and integrals ! !> @details Overlap integrals !>  are computed using Gauss-Hermite quadrature formula ! !> @author   Vladimir Mironov ! !     REVISION HISTORY: !> @date _Mar, 2023_ Initial release !> !> @param[in,out]   s       packed matrix of overlap integrals !> @param[in]       basis   basis w/ SP-shells separated !> @param[in]       tol     1-e exponential prefactor tolerance SUBROUTINE overlap ( s , basis , tol ) REAL ( REAL64 ), CONTIGUOUS , INTENT ( INOUT ) :: s (:) TYPE ( basis_set ), INTENT ( IN ) :: basis ! basis without sp-shells REAL ( REAL64 ), INTENT ( IN ) :: tol INTEGER :: & ii , jj logical , parameter :: dokinetic = . false . REAL ( REAL64 ), DIMENSION ( BLOCKSIZE ) :: sblk REAL ( REAL64 ), DIMENSION ( 1 ) :: tblk !dir$ attributes align : 64 :: tblk, sblk TYPE ( shell_t ) :: shi , shj TYPE ( shpair_t ) :: cntp !$omp parallel & !$omp   private( & !$omp       ii, jj, & !$omp       sblk, & !$omp       shi, shj, cntp & !$omp   ) CALL cntp % alloc ( basis ) !   I shell DO ii = basis % nshell , 1 , - 1 CALL shi % fetch_by_id ( basis , ii ) !       J shell !$omp do schedule(dynamic) DO jj = 1 , ii CALL shj % fetch_by_id ( basis , jj ) CALL cntp % shell_pair ( basis , shi , shj , tol ) IF ( cntp % numpairs == 0 ) CYCLE sblk = 0.0 CALL int1_kin_ovl ( cntp , dokinetic , sblk , tblk ) IF ( HARMONIC_ACTIVE . AND . ( shi % harmonic == 1 . OR . shj % harmonic == 1 )) & CALL cart2sph_mat ( sblk , shj % ang , shj % harmonic , shi % ang , shi % harmonic , iandj = ( shi % shid == shj % shid )) CALL update_triang_matrix ( shi , shj , sblk , s ) END DO !$omp end do END DO !$omp end parallel !   End of shell loops END SUBROUTINE !------------------------------------------------------------------------------- !> @brief Compute overlap and kinetic integrals ! !> @details Overlap and electron kinetic energy integrals !>  are computed using Gauss-Hermite quadrature formula !>  Kinetic energy integrals are actually overlap integrals with +2, -2 angular !>  momentum shifts ! !> @author   Vladimir Mironov ! !     REVISION HISTORY: !> @date _Sep, 2018_ Initial release !> !> @param[in,out]   s       packed matrix of overlap integrals !> @param[in,out]   t       packed matrix of kinetic energy integrals !> @param[in]       basis   basis w/ SP-shells separated !> @param[in]       tol     1-e exponential prefactor tolerance SUBROUTINE kin_ovl_ints ( s , t , basis , tol ) REAL ( REAL64 ), CONTIGUOUS , INTENT ( INOUT ) :: s (:), t (:) TYPE ( basis_set ), INTENT ( IN ) :: basis ! basis without sp-shells REAL ( REAL64 ), INTENT ( IN ) :: tol INTEGER :: & ii , jj LOGICAL :: dokinetic REAL ( REAL64 ), DIMENSION ( BLOCKSIZE ) :: tblk , sblk !dir$ attributes align : 64 :: tblk, sblk TYPE ( shell_t ) :: shi , shj TYPE ( shpair_t ) :: cntp !$omp parallel & !$omp   private( & !$omp       ii, jj, & !$omp       sblk, tblk, & !$omp       shi, shj, cntp, dokinetic & !$omp   ) dokinetic = . true . CALL cntp % alloc ( basis ) !   I shell DO ii = basis % nshell , 1 , - 1 CALL shi % fetch_by_id ( basis , ii ) !       J shell !$omp do schedule(dynamic) DO jj = 1 , ii CALL shj % fetch_by_id ( basis , jj ) CALL cntp % shell_pair ( basis , shi , shj , tol ) IF ( cntp % numpairs == 0 ) CYCLE sblk = 0.0 tblk = 0.0 CALL int1_kin_ovl ( cntp , dokinetic , sblk , tblk ) IF ( HARMONIC_ACTIVE . AND . ( shi % harmonic == 1 . OR . shj % harmonic == 1 )) THEN CALL cart2sph_mat ( sblk , shj % ang , shj % harmonic , shi % ang , shi % harmonic , iandj = ( shi % shid == shj % shid )) CALL cart2sph_mat ( tblk , shj % ang , shj % harmonic , shi % ang , shi % harmonic , iandj = ( shi % shid == shj % shid )) END IF CALL update_triang_matrix ( shi , shj , sblk , s ) CALL update_triang_matrix ( shi , shj , tblk , t ) END DO !$omp end do END DO !$omp end parallel !   End of shell loops END SUBROUTINE !------------------------------------------------------------------------------- !> @brief Compute multipole moment integrals !> @author   Vladimir Mironov ! SUBROUTINE mult_all_ints ( ints , mxmom , r , basis , tol ) REAL ( REAL64 ), CONTIGUOUS , INTENT ( INOUT ) :: ints (:,:) TYPE ( basis_set ), INTENT ( IN ) :: basis ! basis without sp-shells real ( real64 ), contiguous , intent ( in ) :: r (:) integer , intent ( in ) :: mxmom REAL ( REAL64 ), INTENT ( IN ) :: tol INTEGER :: ii , jj , m REAL ( REAL64 ), DIMENSION ( BLOCKSIZE , 19 ) :: blk !dir$ attributes align : 64 :: blk TYPE ( shell_t ) :: shi , shj TYPE ( shpair_t ) :: cntp !$omp parallel & !$omp   private( & !$omp       ii, jj, & !$omp       blk, & !$omp       shi, shj, cntp & !$omp   ) CALL cntp % alloc ( basis ) !   I shell !DO ii = basis%nshell, 1, -1 DO ii = 1 , basis % nshell CALL shi % fetch_by_id ( basis , ii ) !       J shell !$omp do schedule(dynamic) DO jj = 1 , ii CALL shj % fetch_by_id ( basis , jj ) CALL cntp % shell_pair ( basis , shi , shj , tol ) IF ( cntp % numpairs == 0 ) CYCLE blk = 0.0 CALL int1_allmul ( cntp , r , mxmom , blk ) do m = 1 , mult_all_bs ( mxmom ) IF ( HARMONIC_ACTIVE . AND . ( shi % harmonic == 1 . OR . shj % harmonic == 1 )) & CALL cart2sph_mat ( blk (:, m ), shj % ang , shj % harmonic , shi % ang , shi % harmonic , iandj = ( shi % shid == shj % shid )) CALL update_triang_matrix ( shi , shj , blk (:, m ), ints (:, m )) end do END DO !$omp end do END DO !$omp end parallel !   End of shell loops END SUBROUTINE !------------------------------------------------------------------------------- !> @brief Compute multipole moment integrals !> @author   Vladimir Mironov ! SUBROUTINE mult_ints ( ints , mom , r , basis , tol ) REAL ( REAL64 ), CONTIGUOUS , INTENT ( INOUT ) :: ints (:,:) TYPE ( basis_set ), INTENT ( IN ) :: basis ! basis without sp-shells real ( real64 ), contiguous , intent ( in ) :: r (:) integer , intent ( in ) :: mom REAL ( REAL64 ), INTENT ( IN ) :: tol INTEGER :: ii , jj , m REAL ( REAL64 ), DIMENSION ( BLOCKSIZE , 10 ) :: blk !dir$ attributes align : 64 :: blk TYPE ( shell_t ) :: shi , shj TYPE ( shpair_t ) :: cntp !$omp parallel & !$omp   private( & !$omp       ii, jj, & !$omp       blk, & !$omp       shi, shj, cntp & !$omp   ) CALL cntp % alloc ( basis ) !   I shell !DO ii = basis%nshell, 1, -1 DO ii = 1 , basis % nshell CALL shi % fetch_by_id ( basis , ii ) !       J shell !$omp do schedule(dynamic) DO jj = 1 , ii CALL shj % fetch_by_id ( basis , jj ) CALL cntp % shell_pair ( basis , shi , shj , tol ) IF ( cntp % numpairs == 0 ) CYCLE blk = 0.0 CALL int1_mul ( cntp , r , mom , blk ) do m = 1 , mult_bs ( mom ) IF ( HARMONIC_ACTIVE . AND . ( shi % harmonic == 1 . OR . shj % harmonic == 1 )) & CALL cart2sph_mat ( blk (:, m ), shj % ang , shj % harmonic , shi % ang , shi % harmonic , iandj = ( shi % shid == shj % shid )) CALL update_triang_matrix ( shi , shj , blk (:, m ), ints (:, m )) end do END DO !$omp end do END DO !$omp end parallel !   End of shell loops END SUBROUTINE !------------------------------------------------------------------------------- !> @brief Compute \\f$ L_z \\f$ integrals ! !> @details \\f$ L_z \\f$ are actually overlap integrals with +1, -1 angular !>  momentum shifts ! !> @author   Vladimir Mironov ! !     REVISION HISTORY: !> @date _Sep, 2018_ Initial release !> !> @param[in,out]   z       packed matrix of Lz integrals !> @param[in]       basis   basis w/ SP-shells separated !> @param[in]       tol     1-e exponential prefactor tolerance SUBROUTINE lzints ( z , basis , tol ) TYPE ( basis_set ), INTENT ( IN ) :: basis ! basis without sp-shells REAL ( REAL64 ), CONTIGUOUS , INTENT ( OUT ) :: z (:) REAL ( REAL64 ), INTENT ( IN ) :: tol INTEGER :: & ii , jj REAL ( REAL64 ), DIMENSION ( BLOCKSIZE ) :: zblk !dir$ attributes align : 64 :: zblk TYPE ( shell_t ) :: shi , shj TYPE ( shpair_t ) :: cntp CALL cntp % alloc ( basis ) !   I shell DO ii = 1 , basis % nshell CALL shi % fetch_by_id ( basis , ii ) !       J shell DO jj = 1 , ii CALL shj % fetch_by_id ( basis , jj ) CALL cntp % shell_pair ( basis , shi , shj , tol ) IF ( cntp % numpairs == 0 ) CYCLE zblk = 0.0 CALL int1_lz ( cntp , zblk ) IF ( HARMONIC_ACTIVE . AND . ( shi % harmonic == 1 . OR . shj % harmonic == 1 )) & CALL cart2sph_mat ( zblk , shj % ang , shj % harmonic , shi % ang , shi % harmonic , & iandj = ( shi % shid == shj % shid ), antisym = . true .) CALL update_triang_matrix ( shi , shj , zblk , z ) END DO END DO !   End of shell loops END SUBROUTINE !------------------------------------------------------------------------------- !> @brief Compute nuclear attraction integrals ! !> @details Nuclear attaction integrals are computed using Gauss-Rys quadrature ! !> @author   Vladimir Mironov ! !     REVISION HISTORY: !> @date _Sep, 2018_ Initial release !> !> @param[in,out]   h       core Hamiltonian matrix !> @param[in]       basis   basis w/ SP-shells separated !> @param[in]       tol     1-e exponential prefactor tolerance subroutine nuc_ints ( basis , coord , zq , h , tol ) type ( basis_set ), intent ( in ) :: basis ! basis without sp-shells real ( real64 ), intent ( in ) :: tol real ( real64 ), contiguous , intent ( in ) :: coord (:,:), zq (:) real ( real64 ), contiguous , intent ( inout ) :: h (:) integer :: nat , ii , jj real ( real64 ), dimension ( blocksize ) :: vblk !dir$ attributes align : 64 :: vblk type ( shell_t ) :: shi , shj type ( shpair_t ) :: cntp nat = ubound ( zq , 1 ) !$omp parallel & !$omp   private( & !$omp       ii, jj, & !$omp       vblk, & !$omp       shi, shj, cntp & !$omp   ) call cntp % alloc ( basis ) !  I shell do ii = basis % nshell , 1 , - 1 call shi % fetch_by_id ( basis , ii ) !       J shell !$omp do schedule(dynamic) do jj = 1 , ii call shj % fetch_by_id ( basis , jj ) call cntp % shell_pair ( basis , shi , shj , tol ) if ( cntp % numpairs == 0 ) cycle vblk = 0.0d0 call int1_coul ( cntp , coord , zq , nat , 0.0d0 , vblk ) if ( HARMONIC_ACTIVE . and . ( shi % harmonic == 1 . or . shj % harmonic == 1 )) & call cart2sph_mat ( vblk , shj % ang , shj % harmonic , shi % ang , shi % harmonic , iandj = ( shi % shid == shj % shid )) call update_triang_matrix ( shi , shj , vblk , h ) end do !$omp end do nowait end do !$omp end parallel !   end of shell loops end subroutine !------------------------------------------------------------------------------- !> @brief General way to compute integrals of charge interaction, charge !>  data are stored in a structure of arrays x(:),y(:),z(:),charge(:) ! !> @details Electron-charge interaction integrals are computed using !>  Gauss-Rys quadrature !> @note This case is a variation of nuclear attraction case. They differ in !>  data representation and in screening logic ! !> @author   Vladimir Mironov ! !     REVISION HISTORY: !> @date _Sep, 2018_ Initial release !> !> @param[in,out]   h       packed matrix of one-electon Coulomb integrals !> @param[in]       basis   basis w/ SP-shells separated !> @param[in]       nat     number of atoms !> @param[in]       x       array of X particle coordinates !> @param[in]       y       array of Y particle coordinates !> @param[in]       z       array of Z particle coordinates !> @param[in]       chg     array of particle charges !> @param[in]       tol     1-e exponential prefactor tolerance !> @param[in]       chgtol  tolerance for particle charge SUBROUTINE int1_coul_ext_chg ( h , basis , nat , x , y , z , chg , tol , chgtol ) REAL ( REAL64 ), CONTIGUOUS , INTENT ( INOUT ) :: h (:) TYPE ( basis_set ), INTENT ( IN ) :: basis ! basis without sp-shells INTEGER , INTENT ( IN ) :: nat REAL ( REAL64 ), CONTIGUOUS , INTENT ( IN ) :: x (:), y (:), z (:), chg (:) REAL ( REAL64 ), INTENT ( IN ) :: tol , chgtol INTEGER :: & ii , jj REAL ( REAL64 ), DIMENSION ( BLOCKSIZE ) :: vblk !dir$ attributes align : 64 :: vblk TYPE ( shell_t ) :: shi , shj TYPE ( shpair_t ) :: cntp !$omp parallel & !$omp   private( & !$omp       ii, jj, & !$omp       vblk, & !$omp       shi, shj, cntp & !$omp   ) CALL cntp % alloc ( basis ) !   I shell DO ii = basis % nshell , 1 , - 1 CALL shi % fetch_by_id ( basis , ii ) !       J shell !$omp do schedule(dynamic) DO jj = 1 , ii CALL shj % fetch_by_id ( basis , jj ) CALL cntp % shell_pair ( basis , shi , shj , tol ) IF ( cntp % numpairs == 0 ) CYCLE vblk = 0.0d0 CALL int1_coul ( cntp , x , y , z , chg , nat , chgtol , vblk ) IF ( HARMONIC_ACTIVE . AND . ( shi % harmonic == 1 . OR . shj % harmonic == 1 )) & CALL cart2sph_mat ( vblk , shj % ang , shj % harmonic , shi % ang , shi % harmonic , iandj = ( shi % shid == shj % shid )) CALL update_triang_matrix ( shi , shj , vblk , h ) END DO !$omp end do END DO !$omp end parallel !   End of shell loops END SUBROUTINE !------------------------------------------------------------------------------- !> @brief Ewald summation scheme, short-range part ! !> @details Compute 1e integrals using modified Coulomb potential: !>  \\f$ \\frac{Erfc(\\omega&#94;{1/2}|r-r_C|)}{|r-r_C|} \\f$ !>  First, regular integrals are computed, then, long-range Ewald !>  term is subtracted. Integrals are computed using Gauss-Rys quadrature. ! !> @author   Vladimir Mironov ! !     REVISION HISTORY: !> @date _Sep, 2018_ Initial release !> !> @param[in,out]   h       packed matrix of one-electon Coulomb integrals !> @param[in]       basis   basis w/ SP-shells separated !> @param[in]       nat     number of atoms !> @param[in]       x       array of X particle coordinates !> @param[in]       y       array of Y particle coordinates !> @param[in]       z       array of Z particle coordinates !> @param[in]       chg     array of particle charges !> @param[in]       tol     1-e exponential prefactor tolerance !> @param[in]       chgtol  tolerance for particle charge !> @param[in]       omega   Ewald splitting parameter SUBROUTINE int1_coul_ext_chg_ewaldsr ( h , basis , nat , x , y , z , chg , tol , chgtol , omega ) REAL ( REAL64 ), CONTIGUOUS , INTENT ( INOUT ) :: h (:) TYPE ( basis_set ), INTENT ( IN ) :: basis ! basis without sp-shells INTEGER , INTENT ( IN ) :: nat REAL ( REAL64 ), CONTIGUOUS , INTENT ( IN ) :: x (:), y (:), z (:), chg (:) REAL ( REAL64 ), INTENT ( IN ) :: tol , chgtol REAL ( REAL64 ), INTENT ( IN ) :: omega INTEGER :: ii , jj REAL ( REAL64 ), DIMENSION ( BLOCKSIZE ) :: vblk !dir$ attributes align : 64 :: vblk TYPE ( shell_t ) :: shi , shj TYPE ( shpair_t ) :: cntp !$omp parallel & !$omp   private( & !$omp       ii, jj, & !$omp       vblk, & !$omp       shi, shj, cntp & !$omp   ) CALL cntp % alloc ( basis ) !   I shell DO ii = basis % nshell , 1 , - 1 CALL shi % fetch_by_id ( basis , ii ) !       J shell !$omp do schedule(dynamic) DO jj = 1 , ii CALL shj % fetch_by_id ( basis , jj ) CALL cntp % shell_pair ( basis , shi , shj , tol ) IF ( cntp % numpairs == 0 ) CYCLE vblk = 0.0d0 CALL int1_coul ( cntp , x , y , z , chg , nat , chgtol , vblk ) !           Subtract long-range Ewald term CALL int1_ewald ( cntp , x , y , z , chg , nat , chgtol , omega , vblk ) IF ( HARMONIC_ACTIVE . AND . ( shi % harmonic == 1 . OR . shj % harmonic == 1 )) & CALL cart2sph_mat ( vblk , shj % ang , shj % harmonic , shi % ang , shi % harmonic , iandj = ( shi % shid == shj % shid )) CALL update_triang_matrix ( shi , shj , vblk , h ) END DO !$omp end do END DO !$omp end parallel !   End of shell loops END SUBROUTINE !------------------------------------------------------------------------------- !> @brief Compute electronic contribution to electrostatic potential on a grid ! !> @details Integrals are computed using Gauss-Rys quadrature ! !> @author   Vladimir Mironov ! !     REVISION HISTORY: !> @date _Sep, 2023_ Initial release !> !> @param[in]       basis   basis w/ SP-shells separated !> @param[in]       x       array of X grid pts !> @param[in]       y       array of Y grid pts !> @param[in]       z       array of Z grid pts !> @param[in]       d       density matrix !> @param[in]       tol     1-e exponential prefactor tolerance !> @param[out]      pot     electrostatic potential on a grid subroutine int1_el_pot ( basis , x , y , z , d , pot , tol ) type ( basis_set ), intent ( in ) :: basis real ( real64 ), contiguous , intent ( in ) :: x (:), y (:), z (:), d (:) real ( real64 ), contiguous , intent ( out ) :: pot (:) real ( real64 ), intent ( in ) :: tol integer :: npts , ii , jj , n real ( real64 ), dimension ( BLOCKSIZE ) :: den !dir$ attributes align : 64 :: den type ( shell_t ) :: shi , shj type ( shpair_t ) :: cntp real ( real64 ), allocatable :: dens (:,:) integer , allocatable :: off (:) npts = ubound ( x , 1 ) call prepare_density_matrix ( basis , d , dens , off , apply_norm = . false .) !$omp parallel & !$omp   private( & !$omp       ii, jj, & !$omp       den, & !$omp       shi, shj, cntp & !$omp   ) & !$omp   reduction(+:pot) call cntp % alloc ( basis ) !   i shell do ii = basis % nshell , 1 , - 1 call shi % fetch_by_id ( basis , ii ) !     j shell !$omp do schedule(dynamic) do jj = 1 , ii call shj % fetch_by_id ( basis , jj ) call cntp % shell_pair ( basis , shi , shj , tol ) if ( cntp % numpairs == 0 ) cycle call density_ordered_matrix ( shi , shj , den , dens , off ) do n = 1 , npts pot ( n ) = pot ( n ) + int1_epoten ( cntp , x ( n ), y ( n ), z ( n ), den ) end do end do !$omp end do nowait end do !$omp end parallel deallocate ( dens , off ) end subroutine !-------------------------------------------------------------------------------- !       ONE-ELECTRON INTEGRALS CALCULATION (CONTRACTED SHELLS) !-------------------------------------------------------------------------------- !> @brief Compute contracted block of kinetic energy and overlap 1e integrals !> @param[in]       cntp        shell pair data !> @param[in]       dokinetic   if `.FALSE.` compute only overlap integrals !> @param[out]      sblk        block of overlap integrals !> @param[out]      tblk        block of kinetic energy integrals ! !> @author   Vladimir Mironov ! !     REVISION HISTORY: !> @date _Sep, 2018_ Initial release ! SUBROUTINE int1_kin_ovl ( cntp , dokinetic , sblk , tblk ) !dir$ attributes inline :: int1_kin_ovl TYPE ( shpair_t ), INTENT ( IN ) :: cntp LOGICAL , INTENT ( IN ) :: dokinetic REAL ( REAL64 ), CONTIGUOUS , INTENT ( INOUT ) :: sblk (:), tblk (:) INTEGER :: ig !dir$ assume_aligned sblk : 64 !dir$ assume_aligned tblk : 64 DO ig = 1 , cntp % numpairs CALL comp_kin_ovl_int1_prim ( cntp , ig , dokinetic , sblk , tblk ) END DO END SUBROUTINE !-------------------------------------------------------------------------------- !> @brief Compute contracted block of Coulomb 1e integrals !> @param[in]       cntp        shell pair data !> @param[in]       xyz         coordinates of particles !> @param[in]       c           charges of particles !> @param[in]       nat         number of particles !> @param[in]       chgtol      cut-off for charge !> @param[inout]    blk         block of 1e Coulomb integrals ! !> @author   Miquel Huix-Rotllant ! !     REVISION HISTORY: !> @date _Jul, 2024_ Initial release ! SUBROUTINE int1_coul_xyz_u ( cntp , xyz , c , blk ) !dir$ attributes inline :: int1_coulxyz_u TYPE ( shpair_t ), INTENT ( IN ) :: cntp REAL ( REAL64 ), CONTIGUOUS , INTENT ( IN ) :: xyz (:) REAL ( REAL64 ), INTENT ( IN ) :: c REAL ( REAL64 ), CONTIGUOUS , INTENT ( INOUT ) :: blk (:) INTEGER :: ig !dir$ assume_aligned blk : 64 !   Interaction with point charge DO ig = 1 , cntp % numpairs CALL comp_coulomb_int1_prim ( cntp , ig , xyz , - c , blk ) END DO END SUBROUTINE !-------------------------------------------------------------------------------- !> @brief Compute contracted block of Coulomb 1e integrals !> @param[in]       cntp        shell pair data !> @param[in]       xyz         coordinates of particles !> @param[in]       c           charges of particles !> @param[in]       nat         number of particles !> @param[in]       chgtol      cut-off for charge !> @param[inout]    blk         block of 1e Coulomb integrals ! !> @author   Vladimir Mironov ! !     REVISION HISTORY: !> @date _Sep, 2018_ Initial release ! SUBROUTINE int1_coul_xyz_c ( cntp , xyz , c , nat , chgtol , blk ) !dir$ attributes inline :: int1_coulxyz_c TYPE ( shpair_t ), INTENT ( IN ) :: cntp REAL ( REAL64 ), CONTIGUOUS , INTENT ( IN ) :: xyz (:,:), c (:) REAL ( REAL64 ), INTENT ( IN ) :: chgtol INTEGER , INTENT ( IN ) :: nat REAL ( REAL64 ), CONTIGUOUS , INTENT ( INOUT ) :: blk (:) INTEGER :: ig , iat !dir$ assume_aligned blk : 64 !   Interaction with point charge DO iat = 1 , nat IF ( abs ( c ( iat )) < chgtol ) CYCLE DO ig = 1 , cntp % numpairs CALL comp_coulomb_int1_prim ( cntp , ig , xyz (:, iat ), - c ( iat ), blk ) END DO END DO END SUBROUTINE !-------------------------------------------------------------------------------- !> @brief Compute contracted block of Coulomb 1e integrals !> @param[in]       cntp        shell pair data !> @param[in]       xyzc        coordinates and charges of particles !> @param[in]       nat         number of particles !> @param[in]       chgtol      cut-off for charge !> @param[inout]    blk         block of 1e Coulomb integrals ! !> @author   Vladimir Mironov ! !     REVISION HISTORY: !> @date _Sep, 2018_ Initial release ! subroutine int1_coul_xyzc ( cntp , xyzc , nat , chgtol , blk ) !dir$ attributes inline :: int1_coul_xyzc type ( shpair_t ), intent ( in ) :: cntp real ( real64 ), contiguous , intent ( in ) :: xyzc (:) real ( real64 ), intent ( in ) :: chgtol integer , intent ( in ) :: nat real ( real64 ), contiguous , intent ( inout ) :: blk (:) integer :: ig , iat real ( real64 ) :: c ( 3 ), znuc !dir$ assume_aligned blk : 64 !   Interaction with point charge do iat = 1 , nat c = xyzc (( iat - 1 ) * 4 + 1 : iat * 4 - 1 ) znuc = xyzc ( iat * 4 ) if ( abs ( znuc ) < chgtol ) cycle do ig = 1 , cntp % numpairs call comp_coulomb_int1_prim ( cntp , ig , c (:), - znuc , blk ) end do end do end subroutine !-------------------------------------------------------------------------------- !> @brief Compute contracted block of Coulomb 1e integrals !> @param[in]       cntp        shell pair data !> @param[in]       x           `X` coordinates of charged particles !> @param[in]       y           `Y` coordinates of charged particles !> @param[in]       z           `Z` coordinates of charged particles !> @param[in]       c           charges of particles !> @param[in]       nat         number of particles !> @param[in]       chgtol      cut-off for charge !> @param[inout]    blk         block of 1e Coulomb integrals ! !> @author   Vladimir Mironov ! !     REVISION HISTORY: !> @date _Sep, 2018_ Initial release ! SUBROUTINE int1_coul_x_y_z_c ( cntp , x , y , z , c , nat , chgtol , blk ) !dir$ attributes inline :: int1_coul_x_y_z_c TYPE ( shpair_t ), INTENT ( IN ) :: cntp REAL ( REAL64 ), CONTIGUOUS , INTENT ( IN ) :: x (:), y (:), z (:), c (:) REAL ( REAL64 ), INTENT ( IN ) :: chgtol INTEGER , INTENT ( IN ) :: nat REAL ( REAL64 ), CONTIGUOUS , INTENT ( INOUT ) :: blk (:) INTEGER :: ig , iat REAL ( REAL64 ) :: crd ( 3 ) !dir$ assume_aligned blk : 64 !   Interaction with point charge DO iat = 1 , nat IF ( abs ( c ( iat )) < chgtol ) CYCLE crd ( 1 ) = x ( iat ) crd ( 2 ) = y ( iat ) crd ( 3 ) = z ( iat ) DO ig = 1 , cntp % numpairs CALL comp_coulomb_int1_prim ( cntp , ig , crd , - c ( iat ), blk ) END DO END DO END SUBROUTINE !-------------------------------------------------------------------------------- !> @brief Substract long-range Ewald contribution from the block of regular !>  Coulomb 1e integrals !> @param[in]       cntp        shell pair data !> @param[in]       x           `X` coordinates of charged particles !> @param[in]       y           `Y` coordinates of charged particles !> @param[in]       z           `Z` coordinates of charged particles !> @param[in]       c           charges of particles !> @param[in]       nat         number of particles !> @param[in]       chgtol      cut-off for charge !> @param[in]       omega       Ewald splitting parameter !> @param[inout]    blk         block of 1e Coulomb integrals ! !> @author   Vladimir Mironov ! !     REVISION HISTORY: !> @date _Sep, 2018_ Initial release ! SUBROUTINE int1_ewald ( cntp , x , y , z , c , nat , chgtol , omega , blk ) !dir$ attributes inline :: int1_ewald TYPE ( shpair_t ), INTENT ( IN ) :: cntp REAL ( REAL64 ), CONTIGUOUS , INTENT ( IN ) :: x (:), y (:), z (:), c (:) REAL ( REAL64 ), INTENT ( IN ) :: chgtol REAL ( REAL64 ), INTENT ( IN ) :: omega INTEGER , INTENT ( IN ) :: nat REAL ( REAL64 ), CONTIGUOUS , INTENT ( INOUT ) :: blk (:) INTEGER :: ig , iat REAL ( REAL64 ) :: crd ( 3 ) !dir$ assume_aligned blk : 64 !   Interaction with point charge DO iat = 1 , nat IF ( abs ( c ( iat )) < chgtol ) CYCLE crd ( 1 ) = x ( iat ) crd ( 2 ) = y ( iat ) crd ( 3 ) = z ( iat ) DO ig = 1 , cntp % numpairs !           By passing the charge as is, we effectively !           subtract the long-range Ewald term CALL comp_ewaldlr_int1_prim ( cntp , ig , crd , c ( iat ), omega , blk ) END DO END DO END SUBROUTINE !-------------------------------------------------------------------------------- !> @brief Compute sum of Coulomb integrals over pair of contracted shells !> @param[in]       cntp        shell pair data !> @param[in]       x           `X` coordinate of the charged particle !> @param[in]       y           `Y` coordinate of the charged particle !> @param[in]       z           `Z` coordinate of the charged particle !> @param[in]       den         normalized density matrix block !> @return          sum of Coulomb integrals over shell pair ! !> @author   Vladimir Mironov ! !     REVISION HISTORY: !> @date _Oct, 2018_ Initial release ! function int1_epoten ( cntp , x , y , z , den ) result ( vsum ) !dir$ attributes inline :: int1_epoten type ( shpair_t ), intent ( in ) :: cntp real ( real64 ), intent ( in ) :: x , y , z , den (:) real ( real64 ) :: vsum integer :: ig real ( real64 ) :: crd ( 3 ) vsum = 0.0 crd ( 1 ) = x crd ( 2 ) = y crd ( 3 ) = z do ig = 1 , cntp % numpairs !       Interaction with unit charge call comp_coulpot_prim ( cntp , ig , crd , den , vsum ) end do end function !-------------------------------------------------------------------------------- !> @brief Compute contracted block of Z-angular momentum integrals !> @param[in]       cntp        shell pair data !> @param[inout]    blk         block of 1e Coulomb Lz-integrals ! !> @author   Vladimir Mironov ! !     REVISION HISTORY: !> @date _Sep, 2018_ Initial release ! SUBROUTINE int1_lz ( cntp , blk ) !dir$ attributes inline :: int1_lz TYPE ( shpair_t ), INTENT ( IN ) :: cntp REAL ( REAL64 ), CONTIGUOUS , INTENT ( INOUT ) :: blk (:) INTEGER :: ig !dir$ assume_aligned blk : 64 DO ig = 1 , cntp % numpairs CALL comp_lz_int1_prim ( cntp , ig , blk ) END DO END SUBROUTINE !-------------------------------------------------------------------------------- !> @brief Compute contracted block of multipole moment 1e integrals !> @param[in]       cntp        shell pair data !> @param[in]       r           point in space to compute integrals !> @param[in]       mom         multiplole moment order (1-dipole, 2-quadrupole, 3-octopole) !> @param[out]      blk         block of overlap integrals ! !> @author   Vladimir Mironov ! !     REVISION HISTORY: !> @date _Sep, 2018_ Initial release ! SUBROUTINE int1_mul ( cntp , r , mom , blk ) !dir$ attributes inline :: int1_kin_ovl type ( shpair_t ), intent ( in ) :: cntp real ( real64 ), contiguous , intent ( in ) :: r (:) integer , intent ( in ) :: mom real ( real64 ), contiguous , intent ( inout ) :: blk (:,:) integer :: ig !dir$ assume_aligned blk : 64 do ig = 1 , cntp % numpairs call comp_mult_int1_prim ( cntp , ig , r , mom , blk ) end do end subroutine !-------------------------------------------------------------------------------- !> @brief Compute angular momentum integrals about gauge origin `o` !> @author   Generated for NMR shielding (CGO) ! SUBROUTINE amom_ints ( ints , o , basis , tol ) REAL ( REAL64 ), CONTIGUOUS , INTENT ( INOUT ) :: ints (:,:) TYPE ( basis_set ), INTENT ( IN ) :: basis real ( real64 ), contiguous , intent ( in ) :: o (:) REAL ( REAL64 ), INTENT ( IN ) :: tol INTEGER :: ii , jj , m REAL ( REAL64 ), DIMENSION ( BLOCKSIZE , 3 ) :: blk !dir$ attributes align : 64 :: blk TYPE ( shell_t ) :: shi , shj TYPE ( shpair_t ) :: cntp !$omp parallel & !$omp   private( & !$omp       ii, jj, m, & !$omp       blk, & !$omp       shi, shj, cntp & !$omp   ) CALL cntp % alloc ( basis ) DO ii = 1 , basis % nshell CALL shi % fetch_by_id ( basis , ii ) !$omp do schedule(dynamic) DO jj = 1 , ii CALL shj % fetch_by_id ( basis , jj ) CALL cntp % shell_pair ( basis , shi , shj , tol ) IF ( cntp % numpairs == 0 ) CYCLE blk = 0.0 CALL int1_amom ( cntp , o , blk ) do m = 1 , 3 IF ( HARMONIC_ACTIVE . AND . ( shi % harmonic == 1 . OR . shj % harmonic == 1 )) & CALL cart2sph_mat ( blk (:, m ), shj % ang , shj % harmonic , shi % ang , shi % harmonic , & iandj = ( shi % shid == shj % shid ), antisym = . true .) CALL update_triang_matrix ( shi , shj , blk (:, m ), ints (:, m )) end do END DO !$omp end do END DO !$omp end parallel END SUBROUTINE !-------------------------------------------------------------------------------- !> @brief Compute contracted block of angular momentum 1e integrals !> @param[in]       cntp        shell pair data !> @param[in]       o           gauge origin !> @param[inout]    blk         block of 1e angular momentum integrals (:,1:3) !> @author   Generated for NMR shielding (CGO) ! SUBROUTINE int1_amom ( cntp , o , blk ) !dir$ attributes inline :: int1_amom type ( shpair_t ), intent ( in ) :: cntp real ( real64 ), contiguous , intent ( in ) :: o (:) real ( real64 ), contiguous , intent ( inout ) :: blk (:,:) integer :: ig !dir$ assume_aligned blk : 64 do ig = 1 , cntp % numpairs call comp_amom_int1_prim ( cntp , ig , o , blk ) end do end subroutine !-------------------------------------------------------------------------------- !> @brief Compute GIAO/London overlap magnetic derivative integrals. SUBROUTINE giao_overlap_deriv_ints ( ints , basis , tol ) REAL ( REAL64 ), CONTIGUOUS , INTENT ( INOUT ) :: ints (:,:) TYPE ( basis_set ), INTENT ( IN ) :: basis REAL ( REAL64 ), INTENT ( IN ) :: tol INTEGER :: ii , jj , m REAL ( REAL64 ), DIMENSION ( BLOCKSIZE , 3 ) :: blk !dir$ attributes align : 64 :: blk TYPE ( shell_t ) :: shi , shj TYPE ( shpair_t ) :: cntp !$omp parallel & !$omp   private( & !$omp       ii, jj, m, & !$omp       blk, & !$omp       shi, shj, cntp & !$omp   ) CALL cntp % alloc ( basis ) DO ii = 1 , basis % nshell CALL shi % fetch_by_id ( basis , ii ) !$omp do schedule(dynamic) DO jj = 1 , ii CALL shj % fetch_by_id ( basis , jj ) CALL cntp % shell_pair ( basis , shi , shj , tol ) IF ( cntp % numpairs == 0 ) CYCLE blk = 0.0d0 CALL int1_giao_overlap_deriv ( cntp , blk ) do m = 1 , 3 IF ( HARMONIC_ACTIVE . AND . ( shi % harmonic == 1 . OR . shj % harmonic == 1 )) & CALL cart2sph_mat ( blk (:, m ), shj % ang , shj % harmonic , shi % ang , shi % harmonic , iandj = ( shi % shid == shj % shid )) CALL update_triang_matrix ( shi , shj , blk (:, m ), ints (:, m )) end do END DO !$omp end do END DO !$omp end parallel END SUBROUTINE !-------------------------------------------------------------------------------- !> @brief Compute contracted block of GIAO/London overlap derivative integrals. SUBROUTINE int1_giao_overlap_deriv ( cntp , blk ) !dir$ attributes inline :: int1_giao_overlap_deriv type ( shpair_t ), intent ( in ) :: cntp real ( real64 ), contiguous , intent ( inout ) :: blk (:,:) integer :: ig !dir$ assume_aligned blk : 64 do ig = 1 , cntp % numpairs call comp_giao_overlap_deriv_prim ( cntp , ig , blk ) end do end subroutine !-------------------------------------------------------------------------------- !> @brief Compute one-electron GIAO h10 core derivative integrals. SUBROUTINE giao_h10_core_ints ( ints , basis , coord , zq , nat , tol ) REAL ( REAL64 ), CONTIGUOUS , INTENT ( INOUT ) :: ints (:,:) TYPE ( basis_set ), INTENT ( IN ) :: basis real ( real64 ), contiguous , intent ( in ) :: coord (:,:), zq (:) integer , intent ( in ) :: nat REAL ( REAL64 ), INTENT ( IN ) :: tol INTEGER :: ii , jj , m REAL ( REAL64 ), DIMENSION ( BLOCKSIZE , 3 ) :: blk !dir$ attributes align : 64 :: blk TYPE ( shell_t ) :: shi , shj TYPE ( shpair_t ) :: cntp !$omp parallel & !$omp   private( & !$omp       ii, jj, m, & !$omp       blk, & !$omp       shi, shj, cntp & !$omp   ) CALL cntp % alloc ( basis ) DO ii = 1 , basis % nshell CALL shi % fetch_by_id ( basis , ii ) !$omp do schedule(dynamic) DO jj = 1 , ii CALL shj % fetch_by_id ( basis , jj ) CALL cntp % shell_pair ( basis , shi , shj , tol ) IF ( cntp % numpairs == 0 ) CYCLE blk = 0.0d0 CALL int1_giao_h10_core ( cntp , coord , zq , nat , blk ) do m = 1 , 3 IF ( HARMONIC_ACTIVE . AND . ( shi % harmonic == 1 . OR . shj % harmonic == 1 )) & CALL cart2sph_mat ( blk (:, m ), shj % ang , shj % harmonic , shi % ang , shi % harmonic , & iandj = ( shi % shid == shj % shid ), antisym = . true .) CALL update_triang_matrix ( shi , shj , blk (:, m ), ints (:, m )) end do END DO !$omp end do END DO !$omp end parallel END SUBROUTINE !-------------------------------------------------------------------------------- !> @brief Compute contracted block of one-electron GIAO h10 derivative integrals. !> @details Matches the one-electron libcint convention !>  h10_onee = -0.5*int1e_giao_irjxp - int1e_ignuc(asym) - int1e_igkin; !>  the two-electron GIAO magnetic Fock derivative is intentionally absent here. SUBROUTINE int1_giao_h10_core ( cntp , coord , zq , nat , blk ) !dir$ attributes inline :: int1_giao_h10_core type ( shpair_t ), intent ( in ) :: cntp real ( real64 ), contiguous , intent ( in ) :: coord (:,:), zq (:) integer , intent ( in ) :: nat real ( real64 ), contiguous , intent ( inout ) :: blk (:,:) integer :: ig real ( real64 ), dimension ( BLOCKSIZE , 3 ) :: amom_blk !dir$ assume_aligned blk : 64 !dir$ assume_aligned amom_blk : 64 amom_blk = 0.0_real64 do ig = 1 , cntp % numpairs call comp_giao_h10_core_prim ( cntp , ig , coord , zq , nat , blk ) call comp_amom_int1_prim ( cntp , ig , cntp % rj , amom_blk ) end do ! libcint/the reference int1e_giao_irjxp is the negative transpose of the ! angular-momentum block returned by comp_amom_int1_prim for the current ! (bra=shi, ket=shj) shell-pair convention.  The packed lower-triangle ! h10 contribution is therefore -0.5*irjxp = +0.5*amom_blk. blk = blk + 0.5_real64 * amom_blk end subroutine !-------------------------------------------------------------------------------- !-------------------------------------------------------------------------------- !-------------------------------------------------------------------------------- !> @brief Compute contracted block of multipole moment 1e integrals !> @param[in]       cntp        shell pair data !> @param[in]       r           point in space to compute integrals !> @param[in]       mom         multiplole moment order (1-dipole, 2-quadrupole, 3-octopole) !> @param[out]      blk         block of overlap integrals ! !> @author   Vladimir Mironov ! !     REVISION HISTORY: !> @date _Sep, 2018_ Initial release ! SUBROUTINE int1_allmul ( cntp , r , mxmom , blk ) !dir$ attributes inline :: int1_kin_ovl type ( shpair_t ), intent ( in ) :: cntp real ( real64 ), contiguous , intent ( in ) :: r (:) integer , intent ( in ) :: mxmom real ( real64 ), contiguous , intent ( inout ) :: blk (:,:) integer :: ig !dir$ assume_aligned blk : 64 do ig = 1 , cntp % numpairs call comp_allmult_int1_prim ( cntp , ig , r , mxmom , blk ) end do end subroutine end module","tags":"","url":"sourcefile/int1.f90.html"},{"title":"dft_gridint_fxc.F90 – OpenQP Fortran API","text":"Source Code module mod_dft_gridint_fxc use precision , only : fp use mod_dft_gridint , only : xc_engine_t , xc_consumer_t use mod_dft_gridint , only : X__ , Y__ , Z__ use mod_dft_gridint , only : OQP_FUNTYP_LDA , OQP_FUNTYP_GGA , OQP_FUNTYP_MGGA use oqp_linalg use blas_wrap , only : oqp_ddot => oqp_ddot_i64 implicit none !------------------------------------------------------------------------------- type , extends ( xc_consumer_t ) :: xc_consumer_tde_t integer :: nMtx = 1 real ( kind = fp ), pointer :: da (:,:,:) => null () real ( kind = fp ), pointer :: db (:,:,:) => null () real ( kind = fp ), allocatable :: focks (:,:,:,:,:) real ( kind = fp ), allocatable :: mo (:,:,:,:,:) real ( kind = fp ), allocatable :: rRho (:,:,:,:) real ( kind = fp ), allocatable :: drRho (:,:,:,:,:) real ( kind = fp ), allocatable :: rTau (:,:,:,:) !   Temporary storage real ( kind = fp ), allocatable :: focks_ (:,:) real ( kind = fp ), allocatable :: tmpMO_ (:,:) real ( kind = fp ), allocatable :: tmpDensity_ (:,:,:) real ( kind = fp ), allocatable :: moG1_ (:,:) real ( kind = fp ), allocatable :: tmp_ (:,:) contains procedure :: parallel_start procedure :: parallel_stop procedure :: update procedure :: postUpdate procedure :: clean procedure :: resetXCPointers procedure :: computeRAll procedure :: resetOrbPointers procedure :: RUpdate procedure :: UUpdate end type !------------------------------------------------------------------------------- private public tddft_fxc public utddft_fxc public xc_consumer_tde_t !------------------------------------------------------------------------------- contains !------------------------------------------------------------------------------- subroutine parallel_start ( self , xce , nThreads ) implicit none class ( xc_consumer_tde_t ), target , intent ( inout ) :: self class ( xc_engine_t ), intent ( in ) :: xce integer , intent ( in ) :: nThreads integer :: nSpin call self % clean () nSpin = 1 if ( xce % hasBeta ) nSpin = 2 allocate ( & self % focks ( xce % numAOs , xce % numAOs , self % nMtx , nSpin , nThreads ) & , self % mo ( xce % numAOs , xce % maxPts , self % nMtx , nSpin , nThreads ) & , self % rRho ( nSpin , xce % maxPts , self % nMtx , nThreads ) & , self % drRho ( 4 , nSpin , xce % maxPts , self % nMtx , nThreads ) & !       Temporary storage , self % focks_ ( xce % numAOs * xce % numAOs * self % nMtx * nSpin , nThreads ) & , self % tmpMO_ ( xce % numAOs * xce % maxPts * self % nMtx * nSpin , nThreads ) & , self % tmpDensity_ ( xce % numAOs * xce % numAOs * self % nMtx , nSpin , nThreads ) & , self % tmp_ ( xce % numAOs * xce % maxPts * xce % numTmpVec , nthreads ) & , source = 0.0d0 ) if ( xce % funTyp == OQP_FUNTYP_MGGA ) then allocate ( & self % rTau ( nSpin , xce % maxPts , self % nMtx , nThreads ) & !       Temporary storage , self % moG1_ ( xce % numAOs * xce % maxPts * 3 * self % nMtx , nThreads ) & , source = 0.0d0 ) end if end subroutine !------------------------------------------------------------------------------- subroutine parallel_stop ( self ) implicit none class ( xc_consumer_tde_t ), intent ( inout ) :: self if ( ubound ( self % focks , 5 ) /= 1 ) then self % focks (:,:,:,:, lbound ( self % focks , 5 )) = sum ( self % focks , dim = 5 ) end if call self % pe % allreduce ( self % focks (:,:,:,:, 1 ), & size ( self % focks (:,:,:,:, 1 ))) end subroutine !------------------------------------------------------------------------------- subroutine clean ( self ) implicit none class ( xc_consumer_tde_t ), intent ( inout ) :: self if ( allocated ( self % focks )) deallocate ( self % focks ) if ( allocated ( self % mo )) deallocate ( self % mo ) if ( allocated ( self % rRho )) deallocate ( self % rRho ) if ( allocated ( self % drRho )) deallocate ( self % drRho ) if ( allocated ( self % rTau )) deallocate ( self % rTau ) !       Temporary storage if ( allocated ( self % focks_ )) deallocate ( self % focks_ ) if ( allocated ( self % tmpMO_ )) deallocate ( self % tmpMO_ ) if ( allocated ( self % tmpDensity_ )) deallocate ( self % tmpDensity_ ) if ( allocated ( self % moG1_ )) deallocate ( self % moG1_ ) if ( allocated ( self % tmp_ )) deallocate ( self % tmp_ ) end subroutine !------------------------------------------------------------------------------- subroutine update ( self , xce , myThread ) class ( xc_consumer_tde_t ), intent ( inout ) :: self class ( xc_engine_t ), intent ( in ) :: xce integer :: myThread call self % computeRAll ( xce , myThread ) if ( xce % hasBeta ) then call self % UUpdate ( xce , myThread ) else call self % RUpdate ( xce , myThread ) end if end subroutine subroutine postUpdate ( self , xce , myThread ) class ( xc_consumer_tde_t ), intent ( inout ) :: self class ( xc_engine_t ), intent ( in ) :: xce integer :: myThread real ( kind = fp ), pointer :: focks (:,:,:,:) integer :: i , j , jj , m , s call self % resetOrbPointers ( xce , focks = focks , myThread = myThread ) associate ( numAOs => xce % numAOs_p & ! number of pruned AOs , indices => xce % indices_p & ) ! Only the upper triangle of focks is valid (dsyr2k 'U' in ! R/UUpdate) and the drivers consume the result via ! triangular_to_full(..., 'u'), so accumulate just that part. ! The indices are ascending, hence the scatter keeps upper ! triangle upper. if ( xce % skip_p ) then do s = 1 , ubound ( focks , 4 ) do m = 1 , ubound ( focks , 3 ) do j = 1 , numAOs self % focks ( 1 : j , j , m , s , myThread ) = & self % focks ( 1 : j , j , m , s , myThread ) + focks ( 1 : j , j , m , s ) end do end do end do else do s = 1 , ubound ( focks , 4 ) do m = 1 , ubound ( focks , 3 ) do j = 1 , numAOs jj = indices ( j ) do i = 1 , j self % focks ( indices ( i ), jj , m , s , myThread ) = & self % focks ( indices ( i ), jj , m , s , myThread ) + focks ( i , j , m , s ) end do end do end do end do end if end associate end subroutine !------------------------------------------------------------------------------- !> @brief Adjust internal memory storage for a given !>  number of pruned grid points !> @author Konstantin Komarov subroutine resetXCPointers ( self , xce , da , db , mo , moG1 , myThread ) class ( xc_consumer_tde_t ), target , intent ( inout ) :: self class ( xc_engine_t ), intent ( in ) :: xce real ( kind = fp ), intent ( out ), pointer :: da (:,:,:) real ( kind = fp ), intent ( out ), pointer :: db (:,:,:) real ( kind = fp ), intent ( out ), pointer :: mo (:,:,:,:) real ( kind = fp ), intent ( out ), pointer :: moG1 (:,:,:,:) integer , intent ( in ) :: myThread integer :: nSpin , j , m if ( xce % skip_p ) then !     no pruned AOs da => self % da if ( xce % hasBeta ) db => self % db mo => self % mo (:,:,:,:, myThread ) else !     pruned AOs nSpin = 1 if ( xce % hasBeta ) nSpin = 2 associate ( indices => xce % indices_p & , numAOs => xce % numAOs_p & ! number of pruned AOs , numPts => xce % numPts & , nMtx => self % nMtx ) ! Set pointer for Dens A da ( 1 : numAOs , 1 : numAOs , 1 : nMtx ) => & self % tmpDensity_ ( 1 : numAOs * numAOs * nMtx , 1 , myThread ) ! Compress Dens A; only the upper triangle is referenced ! downstream (dsymm 'L'/'U' in compRMOs/compRMOGs) and the ! indices are ascending, so compressing it is sufficient do m = 1 , nMtx do j = 1 , numAOs da ( 1 : j , j , m ) = self % da ( indices ( 1 : j ), indices ( j ), m ) end do end do mo ( 1 : numAOs , 1 : numPts , 1 : nMtx , 1 : nSpin ) => & self % tmpMO_ ( 1 : numAOs * numPts * nMtx * nSpin , myThread ) if ( xce % funTyp == OQP_FUNTYP_MGGA ) then ! Set pointer for tmp mGGA moG1 ( 1 : numAOs , 1 : numPts , 1 : 3 , 1 : nMtx ) => & self % moG1_ ( 1 : numAOs * numPts * 3 * nMtx , myThread ) end if if ( xce % hasBeta ) then ! Set pointer for Dens B db ( 1 : numAOs , 1 : numAOs , 1 : nMtx ) => & self % tmpDensity_ ( 1 : numAOs * numAOs * nMtx , 2 , myThread ) ! Compress Dens B, upper triangle only as for Dens A do m = 1 , nMtx do j = 1 , numAOs db ( 1 : j , j , m ) = self % db ( indices ( 1 : j ), indices ( j ), m ) end do end do end if end associate end if ! In any case set pointer for moG1 if ( xce % funTyp == OQP_FUNTYP_MGGA ) then ! Set pointer for tmp mGGA moG1 ( 1 : xce % numAOs_p , 1 : xce % numPts , 1 : 3 , 1 : self % nMtx ) => & self % moG1_ ( 1 : xce % numAOs_p * xce % numPts * 3 * self % nMtx , myThread ) end if end subroutine subroutine resetOrbPointers ( self , xce , focks , tmp , myThread ) class ( xc_consumer_tde_t ), target , intent ( inout ) :: self class ( xc_engine_t ), intent ( in ) :: xce real ( kind = fp ), intent ( out ), pointer :: focks (:,:,:,:) real ( kind = fp ), intent ( out ), pointer , optional :: tmp (:,:,:) integer , intent ( in ) :: myThread integer :: nSpin nSpin = 1 if ( xce % hasBeta ) nSpin = 2 !   pruned AOs or no pruned AOs associate ( numAOs => xce % numAOs_p & ! number of pruned AOs ) focks ( 1 : numAOs , 1 : numAOs , 1 : self % nMtx , 1 : nSpin ) => & self % focks_ ( 1 : numAOs * numAOs * self % nMtx * nSpin , myThread ) if ( present ( tmp )) & tmp ( 1 : numAOs , 1 : xce % numPts , 1 : xce % numTmpVec ) => & self % tmp_ ( 1 : numAOs * xce % numPts * xce % numTmpVec , myThread ) end associate end subroutine !> @brief Compute required MO-like values as well as \\rho, \\sigma, and \\tau subroutine computeRAll ( self , xce , myThread ) class ( xc_consumer_tde_t ), intent ( inout ) :: self class ( xc_engine_t ), intent ( in ) :: xce integer :: myThread real ( kind = fp ), pointer :: da (:,:,:) real ( kind = fp ), pointer :: db (:,:,:) real ( kind = fp ), pointer :: mo (:,:,:,:) real ( kind = fp ), pointer :: moG1 (:,:,:,:) call self % resetXCPointers ( & xce , da , db , mo , moG1 , myThread ) associate ( hasBeta => xce % hasBeta & , numAOs => xce % numAOs_p & ! number of pruned AOs , rrho => self % rrho (:,:,:, mythread ) & , drrho => self % drrho (:,:,:,:, mythread ) & , rtau => self % rtau (:,:,:, mythread ) & , indices => xce % indices_p & ) call xce % compRMOs ( da , mo (:,:,:, 1 )) if ( hasBeta ) then call xce % compRMOs ( db , mo (:,:,:, 2 )) end if call xce % compRRho ( mo , rRho ) if ( xce % funTyp /= OQP_FUNTYP_LDA ) then call xce % compRDRho ( mo , drRho ) end if if ( xce % funTyp == OQP_FUNTYP_MGGA ) then call xce % compRMOGs ( da , moG1 ) call compRTau ( xce , moG1 , rTau , 1 ) if ( xce % hasBeta ) then call xce % compRMOGs ( db , moG1 ) call compRTau ( xce , moG1 , rTau , 2 ) end if end if end associate end subroutine !------------------------------------------------------------------------------- !> @brief Compute Tau: (MO)' times (AO)' !> @param[in]  xce      XC engine, parameters !> @param[in]  moG1     MO directional derivatives !> @param[out] rTau     kinetic energy density !> @author Vladimir Mironov subroutine compRTau ( xce , moG1 , rTau , nSpin ) class ( xc_engine_t ) :: xce real ( kind = fp ), contiguous , intent ( out ) :: rTau (:,:,:) real ( kind = fp ), contiguous , intent ( in ) :: moG1 (:,:,:,:) integer :: i , j , d , m , nSpin , nMtx real ( kind = fp ) :: t nMtx = ubound ( moG1 , 4 ) m = xce % numAOs_p do j = 1 , nMtx do i = 1 , xce % numPts t = 0 do d = 1 , 3 t = t + oqp_ddot ( m , xce % aoG1 (:, i , d ), 1 , moG1 (:, i , d , j ), 1 ) end do rTau ( nSpin , i , j ) = 0.5 * t end do end do end subroutine !------------------------------------------------------------------------------- !> @brief Add XC derivative contribution to the Kohn-Sham-like matrices !> @param[inout] fa   Kohn-Sham matrices !> @author Vladimir Mironov subroutine UUpdate ( dat , xce , myThread ) use mod_dft_gridint , only : xc_der1 , xc_der2_contr class ( xc_engine_t ) :: xce class ( xc_consumer_tde_t ) :: dat integer :: myThread integer :: i , j , k real ( kind = fp ) :: cs ( 3 ) real ( kind = fp ) :: d_r ( 2 ), d_s ( 3 ), d_t ( 2 ) real ( kind = fp ) :: f_r ( 2 ), f_s ( 3 ), f_t ( 2 ) real ( kind = fp ) :: rhoab ( 2 ), tauab ( 2 ), Sigma ( 3 ), dsaa , dsab , dsba , dsbb real ( kind = fp ), pointer :: focks (:,:,:,:) real ( kind = fp ), pointer :: tmp (:,:,:) call dat % resetOrbPointers ( xce , focks , tmp , myThread ) associate ( aoV => xce % aoV & , aoG1 => xce % aoG1 & , rRho => dat % rRho (:,:,:, myThread ) & , drRho => dat % drRho (:,:,:,:, myThread ) & , rTau => dat % rTau (:,:,:, myThread ) & , dRho => xce % xclib % dRho & , numAOs => xce % numAOs_p & ! number of pruned AOs , numPts => xce % numPts & , nMtx => dat % nMtx & , xc => xce % XCLib & , ids => xce % XCLib % ids & ) do j = 1 , nMtx do i = 1 , numPts rhoab = rRho ( 1 : 2 , i , j ) Sigma = 0 tauab = 0 if ( xce % funTyp /= OQP_FUNTYP_LDA ) then dsaa = dot_product ( drRho (:, 1 , i , j ), dRho ( 1 : 3 , i )) dsab = dot_product ( drRho (:, 1 , i , j ), dRho ( 4 : 6 , i )) dsbb = dot_product ( drRho (:, 2 , i , j ), dRho ( 4 : 6 , i )) dsba = dot_product ( drRho (:, 2 , i , j ), dRho ( 1 : 3 , i )) Sigma = [ 2 * dsaa , 2 * dsbb , ( dsab + dsba )] end if if ( xce % funTyp == OQP_FUNTYP_MGGA ) tauab = rTau ( 1 : 2 , i , j ) call xc_der1 ( xce , . true ., i , d_r , d_s , d_t ) call xc_der2_contr ( xce , . true ., i , & rhoab , Sigma , tauab , & f_r , f_s , f_t ) if ( maxval ( abs ([ dsaa , dsbb , dsab , dsba ])) < xce % threshold ) then f_s = 0 end if if ( maxval ( abs ( tauab )) < xce % threshold ) then f_t = 0 end if tmp (:, i , 1 ) = 0.5_fp * f_r ( 1 ) * aoV (:, i ) if ( xce % funTyp /= OQP_FUNTYP_LDA ) then cs = 2 * f_s ( 1 ) * dRho ( 1 : 3 , i ) & + f_s ( 3 ) * dRho ( 4 : 6 , i ) & + 2 * d_s ( 1 ) * drRho (:, 1 , i , j ) & + d_s ( 3 ) * drRho (:, 2 , i , j ) tmp (:, i , 1 ) = tmp (:, i , 1 ) & + cs ( X__ ) * aoG1 (:, i , X__ ) & + cs ( Y__ ) * aoG1 (:, i , Y__ ) & + cs ( Z__ ) * aoG1 (:, i , Z__ ) end if if ( xce % funTyp == OQP_FUNTYP_MGGA ) then tmp (:, i , 2 : 4 ) = f_t ( 1 ) * aoG1 (:, i , X__ : Z__ ) end if end do call dsyr2k ( 'u' , 'n' , numAOs , numPts , 1.0_fp , & aoV , numAOs , & tmp (:,:, 1 ), numAOs , & 0.0_fp , focks (:,:, j , 1 ), numAOs ) if ( xce % funTyp == OQP_FUNTYP_MGGA ) then do k = 1 , 3 call dsyr2k ( 'u' , 'n' , numAOs , numPts , 0.25_fp , & aoG1 (:,:, k ), numAOs , & tmp (:,:, k + 1 ), numAOs , & 1.0_fp , focks (:,:, j , 1 ), numAOs ) end do end if do i = 1 , numPts rhoab = rRho ( 1 : 2 , i , j ) Sigma = 0 tauab = 0 if ( xce % funTyp /= OQP_FUNTYP_LDA ) then dsaa = dot_product ( drRho (:, 1 , i , j ), dRho ( 1 : 3 , i )) dsab = dot_product ( drRho (:, 1 , i , j ), dRho ( 4 : 6 , i )) dsbb = dot_product ( drRho (:, 2 , i , j ), dRho ( 4 : 6 , i )) dsba = dot_product ( drRho (:, 2 , i , j ), dRho ( 1 : 3 , i )) Sigma = [ 2 * dsaa , 2 * dsbb , ( dsab + dsba )] end if if ( xce % funTyp == OQP_FUNTYP_MGGA ) tauab = rTau ( 1 : 2 , i , j ) call xc_der1 ( xce , . true ., i , d_r , d_s , d_t ) call xc_der2_contr ( xce , . true ., i , & rhoab , Sigma , tauab , & f_r , f_s , f_t ) if ( maxval ( abs ([ dsaa , dsbb , dsab , dsba ])) < xce % threshold ) then f_s = 0 end if if ( maxval ( abs ( tauab )) < xce % threshold ) then f_t = 0 end if tmp (:, i , 1 ) = 0.5_fp * f_r ( 2 ) * aoV (:, i ) if ( xce % funTyp /= OQP_FUNTYP_LDA ) then cs = 2 * f_s ( 2 ) * dRho ( 4 : 6 , i ) & + f_s ( 3 ) * dRho ( 1 : 3 , i ) & + 2 * d_s ( 2 ) * drRho (:, 2 , i , j ) & + d_s ( 3 ) * drRho (:, 1 , i , j ) tmp (:, i , 1 ) = tmp (:, i , 1 ) & + cs ( X__ ) * aoG1 (:, i , X__ ) & + cs ( Y__ ) * aoG1 (:, i , Y__ ) & + cs ( Z__ ) * aoG1 (:, i , Z__ ) end if if ( xce % funTyp == OQP_FUNTYP_MGGA ) then tmp (:, i , 2 : 4 ) = f_t ( 2 ) * aoG1 (:, i , X__ : Z__ ) end if end do call dsyr2k ( 'u' , 'n' , numAOs , numPts , 1.0_fp , & aoV , numAOs , & tmp (:,:, 1 ), numAOs , & 0.0_fp , focks (:,:, j , 2 ), numAOs ) if ( xce % funTyp == OQP_FUNTYP_MGGA ) then do k = 1 , 3 call dsyr2k ( 'u' , 'n' , numAOs , numPts , 0.25_fp , & aoG1 (:,:, k ), numAOs , & tmp (:,:, k + 1 ), numAOs , & 1.0_fp , focks (:,:, j , 2 ), numAOs ) end do end if end do end associate end subroutine !------------------------------------------------------------------------------- !> @brief Add XC derivative contribution to the Kohn-Sham-like matrices !> @param[inout] fa   Kohn-Sham matrices !> @author Vladimir Mironov subroutine RUpdate ( dat , xce , myThread ) use mod_dft_gridint , only : xc_der1 , xc_der2_contr class ( xc_engine_t ) :: xce class ( xc_consumer_tde_t ) :: dat integer :: myThread integer :: i , j , k real ( kind = fp ) :: c3 ( 3 ) real ( kind = fp ) :: d_r ( 2 ), d_s ( 3 ), d_t ( 2 ) real ( kind = fp ) :: f_r ( 2 ), f_s ( 3 ), f_t ( 2 ) real ( kind = fp ) :: rhoab ( 2 ), tauab ( 2 ), Sigma ( 3 ) real ( kind = fp ), pointer :: focks (:,:,:,:) real ( kind = fp ), pointer :: tmp (:,:,:) call dat % resetOrbPointers ( xce , focks , tmp , myThread ) associate ( aoV => xce % aoV & , aoG1 => xce % aoG1 & , rRho => dat % rRho (:,:,:, myThread ) & , drRho => dat % drRho (:,:,:,:, myThread ) & , rTau => dat % rTau (:,:,:, myThread ) & , dRho => xce % xclib % dRho & , numAOs => xce % numAOs_p & ! number of pruned AOs , numPts => xce % numPts & , nMtx => dat % nMtx & ) do j = 1 , nMtx do i = 1 , numPts rhoab = rRho ( 1 , i , j ) Sigma = 0 tauab = 0 if ( xce % funTyp /= OQP_FUNTYP_LDA ) Sigma = 2 * sum ( drRho ( 1 : 3 , 1 , i , j ) * dRho ( 1 : 3 , i )) if ( xce % funTyp == OQP_FUNTYP_MGGA ) tauab = rTau ( 1 , i , j ) call xc_der1 ( xce , . false ., i , d_r , d_s , d_t ) call xc_der2_contr ( xce , . false ., i , & rhoab , Sigma , tauab , & f_r , f_s , f_t ) ! LDA tmp (:, i , 1 ) = 0.5_fp * f_r ( 1 ) * aoV (:, i ) if ( xce % funTyp /= OQP_FUNTYP_LDA ) then ! GGA c3 = ( 2 * f_s ( 1 ) + f_s ( 3 )) * dRho ( 1 : 3 , i ) & + ( 2 * d_s ( 1 ) + d_s ( 3 )) * drRho ( 1 : 3 , 1 , i , j ) tmp (:, i , 1 ) = tmp (:, i , 1 ) & + c3 ( X__ ) * aoG1 (:, i , X__ ) & + c3 ( Y__ ) * aoG1 (:, i , Y__ ) & + c3 ( Z__ ) * aoG1 (:, i , Z__ ) end if if ( xce % funTyp == OQP_FUNTYP_MGGA ) then ! mGGA tmp (:, i , 2 ) = f_t ( 1 ) * aoG1 (:, i , X__ ) tmp (:, i , 3 ) = f_t ( 1 ) * aoG1 (:, i , Y__ ) tmp (:, i , 4 ) = f_t ( 1 ) * aoG1 (:, i , Z__ ) end if end do call dsyr2k ( 'U' , 'N' , numAOs , numPts , 1.0_fp , & aoV , numAOs , & tmp (:,:, 1 ), numAOs , & 0.0_fp , focks (:,:, j , 1 ), numAOs ) if ( xce % funTyp == OQP_FUNTYP_MGGA ) then do k = 1 , 3 call dsyr2k ( 'U' , 'N' , numAOs , numPts , 0.25_fp , & aoG1 (:,:, k ), numAOs , & tmp (:,:, k + 1 ), numAOs , & 1.0_fp , focks (:,:, j , 1 ), numAOs ) end do end if end do end associate end subroutine !------------------------------------------------------------------------------- !> @brief Compute derivative XC contribution to the TD-DFT KS-like matrices !> @param[in]    basis     basis set !> @param[in]    isVecs    .true. if orbitals are provided instead of density matrix !> @param[in]    wf        density matrix/orbitals !> @param[inout] fx        fock-like matrices !> @param[inout] dx        densities !> @param[in]    nMtx      number of density/Fock-like matrices !> @param[in]    threshold tolerance !> @param[in]    isGGA     .TRUE. if GGA/mGGA functional used !> @param[in]    infos     OQP metadata !> @author Vladimir Mironov subroutine utddft_fxc ( basis , molGrid , isVecs , & wfa , wfb , & fxa , fxb , & dxa , dxb , & nMtx , threshold , infos ) !$  use omp_lib, only: omp_get_num_threads, omp_get_thread_num use basis_tools , only : basis_set use mod_dft_gridint , only : xc_options_t , run_xc use types , only : information use mod_dft_molgrid , only : dft_grid_t use mathlib , only : triangular_to_full implicit none type ( information ), target , intent ( in ) :: infos type ( dft_grid_t ), target , intent ( in ) :: molGrid type ( basis_set ) :: basis logical , intent ( in ) :: isVecs integer , intent ( in ) :: nMtx real ( kind = fp ), intent ( in ) :: wfa (:,:), wfb (:,:) real ( kind = fp ), intent ( inout ), target :: dxa (:,:,:), dxb (:,:,:) real ( kind = fp ), intent ( inout ) :: fxa (:,:,:), fxb (:,:,:) real ( kind = fp ), intent ( in ) :: threshold type ( xc_consumer_tde_t ) :: dat type ( xc_options_t ) :: xc_opts integer :: i , j , nbf real ( kind = fp ), allocatable , target :: d2a (:,:), d2b (:,:) nbf = ubound ( wfa , 1 ) ! Scale w.f. by B.F. norms allocate ( d2a ( nbf , nbf ), d2b ( nbf , nbf )) if ( isVecs ) then do i = 1 , nbf d2a (:, i ) = wfa (:, i ) * basis % bfnrm (:) d2b (:, i ) = wfb (:, i ) * basis % bfnrm (:) end do else do i = 1 , nbf d2a (:, i ) = wfa (:, i ) & * basis % bfnrm ( i ) & * basis % bfnrm (:) d2b (:, i ) = wfb (:, i ) & * basis % bfnrm ( i ) & * basis % bfnrm (:) end do end if ! Scale densities by B.F. norms do j = 1 , nMtx do i = 1 , nbf dxa (:, i , j ) = dxa (:, i , j ) & * basis % bfnrm ( i ) & * basis % bfnrm (:) dxb (:, i , j ) = dxb (:, i , j ) & * basis % bfnrm ( i ) & * basis % bfnrm (:) end do end do xc_opts % isGGA = infos % functional % needGrd xc_opts % needTau = infos % functional % needTau xc_opts % functional => infos % functional xc_opts % hasBeta = . true . xc_opts % isWFVecs = isVecs xc_opts % numAOs = nbf xc_opts % maxPts = molGrid % maxSlicePts xc_opts % limPts = molGrid % maxNRadTimesNAng xc_opts % numAtoms = infos % mol_prop % natom xc_opts % maxAngMom = basis % mxam xc_opts % nDer = 0 xc_opts % nXCDer = 2 xc_opts % numOccAlpha = infos % mol_prop % nelec_A xc_opts % numOccBeta = infos % mol_prop % nelec_B xc_opts % wfAlpha => d2a xc_opts % wfBeta => d2b xc_opts % dft_threshold = threshold xc_opts % molGrid => molGrid dat % da => dxa dat % db => dxb dat % nMtx = nMtx call run_xc ( xc_opts , dat , basis ) deallocate ( d2a , d2b ) do j = 1 , nMtx call triangular_to_full ( dat % focks (:,:, j , 1 , 1 ), nbf , 'u' ) do i = 1 , nbf fxa (:, i , j ) = fxa (:, i , j ) & + dat % focks (:, i , j , 1 , 1 ) & * basis % bfnrm ( i ) & * basis % bfnrm (:) end do end do do j = 1 , nMtx call triangular_to_full ( dat % focks (:,:, j , 2 , 1 ), nbf , 'u' ) do i = 1 , nbf fxb (:, i , j ) = fxb (:, i , j ) & + dat % focks (:, i , j , 2 , 1 ) & * basis % bfnrm ( i ) & * basis % bfnrm (:) end do end do ! Scale densities back do j = 1 , nMtx do i = 1 , nbf dxa (:, i , j ) = dxa (:, i , j ) & / basis % bfnrm ( i ) & / basis % bfnrm (:) dxb (:, i , j ) = dxb (:, i , j ) & / basis % bfnrm ( i ) & / basis % bfnrm (:) end do end do call dat % clean () end subroutine !------------------------------------------------------------------------------- !> @brief Compute derivative XC contribution to the TD-DFT KS-like matrices !> @param[in]    basis     basis set !> @param[in]    isVecs    .true. if orbitals are provided instead of density matrix !> @param[in]    wf        density matrix/orbitals !> @param[inout] fx        fock-like matrices !> @param[inout] dx        densities !> @param[in]    nMtx      number of density/Fock-like matrices !> @param[in]    threshold tolerance !> @param[in]    infos     OQP metadata !> @author Vladimir Mironov subroutine tddft_fxc ( basis , molGrid , isVecs , wf , fx , dx , & nMtx , threshold , infos ) !$  use omp_lib, only: omp_get_num_threads, omp_get_thread_num use basis_tools , only : basis_set use mod_dft_gridint , only : xc_options_t , run_xc use types , only : information use mod_dft_molgrid , only : dft_grid_t use mathlib , only : triangular_to_full implicit none type ( information ), target , intent ( in ) :: infos type ( dft_grid_t ), target , intent ( in ) :: molGrid type ( basis_set ) :: basis logical , intent ( in ) :: isVecs integer , intent ( in ) :: nMtx real ( kind = fp ), intent ( in ) :: wf (:,:) real ( kind = fp ), intent ( inout ), target :: dx (:,:,:) real ( kind = fp ), intent ( inout ) :: fx (:,:,:) real ( kind = fp ), intent ( in ) :: threshold type ( xc_consumer_tde_t ) :: dat type ( xc_options_t ) :: xc_opts integer :: i , j , nbf real ( kind = fp ), allocatable , target :: d2 (:,:) nbf = ubound ( wf , 1 ) ! Scale w.f. by B.F. norms allocate ( d2 ( nbf , nbf )) if ( isVecs ) then do i = 1 , nbf d2 (:, i ) = wf (:, i ) * basis % bfnrm (:) end do else do i = 1 , nbf d2 (:, i ) = wf (:, i ) & * basis % bfnrm ( i ) & * basis % bfnrm (:) end do end if ! Scale densities by B.F. norms do j = 1 , nMtx do i = 1 , nbf dx (:, i , j ) = dx (:, i , j ) & * basis % bfnrm ( i ) & * basis % bfnrm (:) end do end do xc_opts % isGGA = infos % functional % needGrd xc_opts % needTau = infos % functional % needTau xc_opts % functional => infos % functional xc_opts % hasBeta = . false . xc_opts % isWFVecs = isVecs xc_opts % numAOs = nbf xc_opts % maxPts = molGrid % maxSlicePts xc_opts % limPts = molGrid % maxNRadTimesNAng xc_opts % numAtoms = infos % mol_prop % natom xc_opts % maxAngMom = basis % mxam xc_opts % nDer = 0 xc_opts % nXCDer = 2 xc_opts % numOccAlpha = infos % mol_prop % nelec_A xc_opts % numOccBeta = infos % mol_prop % nelec_B xc_opts % wfAlpha => d2 xc_opts % dft_threshold = threshold xc_opts % molGrid => molGrid dat % da => dx dat % nMtx = nMtx call dat % pe % init ( infos % mpiinfo % comm , infos % mpiinfo % usempi ) call run_xc ( xc_opts , dat , basis ) deallocate ( d2 ) do j = 1 , nMtx call triangular_to_full ( dat % focks (:,:, j , 1 , 1 ), nbf , 'u' ) do i = 1 , nbf fx (:, i , j ) = fx (:, i , j ) & + dat % focks (:, i , j , 1 , 1 ) & * basis % bfnrm ( i ) & * basis % bfnrm (:) end do end do ! Scale densities back do j = 1 , nMtx do i = 1 , nbf dx (:, i , j ) = dx (:, i , j ) & / basis % bfnrm ( i ) & / basis % bfnrm (:) end do end do call dat % clean () end subroutine !------------------------------------------------------------------------------- end module mod_dft_gridint_fxc","tags":"","url":"sourcefile/dft_gridint_fxc.f90.html"},{"title":"lebedev.F90 – OpenQP Fortran API","text":"Source Code module lebedev use precision , only : dp implicit none private public :: lebedev_get_grid public :: spherical_grid_type_lebedev public :: spherical_grid_type_o public :: spherical_grid_type_oh public :: spherical_grid_type_i public :: lebedev_npts public :: oct_npts public :: oh_npts public :: i_npts public :: lebedev_orders public :: oct_orders public :: oh_orders public :: i_orders integer , parameter :: spherical_grid_type_lebedev = 0 integer , parameter :: spherical_grid_type_o = 1 integer , parameter :: spherical_grid_type_oh = 2 integer , parameter :: spherical_grid_type_i = 3 integer , parameter :: & lebedev_npts ( * ) = [ & 6 , 14 , 26 , 38 , 50 , 74 , 86 , 110 , 146 , 170 , 194 , 230 , 266 , 302 , 350 , 434 , & 590 , 770 , 974 , 1202 , 1454 , 1730 , 2030 , 2354 , 2702 , 3074 , 3470 , 3890 , 4334 , & 4802 , 5294 , 5810 ] integer , parameter :: oct_npts ( * ) = [ 246 , 264 , 342 , 432 ] integer , parameter :: oh_npts ( * ) = [ 350 , 398 ] integer , parameter :: i_npts ( * ) = [ 132 , 152 , 180 , 192 , 212 , 242 ] integer , parameter :: & lebedev_orders ( * ) = [ & 3 , 5 , 7 , 9 , 11 , 13 , 15 , 17 , 19 , 21 , 23 , 25 , 27 , 29 , 31 , 35 , 41 , 47 , 53 , 59 , & 65 , 71 , 77 , 83 , 89 , 95 , 101 , 107 , 113 , 119 , 125 , 131 ] integer , parameter :: oct_orders ( * ) = [ 26 , 27 , 31 , 35 ] integer , parameter :: oh_orders ( * ) = [ 31 , 33 ] integer , parameter :: i_orders ( * ) = [ 19 , 20 , 21 , 23 , 24 , 25 ] contains subroutine lebedev_get_grid ( npts , xyz , w , grid_type ) use messages , only : show_message , WITH_ABORT integer , intent ( in ) :: npts integer , optional , intent ( in ) :: grid_type real ( kind = dp ), intent ( inout ) :: xyz ( npts , * ), w ( * ) character (:), allocatable :: errmsg integer :: n integer :: grdtype grdtype = 0 if ( present ( grid_type )) grdtype = grid_type select case ( grdtype ) !   Lebedev-Laikov grids case ( spherical_grid_type_lebedev ) select case ( npts ) case ( 6 ); call ld0006 ( xyz (:, 1 ), xyz (:, 2 ), xyz (:, 3 ), w , n ) case ( 14 ); call ld0014 ( xyz (:, 1 ), xyz (:, 2 ), xyz (:, 3 ), w , n ) case ( 26 ); call ld0026 ( xyz (:, 1 ), xyz (:, 2 ), xyz (:, 3 ), w , n ) case ( 38 ); call ld0038 ( xyz (:, 1 ), xyz (:, 2 ), xyz (:, 3 ), w , n ) case ( 50 ); call ld0050 ( xyz (:, 1 ), xyz (:, 2 ), xyz (:, 3 ), w , n ) case ( 74 ); call ld0074 ( xyz (:, 1 ), xyz (:, 2 ), xyz (:, 3 ), w , n ) case ( 86 ); call ld0086 ( xyz (:, 1 ), xyz (:, 2 ), xyz (:, 3 ), w , n ) case ( 110 ); call ld0110 ( xyz (:, 1 ), xyz (:, 2 ), xyz (:, 3 ), w , n ) case ( 146 ); call ld0146 ( xyz (:, 1 ), xyz (:, 2 ), xyz (:, 3 ), w , n ) case ( 170 ); call ld0170 ( xyz (:, 1 ), xyz (:, 2 ), xyz (:, 3 ), w , n ) case ( 194 ); call ld0194 ( xyz (:, 1 ), xyz (:, 2 ), xyz (:, 3 ), w , n ) case ( 230 ); call ld0230 ( xyz (:, 1 ), xyz (:, 2 ), xyz (:, 3 ), w , n ) case ( 266 ); call ld0266 ( xyz (:, 1 ), xyz (:, 2 ), xyz (:, 3 ), w , n ) case ( 302 ); call ld0302 ( xyz (:, 1 ), xyz (:, 2 ), xyz (:, 3 ), w , n ) case ( 350 ); call ld0350 ( xyz (:, 1 ), xyz (:, 2 ), xyz (:, 3 ), w , n ) case ( 434 ); call ld0434 ( xyz (:, 1 ), xyz (:, 2 ), xyz (:, 3 ), w , n ) case ( 590 ); call ld0590 ( xyz (:, 1 ), xyz (:, 2 ), xyz (:, 3 ), w , n ) case ( 770 ); call ld0770 ( xyz (:, 1 ), xyz (:, 2 ), xyz (:, 3 ), w , n ) case ( 974 ); call ld0974 ( xyz (:, 1 ), xyz (:, 2 ), xyz (:, 3 ), w , n ) case ( 1202 ); call ld1202 ( xyz (:, 1 ), xyz (:, 2 ), xyz (:, 3 ), w , n ) case ( 1454 ); call ld1454 ( xyz (:, 1 ), xyz (:, 2 ), xyz (:, 3 ), w , n ) case ( 1730 ); call ld1730 ( xyz (:, 1 ), xyz (:, 2 ), xyz (:, 3 ), w , n ) case ( 2030 ); call ld2030 ( xyz (:, 1 ), xyz (:, 2 ), xyz (:, 3 ), w , n ) case ( 2354 ); call ld2354 ( xyz (:, 1 ), xyz (:, 2 ), xyz (:, 3 ), w , n ) case ( 2702 ); call ld2702 ( xyz (:, 1 ), xyz (:, 2 ), xyz (:, 3 ), w , n ) case ( 3074 ); call ld3074 ( xyz (:, 1 ), xyz (:, 2 ), xyz (:, 3 ), w , n ) case ( 3470 ); call ld3470 ( xyz (:, 1 ), xyz (:, 2 ), xyz (:, 3 ), w , n ) case ( 3890 ); call ld3890 ( xyz (:, 1 ), xyz (:, 2 ), xyz (:, 3 ), w , n ) case ( 4334 ); call ld4334 ( xyz (:, 1 ), xyz (:, 2 ), xyz (:, 3 ), w , n ) case ( 4802 ); call ld4802 ( xyz (:, 1 ), xyz (:, 2 ), xyz (:, 3 ), w , n ) case ( 5294 ); call ld5294 ( xyz (:, 1 ), xyz (:, 2 ), xyz (:, 3 ), w , n ) case ( 5810 ); call ld5810 ( xyz (:, 1 ), xyz (:, 2 ), xyz (:, 3 ), w , n ) case default write ( errmsg , \"(' Lebedev grid with ',i4,' points not available.')\" ) npts call show_message ( errmsg , WITH_ABORT ) end select !   Class of grids developed by A.S.Popov. !   Rotational octahedral symmetry grids (without inversion): case ( spherical_grid_type_o ) select case ( npts ) case ( 246 ); call od0246 ( xyz (:, 1 ), xyz (:, 2 ), xyz (:, 3 ), w , n ) case ( 264 ); call od0264 ( xyz (:, 1 ), xyz (:, 2 ), xyz (:, 3 ), w , n ) case ( 342 ); call od0342 ( xyz (:, 1 ), xyz (:, 2 ), xyz (:, 3 ), w , n ) case ( 432 ); call od0432 ( xyz (:, 1 ), xyz (:, 2 ), xyz (:, 3 ), w , n ) case default write ( errmsg , \"(' O-symmetry grid with ',i4,' points not available.')\" ) npts call show_message ( errmsg , WITH_ABORT ) end select !   Full octahedral symmetry grids (same symmetry as Lebedev grids): case ( spherical_grid_type_oh ) select case ( npts ) case ( 350 ); call ohd0350 ( xyz (:, 1 ), xyz (:, 2 ), xyz (:, 3 ), w , n ) case ( 398 ); call ohd0398 ( xyz (:, 1 ), xyz (:, 2 ), xyz (:, 3 ), w , n ) case default write ( errmsg , \"(' Oh-symmetry grid with ',i4,' points not available.')\" ) npts call show_message ( errmsg , WITH_ABORT ) end select !   Rotational icosahedral symmetry grids: case ( spherical_grid_type_i ) select case ( npts ) case ( 132 ); call id0132 ( xyz (:, 1 ), xyz (:, 2 ), xyz (:, 3 ), w , n ) case ( 152 ); call id0152 ( xyz (:, 1 ), xyz (:, 2 ), xyz (:, 3 ), w , n ) case ( 180 ); call id0180 ( xyz (:, 1 ), xyz (:, 2 ), xyz (:, 3 ), w , n ) case ( 192 ); call id0192 ( xyz (:, 1 ), xyz (:, 2 ), xyz (:, 3 ), w , n ) case ( 212 ); call id0212 ( xyz (:, 1 ), xyz (:, 2 ), xyz (:, 3 ), w , n ) case ( 242 ); call id0242 ( xyz (:, 1 ), xyz (:, 2 ), xyz (:, 3 ), w , n ) case default write ( errmsg , \"(' I-symmetry grid with ',i4,' points not available.')\" ) npts call show_message ( errmsg , WITH_ABORT ) end select case default call show_message ( \"Unknown spherical grid type\" , WITH_ABORT ) end select !   Final check if ( n /= npts ) then write ( errmsg , '(2(a,i8))' ) 'Error, the computed number of points N=' , n , & ' does not match requested NPTS=' , npts call show_message ( errmsg , WITH_ABORT ) end if end subroutine !> @brief Given a point on a sphere (specified by `a` and `b`), generate all !>    the equivalent points under octahedral (Oh or O) symmetry, !>    making grid points with weight `v`. !> @detail !>   The variable `num` is increased by the number of different points !>   generated. !> !>   Depending on code, there are 6...48 different but equivalent !>   points. !>   Full octahedral symmetry points: !>   code=1:   (0,0,1) etc                                (  6 points) !>   code=2:   (0,a,a) etc, a=1/sqrt(2)                   ( 12 points) !>   code=3:   (a,a,a) etc, a=1/sqrt(3)                   (  8 points) !>   code=4:   (a,a,b) etc, b=sqrt(1-2 a&#94;2)               ( 24 points) !>   code=5:   (a,b,0) etc, b=sqrt(1-a&#94;2), a input        ( 24 points) !>   code=6:   (a,b,c) etc, c=sqrt(1-a&#94;2-b&#94;2), a/b input  ( 48 points) !>   General octahedral points: !>   code=7:   (a,b,c) etc, c=sqrt(1-a&#94;2-b&#94;2), a/b input  ( 24 points) !> @note This routine is part of a set of routines that generate !>  Lebedev grids [1-6] for integration on a sphere. The original !>  C-code [1] was kindly provided by Dr. Dmitri N. Laikov and !>  translated into fortran by Dr. Christoph van Wuellen. !>  This routine was translated from C to Fortran77 by hand. !> !>  The original subroutine was heavily modified and extended !>  by Dr. Vladimir Mironov. !> !>  Users of this code are asked to include reference [1] in their !>  publications, and in the user- and programmers-manuals !>  describing their codes. !> !>  This code was distributed through CCL (http://www.ccl.net/). !> !>  [1] V.I. Lebedev, and D.N. Laikov !>      \"A quadrature formula for the sphere of the 131st !>       algebraic order of accuracy\" !>      Doklady Mathematics, vol. 59, no. 3, 1999, pp. 477-481. !> !>  [2] V.I. Lebedev !>      \"A quadrature formula for the sphere of 59th algebraic !>       order of accuracy\" !>      russian acad. sci. dokl. math., vol. 50, 1995, pp. 283-286. !> !>  [3] V.I. Lebedev, and A.L. Skorokhodov !>      \"Quadrature formulas of orders 41, 47, and 53 for the sphere\" !>      Russian Acad. Sci. Dokl. Math., vol. 45, 1992, pp. 587-592. !> !>  [4] V.I. Lebedev !>      \"Spherical quadrature formulas exact to orders 25-29\" !>      Siberian Mathematical Journal, vol. 18, 1977, pp. 99-107. !> !>  [5] V.I. Lebedev !>      \"Quadratures on a sphere\" !>      Computational Mathematics and Mathematical Physics, vol. 16, !>      1976, pp. 10-24. !> !>  [6] V.I. Lebedev !>      \"Values of the nodes and weights of ninth to seventeenth !>       order gauss-markov quadrature formulae invariant under the !>       octahedron group with inversion\" !>      Computational Mathematics and Mathematical Physics, vol. 15, !>      1975, pp. 44-51. ! subroutine gen_oh ( code , num , x , y , z , w , a , b , v ) use messages , only : show_message , WITH_ABORT real ( kind = dp ), intent ( out ) :: x ( * ), y ( * ), z ( * ), w ( * ) real ( kind = dp ), intent ( inout ) :: a , b , v integer , intent ( in ) :: code integer , intent ( inout ) :: num real ( kind = dp ) :: c select case ( code ) case ( 1 ) !     (0,0,1) etc,   6 points !     Octahedron vertices a = 1.0d0 x ( 1 : 6 ) = 0.0d0 y ( 1 : 6 ) = 0.0d0 z ( 1 : 6 ) = 0.0d0 x ( 1 ) = a x ( 2 ) = - a y ( 3 ) = a y ( 4 ) = - a z ( 5 ) = a z ( 6 ) = - a w ( 1 : 6 ) = v num = num + 6 case ( 2 ) !     (0,a,a) etc, a=1/sqrt(2), 12 points a = sqrt ( 0.5d0 ) call gen_td ( num , x , y , z , w , 0.0d0 , a , a , v ) case ( 3 ) !     (a,a,a) etc, a=1/sqrt(3), 8 points !     Cube vertices a = sqrt ( 1.0d0 / 3.0d0 ) x ( 1 ) = a ; y ( 1 ) = a ; z ( 1 ) = a x ( 2 ) = - a ; y ( 2 ) = a ; z ( 2 ) = a x ( 3 ) = a ; y ( 3 ) = - a ; z ( 3 ) = a x ( 4 ) = - a ; y ( 4 ) = - a ; z ( 4 ) = a x ( 5 ) = a ; y ( 5 ) = a ; z ( 5 ) = - a x ( 6 ) = - a ; y ( 6 ) = a ; z ( 6 ) = - a x ( 7 ) = a ; y ( 7 ) = - a ; z ( 7 ) = - a x ( 8 ) = - a ; y ( 8 ) = - a ; z ( 8 ) = - a w ( 1 : 8 ) = v num = num + 8 case ( 4 ) !     (a,a,b) etc, b=sqrt(1-2 a&#94;2), 24 points b = sqrt ( 1.0d0 - 2.0d0 * a * a ) call gen_td ( num , x , y , z , w , a , a , b , v ) call gen_td ( num , x ( 13 ), y ( 13 ), z ( 13 ), w ( 13 ), a , a , - b , v ) case ( 5 ) !     (a,b,0) etc, b=sqrt(1-a&#94;2), a input, 24 points b = sqrt ( 1.0d0 - a * a ) call gen_td ( num , x , y , z , w , a , 0.0d0 , b , v ) call gen_td ( num , x ( 13 ), y ( 13 ), z ( 13 ), w ( 13 ), 0.0d0 , a , b , v ) case ( 6 ) !     (a,b,c) etc, c=sqrt(1-a&#94;2-b&#94;2), a/b input, 48 points c = sqrt ( 1.0d0 - a * a - b * b ) call gen_td ( num , x , y , z , w , a , b , c , v ) call gen_td ( num , x ( 13 ), y ( 13 ), z ( 13 ), w ( 13 ), a , b , - c , v ) call gen_td ( num , x ( 25 ), y ( 25 ), z ( 25 ), w ( 25 ), b , a , c , v ) call gen_td ( num , x ( 37 ), y ( 37 ), z ( 37 ), w ( 37 ), b , a , - c , v ) case ( 7 ) !     (a,b,c) etc, c=sqrt(1-a&#94;2-b&#94;2), a/b input, 24 points c = sqrt ( 1.0d0 - a * a - b * b ) call gen_td ( num , x ( 1 ), y ( 1 ), z ( 1 ), w ( 1 ), a , b , c , v ) call gen_td ( num , x ( 13 ), y ( 13 ), z ( 13 ), w ( 13 ), a , - c , b , v ) case default call show_message ( 'GEN_OH: INVALID CODE' , WITH_ABORT ) end select end subroutine !--------------------------------------------------------------------- !> @brief Given a point on a sphere (specified by `a` and `b`), generate all !>    the equivalent points under Ih symmetry, making grid points with !>    weight `v`. !> @author Vladimir Mironov subroutine gen_ih ( code , num , x , y , z , w , a , b , v ) use messages , only : show_message , WITH_ABORT implicit none real ( kind = dp ), intent ( inout ) :: x ( * ), y ( * ), z ( * ), w ( * ) real ( kind = dp ), intent ( inout ) :: a , b , v real ( kind = dp ) :: c integer code integer num integer n double precision g , h , t parameter ( g = ( sqrt ( 5.0d0 ) + 1.0d0 ) * 0.25d0 ) parameter ( h = ( sqrt ( 5.0d0 ) - 1.0d0 ) * 0.25d0 ) parameter ( t = 0.5d0 ) n = 1 select case ( code ) case ( 1 ) a = sqrt (( 5.0d0 + sqrt ( 5.0d0 )) / 1 0.0d0 ) b = sqrt (( 5.0d0 - sqrt ( 5.0d0 )) / 1 0.0d0 ) c = 0.0d0 call gen_td ( n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , c , v ) num = num + 12 case ( 2 ) a = sqrt (( 3.0d0 - sqrt ( 5.0d0 )) / 6.0d0 ) b = sqrt (( 3.0d0 + sqrt ( 5.0d0 )) / 6.0d0 ) c = 0.0d0 call gen_td ( n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , c , v ) c = 1.0d0 / sqrt ( 3.0d0 ) call gen_oh ( 3 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) num = num + 20 case ( 3 ) call gen_oh ( 1 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = g b = h c = t call gen_oh ( 7 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) num = num + 30 case ( 4 ) c = sqrt ( 1.0d0 - a * a - b * b ) call gen_td ( n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , c , v ) call ih_tr ( a , b , c ) call gen_td ( n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , c , v ) call ih_tr ( a , b , c ) call gen_td ( n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , c , v ) call ih_tr ( a , b , c ) call gen_td ( n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , c , v ) call ih_tr ( a , b , c ) call gen_td ( n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , c , v ) num = num + 60 case default call show_message ( 'GEN_IH: INVALID CODE' , WITH_ABORT ) end select end subroutine !--------------------------------------------------------------------- !> @brief Given a point on a sphere (specified by `x`, `y`, and `z`), !>    permute its coordinates, so the new point belongs to the next !>    tetrahedron within icosahedron. !> @note This is supplementary subroutine to the others !> @author Vladimir Mironov subroutine ih_tr ( x , y , z ) real ( kind = dp ), intent ( inout ) :: x , y , z real ( kind = dp ) :: x_tmp , y_tmp , z_tmp real ( kind = dp ), parameter :: g = ( sqrt ( 5.0d0 ) + 1.0d0 ) * 0.25d0 real ( kind = dp ), parameter :: h = ( sqrt ( 5.0d0 ) - 1.0d0 ) * 0.25d0 real ( kind = dp ), parameter :: t = 0.5d0 ! New point: ! |x|   |g  h -t|   |x| ! |y| = |h  t  g| x |y| ! |z|   |t -g  h|   |z| x_tmp = g * x + h * y - t * z y_tmp = h * x + t * y + g * z z_tmp = t * x - g * y + h * z x = x_tmp y = y_tmp z = z_tmp end subroutine !--------------------------------------------------------------------- !> @brief Given a point on a sphere (specified by `a` and `b`), generate all !>    the equivalent points under Td symmetry, making grid points with !>    weight `v`. !> @note This is supplementary subroutine to the others !> @author Vladimir Mironov subroutine gen_td ( num , x , y , z , w , a , b , c , v ) real ( kind = dp ), intent ( inout ) :: x ( * ), y ( * ), z ( * ), w ( * ) real ( kind = dp ), intent ( in ) :: a , b , c , v integer , intent ( inout ) :: num !     a*a + b*b + c*c = 1 x ( 1 ) = a ; y ( 1 ) = b ; z ( 1 ) = c x ( 2 ) = - a ; y ( 2 ) = - b ; z ( 2 ) = c x ( 3 ) = - a ; y ( 3 ) = b ; z ( 3 ) = - c x ( 4 ) = a ; y ( 4 ) = - b ; z ( 4 ) = - c x ( 5 ) = c ; y ( 5 ) = a ; z ( 5 ) = b x ( 6 ) = c ; y ( 6 ) = - a ; z ( 6 ) = - b x ( 7 ) = - c ; y ( 7 ) = - a ; z ( 7 ) = b x ( 8 ) = - c ; y ( 8 ) = a ; z ( 8 ) = - b x ( 9 ) = b ; y ( 9 ) = c ; z ( 9 ) = a x ( 10 ) = - b ; y ( 10 ) = c ; z ( 10 ) = - a x ( 11 ) = b ; y ( 11 ) = - c ; z ( 11 ) = - a x ( 12 ) = - b ; y ( 12 ) = - c ; z ( 12 ) = a w ( 1 : 12 ) = v num = num + 12 end subroutine !--------------------------------------------------------------------- subroutine ld0006 ( x , y , z , w , n ) real ( kind = dp ) :: x ( * ) real ( kind = dp ) :: y ( * ) real ( kind = dp ) :: z ( * ) real ( kind = dp ) :: w ( * ) integer :: n real ( kind = dp ) :: a , b , v ! !      LEBEDEV 6-POINT ANGULAR GRID ! !      This routine is part of a set of routines that generate !      Lebedev grids [1-6] for integration on a sphere. The original !      C-code [1] was kindly provided by Dr. Dmitri N. Laikov and !      translated into Fortran by Dr. Christoph van Wüllen. !      This routine was translated using a C to Fortran77 conversion !      tool written by Dr. Christoph van Wüllen. ! !      Users of this code are asked to include reference [1] in their !      publications, and in the user and programmer manuals !      describing their codes. ! !      This code was distributed through CCL (http://www.ccl.net/). ! !      References: ! !      [1] V.I. Lebedev and D.N. Laikov, !          \"A Quadrature Formula for the Sphere of the 131st !          Algebraic Order of Accuracy,\" !          Doklady Mathematics, Vol. 59, No. 3, 1999, pp. 477-481. ! !      [2] V.I. Lebedev, !          \"A Quadrature Formula for the Sphere of 59th Algebraic !          Order of Accuracy,\" !          Russian Acad. Sci. Dokl. Math., Vol. 50, 1995, pp. 283-286. ! !      [3] V.I. Lebedev and A.L. Skorokhodov, !          \"Quadrature Formulas of Orders 41, 47, and 53 for the Sphere,\" !          Russian Acad. Sci. Dokl. Math., Vol. 45, 1992, pp. 587-592. ! !      [4] V.I. Lebedev, !          \"Spherical Quadrature Formulas Exact to Orders 25-29,\" !          Siberian Mathematical Journal, Vol. 18, 1977, pp. 99-107. ! !      [5] V.I. Lebedev, !          \"Quadratures on a Sphere,\" !          Computational Mathematics and Mathematical Physics, Vol. 16, !          1976, pp. 10-24. ! !      [6] V.I. Lebedev, !          \"Values of the Nodes and Weights of Ninth to Seventeenth !          Order Gauss-Markov Quadrature Formulae Invariant under the !          Octahedron Group with Inversion,\" !          Computational Mathematics and Mathematical Physics, Vol. 15, !          1975, pp. 44-51. ! n = 1 v = 0.1666666666666667d+00 call gen_oh ( 1 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) n = n - 1 end subroutine subroutine ld0014 ( x , y , z , w , n ) real ( kind = dp ) :: x ( * ) real ( kind = dp ) :: y ( * ) real ( kind = dp ) :: z ( * ) real ( kind = dp ) :: w ( * ) integer :: n real ( kind = dp ) :: a , b , v ! !      LEBEDEV 14-POINT ANGULAR GRID ! !      This routine is part of a set of routines that generate !      Lebedev grids [1-6] for integration on a sphere. The original !      C-code [1] was kindly provided by Dr. Dmitri N. Laikov and !      translated into Fortran by Dr. Christoph van Wüllen. !      This routine was translated using a C to Fortran77 conversion !      tool written by Dr. Christoph van Wüllen. ! !      Users of this code are asked to include reference [1] in their !      publications, and in the user and programmer manuals !      describing their codes. ! !      This code was distributed through CCL (http://www.ccl.net/). ! !      References: ! !      [1] V.I. Lebedev and D.N. Laikov, !          \"A Quadrature Formula for the Sphere of the 131st !          Algebraic Order of Accuracy,\" !          Doklady Mathematics, Vol. 59, No. 3, 1999, pp. 477-481. ! !      [2] V.I. Lebedev, !          \"A Quadrature Formula for the Sphere of 59th Algebraic !          Order of Accuracy,\" !          Russian Acad. Sci. Dokl. Math., Vol. 50, 1995, pp. 283-286. ! !      [3] V.I. Lebedev and A.L. Skorokhodov, !          \"Quadrature Formulas of Orders 41, 47, and 53 for the Sphere,\" !          Russian Acad. Sci. Dokl. Math., Vol. 45, 1992, pp. 587-592. ! !      [4] V.I. Lebedev, !          \"Spherical Quadrature Formulas Exact to Orders 25-29,\" !          Siberian Mathematical Journal, Vol. 18, 1977, pp. 99-107. ! !      [5] V.I. Lebedev, !          \"Quadratures on a Sphere,\" !          Computational Mathematics and Mathematical Physics, Vol. 16, !          1976, pp. 10-24. ! !      [6] V.I. Lebedev, !          \"Values of the Nodes and Weights of Ninth to Seventeenth !          Order Gauss-Markov Quadrature Formulae Invariant under the !          Octahedron Group with Inversion,\" !          Computational Mathematics and Mathematical Physics, Vol. 15, !          1975, pp. 44-51. ! n = 1 v = 0.6666666666666667d-01 call gen_oh ( 1 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) v = 0.7500000000000000d-01 call gen_oh ( 3 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) n = n - 1 end subroutine subroutine ld0026 ( x , y , z , w , n ) real ( kind = dp ) :: x ( * ) real ( kind = dp ) :: y ( * ) real ( kind = dp ) :: z ( * ) real ( kind = dp ) :: w ( * ) integer :: n real ( kind = dp ) :: a , b , v ! !      LEBEDEV   26-POINT ANGULAR GRID ! ! !      THIS ROUTINE IS PART OF A SET OF ROUTINES THAT GENERATE !      LEBEDEV GRIDS [1-6] FOR INTEGRATION ON A SPHERE. THE ORIGINAL !      C-CODE [1] WAS KINDLY PROVIDED BY DR. DMITRI N. LAIKOV AND !      TRANSLATED INTO FORTRAN BY DR. CHRISTOPH VAN WUELLEN. !      THIS ROUTINE WAS TRANSLATED USING A C TO FORTRAN77 CONVERSION !      TOOL WRITTEN BY DR. CHRISTOPH VAN WUELLEN. ! !      USERS OF THIS CODE ARE ASKED TO INCLUDE REFERENCE [1] IN THEIR !      PUBLICATIONS, AND IN THE USER- AND PROGRAMMERS-MANUALS !      DESCRIBING THEIR CODES. ! !      THIS CODE WAS DISTRIBUTED THROUGH CCL (HTTP://WWW.CCL.NET/). ! !      [1] V.I. LEBEDEV, AND D.N. LAIKOV !          \"A QUADRATURE FORMULA FOR THE SPHERE OF THE 131ST !           ALGEBRAIC ORDER OF ACCURACY\" !          DOKLADY MATHEMATICS, VOL. 59, NO. 3, 1999, PP. 477-481. ! !      [2] V.I. LEBEDEV !          \"A QUADRATURE FORMULA FOR THE SPHERE OF 59TH ALGEBRAIC !           ORDER OF ACCURACY\" !          RUSSIAN ACAD. SCI. DOKL. MATH., VOL. 50, 1995, PP. 283-286. ! !      [3] V.I. LEBEDEV, AND A.L. SKOROKHODOV !          \"QUADRATURE FORMULAS OF ORDERS 41, 47, AND 53 FOR THE SPHERE\" !          RUSSIAN ACAD. SCI. DOKL. MATH., VOL. 45, 1992, PP. 587-592. ! !      [4] V.I. LEBEDEV !          \"SPHERICAL QUADRATURE FORMULAS EXACT TO ORDERS 25-29\" !          SIBERIAN MATHEMATICAL JOURNAL, VOL. 18, 1977, PP. 99-107. ! !      [5] V.I. LEBEDEV !          \"QUADRATURES ON A SPHERE\" !          COMPUTATIONAL MATHEMATICS AND MATHEMATICAL PHYSICS, VOL. 16, !          1976, PP. 10-24. ! !      [6] V.I. LEBEDEV !          \"VALUES OF THE NODES AND WEIGHTS OF NINTH TO SEVENTEENTH !           ORDER GAUSS-MARKOV QUADRATURE FORMULAE INVARIANT UNDER THE !           OCTAHEDRON GROUP WITH INVERSION\" !          COMPUTATIONAL MATHEMATICS AND MATHEMATICAL PHYSICS, VOL. 15, !          1975, PP. 44-51. ! n = 1 v = 0.4761904761904762d-01 call gen_oh ( 1 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) v = 0.3809523809523810d-01 call gen_oh ( 2 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) v = 0.3214285714285714d-01 call gen_oh ( 3 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) n = n - 1 end subroutine subroutine ld0038 ( x , y , z , w , n ) real ( kind = dp ) :: x ( * ) real ( kind = dp ) :: y ( * ) real ( kind = dp ) :: z ( * ) real ( kind = dp ) :: w ( * ) integer :: n real ( kind = dp ) :: a , b , v ! !      LEBEDEV   38-POINT ANGULAR GRID ! ! !      THIS ROUTINE IS PART OF A SET OF ROUTINES THAT GENERATE !      LEBEDEV GRIDS [1-6] FOR INTEGRATION ON A SPHERE. THE ORIGINAL !      C-CODE [1] WAS KINDLY PROVIDED BY DR. DMITRI N. LAIKOV AND !      TRANSLATED INTO FORTRAN BY DR. CHRISTOPH VAN WUELLEN. !      THIS ROUTINE WAS TRANSLATED USING A C TO FORTRAN77 CONVERSION !      TOOL WRITTEN BY DR. CHRISTOPH VAN WUELLEN. ! !      USERS OF THIS CODE ARE ASKED TO INCLUDE REFERENCE [1] IN THEIR !      PUBLICATIONS, AND IN THE USER- AND PROGRAMMERS-MANUALS !      DESCRIBING THEIR CODES. ! !      THIS CODE WAS DISTRIBUTED THROUGH CCL (HTTP://WWW.CCL.NET/). ! !      [1] V.I. LEBEDEV, AND D.N. LAIKOV !          \"A QUADRATURE FORMULA FOR THE SPHERE OF THE 131ST !           ALGEBRAIC ORDER OF ACCURACY\" !          DOKLADY MATHEMATICS, VOL. 59, NO. 3, 1999, PP. 477-481. ! !      [2] V.I. LEBEDEV !          \"A QUADRATURE FORMULA FOR THE SPHERE OF 59TH ALGEBRAIC !           ORDER OF ACCURACY\" !          RUSSIAN ACAD. SCI. DOKL. MATH., VOL. 50, 1995, PP. 283-286. ! !      [3] V.I. LEBEDEV, AND A.L. SKOROKHODOV !          \"QUADRATURE FORMULAS OF ORDERS 41, 47, AND 53 FOR THE SPHERE\" !          RUSSIAN ACAD. SCI. DOKL. MATH., VOL. 45, 1992, PP. 587-592. ! !      [4] V.I. LEBEDEV !          \"SPHERICAL QUADRATURE FORMULAS EXACT TO ORDERS 25-29\" !          SIBERIAN MATHEMATICAL JOURNAL, VOL. 18, 1977, PP. 99-107. ! !      [5] V.I. LEBEDEV !          \"QUADRATURES ON A SPHERE\" !          COMPUTATIONAL MATHEMATICS AND MATHEMATICAL PHYSICS, VOL. 16, !          1976, PP. 10-24. ! !      [6] V.I. LEBEDEV !          \"VALUES OF THE NODES AND WEIGHTS OF NINTH TO SEVENTEENTH !           ORDER GAUSS-MARKOV QUADRATURE FORMULAE INVARIANT UNDER THE !           OCTAHEDRON GROUP WITH INVERSION\" !          COMPUTATIONAL MATHEMATICS AND MATHEMATICAL PHYSICS, VOL. 15, !          1975, PP. 44-51. ! n = 1 v = 0.9523809523809524d-02 call gen_oh ( 1 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) v = 0.3214285714285714d-01 call gen_oh ( 3 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.4597008433809831d+00 v = 0.2857142857142857d-01 call gen_oh ( 5 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) n = n - 1 end subroutine subroutine ld0050 ( x , y , z , w , n ) real ( kind = dp ) :: x ( * ) real ( kind = dp ) :: y ( * ) real ( kind = dp ) :: z ( * ) real ( kind = dp ) :: w ( * ) integer :: n real ( kind = dp ) :: a , b , v ! !      LEBEDEV   50-POINT ANGULAR GRID ! ! !      THIS ROUTINE IS PART OF A SET OF ROUTINES THAT GENERATE !      LEBEDEV GRIDS [1-6] FOR INTEGRATION ON A SPHERE. THE ORIGINAL !      C-CODE [1] WAS KINDLY PROVIDED BY DR. DMITRI N. LAIKOV AND !      TRANSLATED INTO FORTRAN BY DR. CHRISTOPH VAN WUELLEN. !      THIS ROUTINE WAS TRANSLATED USING A C TO FORTRAN77 CONVERSION !      TOOL WRITTEN BY DR. CHRISTOPH VAN WUELLEN. ! !      USERS OF THIS CODE ARE ASKED TO INCLUDE REFERENCE [1] IN THEIR !      PUBLICATIONS, AND IN THE USER- AND PROGRAMMERS-MANUALS !      DESCRIBING THEIR CODES. ! !      THIS CODE WAS DISTRIBUTED THROUGH CCL (HTTP://WWW.CCL.NET/). ! !      [1] V.I. LEBEDEV, AND D.N. LAIKOV !          \"A QUADRATURE FORMULA FOR THE SPHERE OF THE 131ST !           ALGEBRAIC ORDER OF ACCURACY\" !          DOKLADY MATHEMATICS, VOL. 59, NO. 3, 1999, PP. 477-481. ! !      [2] V.I. LEBEDEV !          \"A QUADRATURE FORMULA FOR THE SPHERE OF 59TH ALGEBRAIC !           ORDER OF ACCURACY\" !          RUSSIAN ACAD. SCI. DOKL. MATH., VOL. 50, 1995, PP. 283-286. ! !      [3] V.I. LEBEDEV, AND A.L. SKOROKHODOV !          \"QUADRATURE FORMULAS OF ORDERS 41, 47, AND 53 FOR THE SPHERE\" !          RUSSIAN ACAD. SCI. DOKL. MATH., VOL. 45, 1992, PP. 587-592. ! !      [4] V.I. LEBEDEV !          \"SPHERICAL QUADRATURE FORMULAS EXACT TO ORDERS 25-29\" !          SIBERIAN MATHEMATICAL JOURNAL, VOL. 18, 1977, PP. 99-107. ! !      [5] V.I. LEBEDEV !          \"QUADRATURES ON A SPHERE\" !          COMPUTATIONAL MATHEMATICS AND MATHEMATICAL PHYSICS, VOL. 16, !          1976, PP. 10-24. ! !      [6] V.I. LEBEDEV !          \"VALUES OF THE NODES AND WEIGHTS OF NINTH TO SEVENTEENTH !           ORDER GAUSS-MARKOV QUADRATURE FORMULAE INVARIANT UNDER THE !           OCTAHEDRON GROUP WITH INVERSION\" !          COMPUTATIONAL MATHEMATICS AND MATHEMATICAL PHYSICS, VOL. 15, !          1975, PP. 44-51. ! n = 1 v = 0.1269841269841270d-01 call gen_oh ( 1 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) v = 0.2257495590828924d-01 call gen_oh ( 2 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) v = 0.2109375000000000d-01 call gen_oh ( 3 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.3015113445777636d+00 v = 0.2017333553791887d-01 call gen_oh ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) n = n - 1 end subroutine subroutine ld0074 ( x , y , z , w , n ) real ( kind = dp ) :: x ( * ) real ( kind = dp ) :: y ( * ) real ( kind = dp ) :: z ( * ) real ( kind = dp ) :: w ( * ) integer :: n real ( kind = dp ) :: a , b , v ! !      LEBEDEV   74-POINT ANGULAR GRID ! ! !      THIS ROUTINE IS PART OF A SET OF ROUTINES THAT GENERATE !      LEBEDEV GRIDS [1-6] FOR INTEGRATION ON A SPHERE. THE ORIGINAL !      C-CODE [1] WAS KINDLY PROVIDED BY DR. DMITRI N. LAIKOV AND !      TRANSLATED INTO FORTRAN BY DR. CHRISTOPH VAN WUELLEN. !      THIS ROUTINE WAS TRANSLATED USING A C TO FORTRAN77 CONVERSION !      TOOL WRITTEN BY DR. CHRISTOPH VAN WUELLEN. ! !      USERS OF THIS CODE ARE ASKED TO INCLUDE REFERENCE [1] IN THEIR !      PUBLICATIONS, AND IN THE USER- AND PROGRAMMERS-MANUALS !      DESCRIBING THEIR CODES. ! !      THIS CODE WAS DISTRIBUTED THROUGH CCL (HTTP://WWW.CCL.NET/). ! !      [1] V.I. LEBEDEV, AND D.N. LAIKOV !          \"A QUADRATURE FORMULA FOR THE SPHERE OF THE 131ST !           ALGEBRAIC ORDER OF ACCURACY\" !          DOKLADY MATHEMATICS, VOL. 59, NO. 3, 1999, PP. 477-481. ! !      [2] V.I. LEBEDEV !          \"A QUADRATURE FORMULA FOR THE SPHERE OF 59TH ALGEBRAIC !           ORDER OF ACCURACY\" !          RUSSIAN ACAD. SCI. DOKL. MATH., VOL. 50, 1995, PP. 283-286. ! !      [3] V.I. LEBEDEV, AND A.L. SKOROKHODOV !          \"QUADRATURE FORMULAS OF ORDERS 41, 47, AND 53 FOR THE SPHERE\" !          RUSSIAN ACAD. SCI. DOKL. MATH., VOL. 45, 1992, PP. 587-592. ! !      [4] V.I. LEBEDEV !          \"SPHERICAL QUADRATURE FORMULAS EXACT TO ORDERS 25-29\" !          SIBERIAN MATHEMATICAL JOURNAL, VOL. 18, 1977, PP. 99-107. ! !      [5] V.I. LEBEDEV !          \"QUADRATURES ON A SPHERE\" !          COMPUTATIONAL MATHEMATICS AND MATHEMATICAL PHYSICS, VOL. 16, !          1976, PP. 10-24. ! !      [6] V.I. LEBEDEV !          \"VALUES OF THE NODES AND WEIGHTS OF NINTH TO SEVENTEENTH !           ORDER GAUSS-MARKOV QUADRATURE FORMULAE INVARIANT UNDER THE !           OCTAHEDRON GROUP WITH INVERSION\" !          COMPUTATIONAL MATHEMATICS AND MATHEMATICAL PHYSICS, VOL. 15, !          1975, PP. 44-51. ! n = 1 v = 0.5130671797338464d-03 call gen_oh ( 1 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) v = 0.1660406956574204d-01 call gen_oh ( 2 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) v = - 0.2958603896103896d-01 call gen_oh ( 3 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.4803844614152614d+00 v = 0.2657620708215946d-01 call gen_oh ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.3207726489807764d+00 v = 0.1652217099371571d-01 call gen_oh ( 5 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) n = n - 1 end subroutine subroutine ld0086 ( x , y , z , w , n ) real ( kind = dp ) :: x ( * ) real ( kind = dp ) :: y ( * ) real ( kind = dp ) :: z ( * ) real ( kind = dp ) :: w ( * ) integer :: n real ( kind = dp ) :: a , b , v ! !      LEBEDEV   86-POINT ANGULAR GRID ! ! !      THIS ROUTINE IS PART OF A SET OF ROUTINES THAT GENERATE !      LEBEDEV GRIDS [1-6] FOR INTEGRATION ON A SPHERE. THE ORIGINAL !      C-CODE [1] WAS KINDLY PROVIDED BY DR. DMITRI N. LAIKOV AND !      TRANSLATED INTO FORTRAN BY DR. CHRISTOPH VAN WUELLEN. !      THIS ROUTINE WAS TRANSLATED USING A C TO FORTRAN77 CONVERSION !      TOOL WRITTEN BY DR. CHRISTOPH VAN WUELLEN. ! !      USERS OF THIS CODE ARE ASKED TO INCLUDE REFERENCE [1] IN THEIR !      PUBLICATIONS, AND IN THE USER- AND PROGRAMMERS-MANUALS !      DESCRIBING THEIR CODES. ! !      THIS CODE WAS DISTRIBUTED THROUGH CCL (HTTP://WWW.CCL.NET/). ! !      [1] V.I. LEBEDEV, AND D.N. LAIKOV !          \"A QUADRATURE FORMULA FOR THE SPHERE OF THE 131ST !           ALGEBRAIC ORDER OF ACCURACY\" !          DOKLADY MATHEMATICS, VOL. 59, NO. 3, 1999, PP. 477-481. ! !      [2] V.I. LEBEDEV !          \"A QUADRATURE FORMULA FOR THE SPHERE OF 59TH ALGEBRAIC !           ORDER OF ACCURACY\" !          RUSSIAN ACAD. SCI. DOKL. MATH., VOL. 50, 1995, PP. 283-286. ! !      [3] V.I. LEBEDEV, AND A.L. SKOROKHODOV !          \"QUADRATURE FORMULAS OF ORDERS 41, 47, AND 53 FOR THE SPHERE\" !          RUSSIAN ACAD. SCI. DOKL. MATH., VOL. 45, 1992, PP. 587-592. ! !      [4] V.I. LEBEDEV !          \"SPHERICAL QUADRATURE FORMULAS EXACT TO ORDERS 25-29\" !          SIBERIAN MATHEMATICAL JOURNAL, VOL. 18, 1977, PP. 99-107. ! !      [5] V.I. LEBEDEV !          \"QUADRATURES ON A SPHERE\" !          COMPUTATIONAL MATHEMATICS AND MATHEMATICAL PHYSICS, VOL. 16, !          1976, PP. 10-24. ! !      [6] V.I. LEBEDEV !          \"VALUES OF THE NODES AND WEIGHTS OF NINTH TO SEVENTEENTH !           ORDER GAUSS-MARKOV QUADRATURE FORMULAE INVARIANT UNDER THE !           OCTAHEDRON GROUP WITH INVERSION\" !          COMPUTATIONAL MATHEMATICS AND MATHEMATICAL PHYSICS, VOL. 15, !          1975, PP. 44-51. ! n = 1 v = 0.1154401154401154d-01 call gen_oh ( 1 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) v = 0.1194390908585628d-01 call gen_oh ( 3 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.3696028464541502d+00 v = 0.1111055571060340d-01 call gen_oh ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.6943540066026664d+00 v = 0.1187650129453714d-01 call gen_oh ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.3742430390903412d+00 v = 0.1181230374690448d-01 call gen_oh ( 5 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) n = n - 1 end subroutine subroutine ld0110 ( x , y , z , w , n ) real ( kind = dp ) :: x ( * ) real ( kind = dp ) :: y ( * ) real ( kind = dp ) :: z ( * ) real ( kind = dp ) :: w ( * ) integer :: n real ( kind = dp ) :: a , b , v ! !      LEBEDEV  110-POINT ANGULAR GRID ! ! !      THIS ROUTINE IS PART OF A SET OF ROUTINES THAT GENERATE !      LEBEDEV GRIDS [1-6] FOR INTEGRATION ON A SPHERE. THE ORIGINAL !      C-CODE [1] WAS KINDLY PROVIDED BY DR. DMITRI N. LAIKOV AND !      TRANSLATED INTO FORTRAN BY DR. CHRISTOPH VAN WUELLEN. !      THIS ROUTINE WAS TRANSLATED USING A C TO FORTRAN77 CONVERSION !      TOOL WRITTEN BY DR. CHRISTOPH VAN WUELLEN. ! !      USERS OF THIS CODE ARE ASKED TO INCLUDE REFERENCE [1] IN THEIR !      PUBLICATIONS, AND IN THE USER- AND PROGRAMMERS-MANUALS !      DESCRIBING THEIR CODES. ! !      THIS CODE WAS DISTRIBUTED THROUGH CCL (HTTP://WWW.CCL.NET/). ! !      [1] V.I. LEBEDEV, AND D.N. LAIKOV !          \"A QUADRATURE FORMULA FOR THE SPHERE OF THE 131ST !           ALGEBRAIC ORDER OF ACCURACY\" !          DOKLADY MATHEMATICS, VOL. 59, NO. 3, 1999, PP. 477-481. ! !      [2] V.I. LEBEDEV !          \"A QUADRATURE FORMULA FOR THE SPHERE OF 59TH ALGEBRAIC !           ORDER OF ACCURACY\" !          RUSSIAN ACAD. SCI. DOKL. MATH., VOL. 50, 1995, PP. 283-286. ! !      [3] V.I. LEBEDEV, AND A.L. SKOROKHODOV !          \"QUADRATURE FORMULAS OF ORDERS 41, 47, AND 53 FOR THE SPHERE\" !          RUSSIAN ACAD. SCI. DOKL. MATH., VOL. 45, 1992, PP. 587-592. ! !      [4] V.I. LEBEDEV !          \"SPHERICAL QUADRATURE FORMULAS EXACT TO ORDERS 25-29\" !          SIBERIAN MATHEMATICAL JOURNAL, VOL. 18, 1977, PP. 99-107. ! !      [5] V.I. LEBEDEV !          \"QUADRATURES ON A SPHERE\" !          COMPUTATIONAL MATHEMATICS AND MATHEMATICAL PHYSICS, VOL. 16, !          1976, PP. 10-24. ! !      [6] V.I. LEBEDEV !          \"VALUES OF THE NODES AND WEIGHTS OF NINTH TO SEVENTEENTH !           ORDER GAUSS-MARKOV QUADRATURE FORMULAE INVARIANT UNDER THE !           OCTAHEDRON GROUP WITH INVERSION\" !          COMPUTATIONAL MATHEMATICS AND MATHEMATICAL PHYSICS, VOL. 15, !          1975, PP. 44-51. ! n = 1 v = 0.3828270494937162d-02 call gen_oh ( 1 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) v = 0.9793737512487512d-02 call gen_oh ( 3 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.1851156353447362d+00 v = 0.8211737283191111d-02 call gen_oh ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.6904210483822922d+00 v = 0.9942814891178103d-02 call gen_oh ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.3956894730559419d+00 v = 0.9595471336070963d-02 call gen_oh ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.4783690288121502d+00 v = 0.9694996361663028d-02 call gen_oh ( 5 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) n = n - 1 end subroutine subroutine ld0146 ( x , y , z , w , n ) real ( kind = dp ) :: x ( * ) real ( kind = dp ) :: y ( * ) real ( kind = dp ) :: z ( * ) real ( kind = dp ) :: w ( * ) integer :: n real ( kind = dp ) :: a , b , v ! !      LEBEDEV  146-POINT ANGULAR GRID ! ! !      THIS ROUTINE IS PART OF A SET OF ROUTINES THAT GENERATE !      LEBEDEV GRIDS [1-6] FOR INTEGRATION ON A SPHERE. THE ORIGINAL !      C-CODE [1] WAS KINDLY PROVIDED BY DR. DMITRI N. LAIKOV AND !      TRANSLATED INTO FORTRAN BY DR. CHRISTOPH VAN WUELLEN. !      THIS ROUTINE WAS TRANSLATED USING A C TO FORTRAN77 CONVERSION !      TOOL WRITTEN BY DR. CHRISTOPH VAN WUELLEN. ! !      USERS OF THIS CODE ARE ASKED TO INCLUDE REFERENCE [1] IN THEIR !      PUBLICATIONS, AND IN THE USER- AND PROGRAMMERS-MANUALS !      DESCRIBING THEIR CODES. ! !      THIS CODE WAS DISTRIBUTED THROUGH CCL (HTTP://WWW.CCL.NET/). ! !      [1] V.I. LEBEDEV, AND D.N. LAIKOV !          \"A QUADRATURE FORMULA FOR THE SPHERE OF THE 131ST !           ALGEBRAIC ORDER OF ACCURACY\" !          DOKLADY MATHEMATICS, VOL. 59, NO. 3, 1999, PP. 477-481. ! !      [2] V.I. LEBEDEV !          \"A QUADRATURE FORMULA FOR THE SPHERE OF 59TH ALGEBRAIC !           ORDER OF ACCURACY\" !          RUSSIAN ACAD. SCI. DOKL. MATH., VOL. 50, 1995, PP. 283-286. ! !      [3] V.I. LEBEDEV, AND A.L. SKOROKHODOV !          \"QUADRATURE FORMULAS OF ORDERS 41, 47, AND 53 FOR THE SPHERE\" !          RUSSIAN ACAD. SCI. DOKL. MATH., VOL. 45, 1992, PP. 587-592. ! !      [4] V.I. LEBEDEV !          \"SPHERICAL QUADRATURE FORMULAS EXACT TO ORDERS 25-29\" !          SIBERIAN MATHEMATICAL JOURNAL, VOL. 18, 1977, PP. 99-107. ! !      [5] V.I. LEBEDEV !          \"QUADRATURES ON A SPHERE\" !          COMPUTATIONAL MATHEMATICS AND MATHEMATICAL PHYSICS, VOL. 16, !          1976, PP. 10-24. ! !      [6] V.I. LEBEDEV !          \"VALUES OF THE NODES AND WEIGHTS OF NINTH TO SEVENTEENTH !           ORDER GAUSS-MARKOV QUADRATURE FORMULAE INVARIANT UNDER THE !           OCTAHEDRON GROUP WITH INVERSION\" !          COMPUTATIONAL MATHEMATICS AND MATHEMATICAL PHYSICS, VOL. 15, !          1975, PP. 44-51. ! n = 1 v = 0.5996313688621381d-03 call gen_oh ( 1 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) v = 0.7372999718620756d-02 call gen_oh ( 2 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) v = 0.7210515360144488d-02 call gen_oh ( 3 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.6764410400114264d+00 v = 0.7116355493117555d-02 call gen_oh ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.4174961227965453d+00 v = 0.6753829486314477d-02 call gen_oh ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.1574676672039082d+00 v = 0.7574394159054034d-02 call gen_oh ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.1403553811713183d+00 b = 0.4493328323269557d+00 v = 0.6991087353303262d-02 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) n = n - 1 end subroutine subroutine ld0170 ( x , y , z , w , n ) real ( kind = dp ) :: x ( * ) real ( kind = dp ) :: y ( * ) real ( kind = dp ) :: z ( * ) real ( kind = dp ) :: w ( * ) integer :: n real ( kind = dp ) :: a , b , v ! !      LEBEDEV  170-POINT ANGULAR GRID ! ! !      THIS ROUTINE IS PART OF A SET OF ROUTINES THAT GENERATE !      LEBEDEV GRIDS [1-6] FOR INTEGRATION ON A SPHERE. THE ORIGINAL !      C-CODE [1] WAS KINDLY PROVIDED BY DR. DMITRI N. LAIKOV AND !      TRANSLATED INTO FORTRAN BY DR. CHRISTOPH VAN WUELLEN. !      THIS ROUTINE WAS TRANSLATED USING A C TO FORTRAN77 CONVERSION !      TOOL WRITTEN BY DR. CHRISTOPH VAN WUELLEN. ! !      USERS OF THIS CODE ARE ASKED TO INCLUDE REFERENCE [1] IN THEIR !      PUBLICATIONS, AND IN THE USER- AND PROGRAMMERS-MANUALS !      DESCRIBING THEIR CODES. ! !      THIS CODE WAS DISTRIBUTED THROUGH CCL (HTTP://WWW.CCL.NET/). ! !      [1] V.I. LEBEDEV, AND D.N. LAIKOV !          \"A QUADRATURE FORMULA FOR THE SPHERE OF THE 131ST !           ALGEBRAIC ORDER OF ACCURACY\" !          DOKLADY MATHEMATICS, VOL. 59, NO. 3, 1999, PP. 477-481. ! !      [2] V.I. LEBEDEV !          \"A QUADRATURE FORMULA FOR THE SPHERE OF 59TH ALGEBRAIC !           ORDER OF ACCURACY\" !          RUSSIAN ACAD. SCI. DOKL. MATH., VOL. 50, 1995, PP. 283-286. ! !      [3] V.I. LEBEDEV, AND A.L. SKOROKHODOV !          \"QUADRATURE FORMULAS OF ORDERS 41, 47, AND 53 FOR THE SPHERE\" !          RUSSIAN ACAD. SCI. DOKL. MATH., VOL. 45, 1992, PP. 587-592. ! !      [4] V.I. LEBEDEV !          \"SPHERICAL QUADRATURE FORMULAS EXACT TO ORDERS 25-29\" !          SIBERIAN MATHEMATICAL JOURNAL, VOL. 18, 1977, PP. 99-107. ! !      [5] V.I. LEBEDEV !          \"QUADRATURES ON A SPHERE\" !          COMPUTATIONAL MATHEMATICS AND MATHEMATICAL PHYSICS, VOL. 16, !          1976, PP. 10-24. ! !      [6] V.I. LEBEDEV !          \"VALUES OF THE NODES AND WEIGHTS OF NINTH TO SEVENTEENTH !           ORDER GAUSS-MARKOV QUADRATURE FORMULAE INVARIANT UNDER THE !           OCTAHEDRON GROUP WITH INVERSION\" !          COMPUTATIONAL MATHEMATICS AND MATHEMATICAL PHYSICS, VOL. 15, !          1975, PP. 44-51. ! n = 1 v = 0.5544842902037365d-02 call gen_oh ( 1 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) v = 0.6071332770670752d-02 call gen_oh ( 2 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) v = 0.6383674773515093d-02 call gen_oh ( 3 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.2551252621114134d+00 v = 0.5183387587747790d-02 call gen_oh ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.6743601460362766d+00 v = 0.6317929009813725d-02 call gen_oh ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.4318910696719410d+00 v = 0.6201670006589077d-02 call gen_oh ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.2613931360335988d+00 v = 0.5477143385137348d-02 call gen_oh ( 5 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.4990453161796037d+00 b = 0.1446630744325115d+00 v = 0.5968383987681156d-02 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) n = n - 1 end subroutine subroutine ld0194 ( x , y , z , w , n ) real ( kind = dp ) :: x ( * ) real ( kind = dp ) :: y ( * ) real ( kind = dp ) :: z ( * ) real ( kind = dp ) :: w ( * ) integer :: n real ( kind = dp ) :: a , b , v ! !      LEBEDEV  194-POINT ANGULAR GRID ! ! !      THIS ROUTINE IS PART OF A SET OF ROUTINES THAT GENERATE !      LEBEDEV GRIDS [1-6] FOR INTEGRATION ON A SPHERE. THE ORIGINAL !      C-CODE [1] WAS KINDLY PROVIDED BY DR. DMITRI N. LAIKOV AND !      TRANSLATED INTO FORTRAN BY DR. CHRISTOPH VAN WUELLEN. !      THIS ROUTINE WAS TRANSLATED USING A C TO FORTRAN77 CONVERSION !      TOOL WRITTEN BY DR. CHRISTOPH VAN WUELLEN. ! !      USERS OF THIS CODE ARE ASKED TO INCLUDE REFERENCE [1] IN THEIR !      PUBLICATIONS, AND IN THE USER- AND PROGRAMMERS-MANUALS !      DESCRIBING THEIR CODES. ! !      THIS CODE WAS DISTRIBUTED THROUGH CCL (HTTP://WWW.CCL.NET/). ! !      [1] V.I. LEBEDEV, AND D.N. LAIKOV !          \"A QUADRATURE FORMULA FOR THE SPHERE OF THE 131ST !           ALGEBRAIC ORDER OF ACCURACY\" !          DOKLADY MATHEMATICS, VOL. 59, NO. 3, 1999, PP. 477-481. ! !      [2] V.I. LEBEDEV !          \"A QUADRATURE FORMULA FOR THE SPHERE OF 59TH ALGEBRAIC !           ORDER OF ACCURACY\" !          RUSSIAN ACAD. SCI. DOKL. MATH., VOL. 50, 1995, PP. 283-286. ! !      [3] V.I. LEBEDEV, AND A.L. SKOROKHODOV !          \"QUADRATURE FORMULAS OF ORDERS 41, 47, AND 53 FOR THE SPHERE\" !          RUSSIAN ACAD. SCI. DOKL. MATH., VOL. 45, 1992, PP. 587-592. ! !      [4] V.I. LEBEDEV !          \"SPHERICAL QUADRATURE FORMULAS EXACT TO ORDERS 25-29\" !          SIBERIAN MATHEMATICAL JOURNAL, VOL. 18, 1977, PP. 99-107. ! !      [5] V.I. LEBEDEV !          \"QUADRATURES ON A SPHERE\" !          COMPUTATIONAL MATHEMATICS AND MATHEMATICAL PHYSICS, VOL. 16, !          1976, PP. 10-24. ! !      [6] V.I. LEBEDEV !          \"VALUES OF THE NODES AND WEIGHTS OF NINTH TO SEVENTEENTH !           ORDER GAUSS-MARKOV QUADRATURE FORMULAE INVARIANT UNDER THE !           OCTAHEDRON GROUP WITH INVERSION\" !          COMPUTATIONAL MATHEMATICS AND MATHEMATICAL PHYSICS, VOL. 15, !          1975, PP. 44-51. ! n = 1 v = 0.1782340447244611d-02 call gen_oh ( 1 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) v = 0.5716905949977102d-02 call gen_oh ( 2 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) v = 0.5573383178848738d-02 call gen_oh ( 3 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.6712973442695226d+00 v = 0.5608704082587997d-02 call gen_oh ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.2892465627575439d+00 v = 0.5158237711805383d-02 call gen_oh ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.4446933178717437d+00 v = 0.5518771467273614d-02 call gen_oh ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.1299335447650067d+00 v = 0.4106777028169394d-02 call gen_oh ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.3457702197611283d+00 v = 0.5051846064614808d-02 call gen_oh ( 5 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.1590417105383530d+00 b = 0.8360360154824589d+00 v = 0.5530248916233094d-02 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) n = n - 1 end subroutine subroutine ld0230 ( x , y , z , w , n ) real ( kind = dp ) :: x ( * ) real ( kind = dp ) :: y ( * ) real ( kind = dp ) :: z ( * ) real ( kind = dp ) :: w ( * ) integer :: n real ( kind = dp ) :: a , b , v ! !      LEBEDEV  230-POINT ANGULAR GRID ! ! !      THIS ROUTINE IS PART OF A SET OF ROUTINES THAT GENERATE !      LEBEDEV GRIDS [1-6] FOR INTEGRATION ON A SPHERE. THE ORIGINAL !      C-CODE [1] WAS KINDLY PROVIDED BY DR. DMITRI N. LAIKOV AND !      TRANSLATED INTO FORTRAN BY DR. CHRISTOPH VAN WUELLEN. !      THIS ROUTINE WAS TRANSLATED USING A C TO FORTRAN77 CONVERSION !      TOOL WRITTEN BY DR. CHRISTOPH VAN WUELLEN. ! !      USERS OF THIS CODE ARE ASKED TO INCLUDE REFERENCE [1] IN THEIR !      PUBLICATIONS, AND IN THE USER- AND PROGRAMMERS-MANUALS !      DESCRIBING THEIR CODES. ! !      THIS CODE WAS DISTRIBUTED THROUGH CCL (HTTP://WWW.CCL.NET/). ! !      [1] V.I. LEBEDEV, AND D.N. LAIKOV !          \"A QUADRATURE FORMULA FOR THE SPHERE OF THE 131ST !           ALGEBRAIC ORDER OF ACCURACY\" !          DOKLADY MATHEMATICS, VOL. 59, NO. 3, 1999, PP. 477-481. ! !      [2] V.I. LEBEDEV !          \"A QUADRATURE FORMULA FOR THE SPHERE OF 59TH ALGEBRAIC !           ORDER OF ACCURACY\" !          RUSSIAN ACAD. SCI. DOKL. MATH., VOL. 50, 1995, PP. 283-286. ! !      [3] V.I. LEBEDEV, AND A.L. SKOROKHODOV !          \"QUADRATURE FORMULAS OF ORDERS 41, 47, AND 53 FOR THE SPHERE\" !          RUSSIAN ACAD. SCI. DOKL. MATH., VOL. 45, 1992, PP. 587-592. ! !      [4] V.I. LEBEDEV !          \"SPHERICAL QUADRATURE FORMULAS EXACT TO ORDERS 25-29\" !          SIBERIAN MATHEMATICAL JOURNAL, VOL. 18, 1977, PP. 99-107. ! !      [5] V.I. LEBEDEV !          \"QUADRATURES ON A SPHERE\" !          COMPUTATIONAL MATHEMATICS AND MATHEMATICAL PHYSICS, VOL. 16, !          1976, PP. 10-24. ! !      [6] V.I. LEBEDEV !          \"VALUES OF THE NODES AND WEIGHTS OF NINTH TO SEVENTEENTH !           ORDER GAUSS-MARKOV QUADRATURE FORMULAE INVARIANT UNDER THE !           OCTAHEDRON GROUP WITH INVERSION\" !          COMPUTATIONAL MATHEMATICS AND MATHEMATICAL PHYSICS, VOL. 15, !          1975, PP. 44-51. ! n = 1 v = - 0.5522639919727325d-01 call gen_oh ( 1 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) v = 0.4450274607445226d-02 call gen_oh ( 3 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.4492044687397611d+00 v = 0.4496841067921404d-02 call gen_oh ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.2520419490210201d+00 v = 0.5049153450478750d-02 call gen_oh ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.6981906658447242d+00 v = 0.3976408018051883d-02 call gen_oh ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.6587405243460960d+00 v = 0.4401400650381014d-02 call gen_oh ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.4038544050097660d-01 v = 0.1724544350544401d-01 call gen_oh ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.5823842309715585d+00 v = 0.4231083095357343d-02 call gen_oh ( 5 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.3545877390518688d+00 v = 0.5198069864064399d-02 call gen_oh ( 5 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.2272181808998187d+00 b = 0.4864661535886647d+00 v = 0.4695720972568883d-02 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) n = n - 1 end subroutine subroutine ld0266 ( x , y , z , w , n ) real ( kind = dp ) :: x ( * ) real ( kind = dp ) :: y ( * ) real ( kind = dp ) :: z ( * ) real ( kind = dp ) :: w ( * ) integer :: n real ( kind = dp ) :: a , b , v ! !      LEBEDEV  266-POINT ANGULAR GRID ! ! !      THIS ROUTINE IS PART OF A SET OF ROUTINES THAT GENERATE !      LEBEDEV GRIDS [1-6] FOR INTEGRATION ON A SPHERE. THE ORIGINAL !      C-CODE [1] WAS KINDLY PROVIDED BY DR. DMITRI N. LAIKOV AND !      TRANSLATED INTO FORTRAN BY DR. CHRISTOPH VAN WUELLEN. !      THIS ROUTINE WAS TRANSLATED USING A C TO FORTRAN77 CONVERSION !      TOOL WRITTEN BY DR. CHRISTOPH VAN WUELLEN. ! !      USERS OF THIS CODE ARE ASKED TO INCLUDE REFERENCE [1] IN THEIR !      PUBLICATIONS, AND IN THE USER- AND PROGRAMMERS-MANUALS !      DESCRIBING THEIR CODES. ! !      THIS CODE WAS DISTRIBUTED THROUGH CCL (HTTP://WWW.CCL.NET/). ! !      [1] V.I. LEBEDEV, AND D.N. LAIKOV !          \"A QUADRATURE FORMULA FOR THE SPHERE OF THE 131ST !           ALGEBRAIC ORDER OF ACCURACY\" !          DOKLADY MATHEMATICS, VOL. 59, NO. 3, 1999, PP. 477-481. ! !      [2] V.I. LEBEDEV !          \"A QUADRATURE FORMULA FOR THE SPHERE OF 59TH ALGEBRAIC !           ORDER OF ACCURACY\" !          RUSSIAN ACAD. SCI. DOKL. MATH., VOL. 50, 1995, PP. 283-286. ! !      [3] V.I. LEBEDEV, AND A.L. SKOROKHODOV !          \"QUADRATURE FORMULAS OF ORDERS 41, 47, AND 53 FOR THE SPHERE\" !          RUSSIAN ACAD. SCI. DOKL. MATH., VOL. 45, 1992, PP. 587-592. ! !      [4] V.I. LEBEDEV !          \"SPHERICAL QUADRATURE FORMULAS EXACT TO ORDERS 25-29\" !          SIBERIAN MATHEMATICAL JOURNAL, VOL. 18, 1977, PP. 99-107. ! !      [5] V.I. LEBEDEV !          \"QUADRATURES ON A SPHERE\" !          COMPUTATIONAL MATHEMATICS AND MATHEMATICAL PHYSICS, VOL. 16, !          1976, PP. 10-24. ! !      [6] V.I. LEBEDEV !          \"VALUES OF THE NODES AND WEIGHTS OF NINTH TO SEVENTEENTH !           ORDER GAUSS-MARKOV QUADRATURE FORMULAE INVARIANT UNDER THE !           OCTAHEDRON GROUP WITH INVERSION\" !          COMPUTATIONAL MATHEMATICS AND MATHEMATICAL PHYSICS, VOL. 15, !          1975, PP. 44-51. ! n = 1 v = - 0.1313769127326952d-02 call gen_oh ( 1 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) v = - 0.2522728704859336d-02 call gen_oh ( 2 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) v = 0.4186853881700583d-02 call gen_oh ( 3 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.7039373391585475d+00 v = 0.5315167977810885d-02 call gen_oh ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.1012526248572414d+00 v = 0.4047142377086219d-02 call gen_oh ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.4647448726420539d+00 v = 0.4112482394406990d-02 call gen_oh ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.3277420654971629d+00 v = 0.3595584899758782d-02 call gen_oh ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.6620338663699974d+00 v = 0.4256131351428158d-02 call gen_oh ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.8506508083520399d+00 v = 0.4229582700647240d-02 call gen_oh ( 5 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.3233484542692899d+00 b = 0.1153112011009701d+00 v = 0.4080914225780505d-02 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.2314790158712601d+00 b = 0.5244939240922365d+00 v = 0.4071467593830964d-02 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) n = n - 1 end subroutine subroutine ld0302 ( x , y , z , w , n ) real ( kind = dp ) :: x ( * ) real ( kind = dp ) :: y ( * ) real ( kind = dp ) :: z ( * ) real ( kind = dp ) :: w ( * ) integer :: n real ( kind = dp ) :: a , b , v ! !      LEBEDEV  302-POINT ANGULAR GRID ! ! !      THIS ROUTINE IS PART OF A SET OF ROUTINES THAT GENERATE !      LEBEDEV GRIDS [1-6] FOR INTEGRATION ON A SPHERE. THE ORIGINAL !      C-CODE [1] WAS KINDLY PROVIDED BY DR. DMITRI N. LAIKOV AND !      TRANSLATED INTO FORTRAN BY DR. CHRISTOPH VAN WUELLEN. !      THIS ROUTINE WAS TRANSLATED USING A C TO FORTRAN77 CONVERSION !      TOOL WRITTEN BY DR. CHRISTOPH VAN WUELLEN. ! !      USERS OF THIS CODE ARE ASKED TO INCLUDE REFERENCE [1] IN THEIR !      PUBLICATIONS, AND IN THE USER- AND PROGRAMMERS-MANUALS !      DESCRIBING THEIR CODES. ! !      THIS CODE WAS DISTRIBUTED THROUGH CCL (HTTP://WWW.CCL.NET/). ! !      [1] V.I. LEBEDEV, AND D.N. LAIKOV !          \"A QUADRATURE FORMULA FOR THE SPHERE OF THE 131ST !           ALGEBRAIC ORDER OF ACCURACY\" !          DOKLADY MATHEMATICS, VOL. 59, NO. 3, 1999, PP. 477-481. ! !      [2] V.I. LEBEDEV !          \"A QUADRATURE FORMULA FOR THE SPHERE OF 59TH ALGEBRAIC !           ORDER OF ACCURACY\" !          RUSSIAN ACAD. SCI. DOKL. MATH., VOL. 50, 1995, PP. 283-286. ! !      [3] V.I. LEBEDEV, AND A.L. SKOROKHODOV !          \"QUADRATURE FORMULAS OF ORDERS 41, 47, AND 53 FOR THE SPHERE\" !          RUSSIAN ACAD. SCI. DOKL. MATH., VOL. 45, 1992, PP. 587-592. ! !      [4] V.I. LEBEDEV !          \"SPHERICAL QUADRATURE FORMULAS EXACT TO ORDERS 25-29\" !          SIBERIAN MATHEMATICAL JOURNAL, VOL. 18, 1977, PP. 99-107. ! !      [5] V.I. LEBEDEV !          \"QUADRATURES ON A SPHERE\" !          COMPUTATIONAL MATHEMATICS AND MATHEMATICAL PHYSICS, VOL. 16, !          1976, PP. 10-24. ! !      [6] V.I. LEBEDEV !          \"VALUES OF THE NODES AND WEIGHTS OF NINTH TO SEVENTEENTH !           ORDER GAUSS-MARKOV QUADRATURE FORMULAE INVARIANT UNDER THE !           OCTAHEDRON GROUP WITH INVERSION\" !          COMPUTATIONAL MATHEMATICS AND MATHEMATICAL PHYSICS, VOL. 15, !          1975, PP. 44-51. ! n = 1 v = 0.8545911725128148d-03 call gen_oh ( 1 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) v = 0.3599119285025571d-02 call gen_oh ( 3 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.3515640345570105d+00 v = 0.3449788424305883d-02 call gen_oh ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.6566329410219612d+00 v = 0.3604822601419882d-02 call gen_oh ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.4729054132581005d+00 v = 0.3576729661743367d-02 call gen_oh ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.9618308522614784d-01 v = 0.2352101413689164d-02 call gen_oh ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.2219645236294178d+00 v = 0.3108953122413675d-02 call gen_oh ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.7011766416089545d+00 v = 0.3650045807677255d-02 call gen_oh ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.2644152887060663d+00 v = 0.2982344963171804d-02 call gen_oh ( 5 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.5718955891878961d+00 v = 0.3600820932216460d-02 call gen_oh ( 5 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.2510034751770465d+00 b = 0.8000727494073952d+00 v = 0.3571540554273387d-02 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.1233548532583327d+00 b = 0.4127724083168531d+00 v = 0.3392312205006170d-02 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) n = n - 1 end subroutine subroutine ld0350 ( x , y , z , w , n ) real ( kind = dp ) :: x ( * ) real ( kind = dp ) :: y ( * ) real ( kind = dp ) :: z ( * ) real ( kind = dp ) :: w ( * ) integer :: n real ( kind = dp ) :: a , b , v ! !      LEBEDEV  350-POINT ANGULAR GRID ! ! !      THIS ROUTINE IS PART OF A SET OF ROUTINES THAT GENERATE !      LEBEDEV GRIDS [1-6] FOR INTEGRATION ON A SPHERE. THE ORIGINAL !      C-CODE [1] WAS KINDLY PROVIDED BY DR. DMITRI N. LAIKOV AND !      TRANSLATED INTO FORTRAN BY DR. CHRISTOPH VAN WUELLEN. !      THIS ROUTINE WAS TRANSLATED USING A C TO FORTRAN77 CONVERSION !      TOOL WRITTEN BY DR. CHRISTOPH VAN WUELLEN. ! !      USERS OF THIS CODE ARE ASKED TO INCLUDE REFERENCE [1] IN THEIR !      PUBLICATIONS, AND IN THE USER- AND PROGRAMMERS-MANUALS !      DESCRIBING THEIR CODES. ! !      THIS CODE WAS DISTRIBUTED THROUGH CCL (HTTP://WWW.CCL.NET/). ! !      [1] V.I. LEBEDEV, AND D.N. LAIKOV !          \"A QUADRATURE FORMULA FOR THE SPHERE OF THE 131ST !           ALGEBRAIC ORDER OF ACCURACY\" !          DOKLADY MATHEMATICS, VOL. 59, NO. 3, 1999, PP. 477-481. ! !      [2] V.I. LEBEDEV !          \"A QUADRATURE FORMULA FOR THE SPHERE OF 59TH ALGEBRAIC !           ORDER OF ACCURACY\" !          RUSSIAN ACAD. SCI. DOKL. MATH., VOL. 50, 1995, PP. 283-286. ! !      [3] V.I. LEBEDEV, AND A.L. SKOROKHODOV !          \"QUADRATURE FORMULAS OF ORDERS 41, 47, AND 53 FOR THE SPHERE\" !          RUSSIAN ACAD. SCI. DOKL. MATH., VOL. 45, 1992, PP. 587-592. ! !      [4] V.I. LEBEDEV !          \"SPHERICAL QUADRATURE FORMULAS EXACT TO ORDERS 25-29\" !          SIBERIAN MATHEMATICAL JOURNAL, VOL. 18, 1977, PP. 99-107. ! !      [5] V.I. LEBEDEV !          \"QUADRATURES ON A SPHERE\" !          COMPUTATIONAL MATHEMATICS AND MATHEMATICAL PHYSICS, VOL. 16, !          1976, PP. 10-24. ! !      [6] V.I. LEBEDEV !          \"VALUES OF THE NODES AND WEIGHTS OF NINTH TO SEVENTEENTH !           ORDER GAUSS-MARKOV QUADRATURE FORMULAE INVARIANT UNDER THE !           OCTAHEDRON GROUP WITH INVERSION\" !          COMPUTATIONAL MATHEMATICS AND MATHEMATICAL PHYSICS, VOL. 15, !          1975, PP. 44-51. ! n = 1 v = 0.3006796749453936d-02 call gen_oh ( 1 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) v = 0.3050627745650771d-02 call gen_oh ( 3 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.7068965463912316d+00 v = 0.1621104600288991d-02 call gen_oh ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.4794682625712025d+00 v = 0.3005701484901752d-02 call gen_oh ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.1927533154878019d+00 v = 0.2990992529653774d-02 call gen_oh ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.6930357961327123d+00 v = 0.2982170644107595d-02 call gen_oh ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.3608302115520091d+00 v = 0.2721564237310992d-02 call gen_oh ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.6498486161496169d+00 v = 0.3033513795811141d-02 call gen_oh ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.1932945013230339d+00 v = 0.3007949555218533d-02 call gen_oh ( 5 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.3800494919899303d+00 v = 0.2881964603055307d-02 call gen_oh ( 5 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.2899558825499574d+00 b = 0.7934537856582316d+00 v = 0.2958357626535696d-02 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.9684121455103957d-01 b = 0.8280801506686862d+00 v = 0.3036020026407088d-02 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.1833434647041659d+00 b = 0.9074658265305127d+00 v = 0.2832187403926303d-02 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) n = n - 1 end subroutine subroutine ld0434 ( x , y , z , w , n ) real ( kind = dp ) :: x ( * ) real ( kind = dp ) :: y ( * ) real ( kind = dp ) :: z ( * ) real ( kind = dp ) :: w ( * ) integer :: n real ( kind = dp ) :: a , b , v ! !      LEBEDEV  434-POINT ANGULAR GRID ! ! !      THIS ROUTINE IS PART OF A SET OF ROUTINES THAT GENERATE !      LEBEDEV GRIDS [1-6] FOR INTEGRATION ON A SPHERE. THE ORIGINAL !      C-CODE [1] WAS KINDLY PROVIDED BY DR. DMITRI N. LAIKOV AND !      TRANSLATED INTO FORTRAN BY DR. CHRISTOPH VAN WUELLEN. !      THIS ROUTINE WAS TRANSLATED USING A C TO FORTRAN77 CONVERSION !      TOOL WRITTEN BY DR. CHRISTOPH VAN WUELLEN. ! !      USERS OF THIS CODE ARE ASKED TO INCLUDE REFERENCE [1] IN THEIR !      PUBLICATIONS, AND IN THE USER- AND PROGRAMMERS-MANUALS !      DESCRIBING THEIR CODES. ! !      THIS CODE WAS DISTRIBUTED THROUGH CCL (HTTP://WWW.CCL.NET/). ! !      [1] V.I. LEBEDEV, AND D.N. LAIKOV !          \"A QUADRATURE FORMULA FOR THE SPHERE OF THE 131ST !           ALGEBRAIC ORDER OF ACCURACY\" !          DOKLADY MATHEMATICS, VOL. 59, NO. 3, 1999, PP. 477-481. ! !      [2] V.I. LEBEDEV !          \"A QUADRATURE FORMULA FOR THE SPHERE OF 59TH ALGEBRAIC !           ORDER OF ACCURACY\" !          RUSSIAN ACAD. SCI. DOKL. MATH., VOL. 50, 1995, PP. 283-286. ! !      [3] V.I. LEBEDEV, AND A.L. SKOROKHODOV !          \"QUADRATURE FORMULAS OF ORDERS 41, 47, AND 53 FOR THE SPHERE\" !          RUSSIAN ACAD. SCI. DOKL. MATH., VOL. 45, 1992, PP. 587-592. ! !      [4] V.I. LEBEDEV !          \"SPHERICAL QUADRATURE FORMULAS EXACT TO ORDERS 25-29\" !          SIBERIAN MATHEMATICAL JOURNAL, VOL. 18, 1977, PP. 99-107. ! !      [5] V.I. LEBEDEV !          \"QUADRATURES ON A SPHERE\" !          COMPUTATIONAL MATHEMATICS AND MATHEMATICAL PHYSICS, VOL. 16, !          1976, PP. 10-24. ! !      [6] V.I. LEBEDEV !          \"VALUES OF THE NODES AND WEIGHTS OF NINTH TO SEVENTEENTH !           ORDER GAUSS-MARKOV QUADRATURE FORMULAE INVARIANT UNDER THE !           OCTAHEDRON GROUP WITH INVERSION\" !          COMPUTATIONAL MATHEMATICS AND MATHEMATICAL PHYSICS, VOL. 15, !          1975, PP. 44-51. ! n = 1 v = 0.5265897968224436d-03 call gen_oh ( 1 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) v = 0.2548219972002607d-02 call gen_oh ( 2 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) v = 0.2512317418927307d-02 call gen_oh ( 3 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.6909346307509111d+00 v = 0.2530403801186355d-02 call gen_oh ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.1774836054609158d+00 v = 0.2014279020918528d-02 call gen_oh ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.4914342637784746d+00 v = 0.2501725168402936d-02 call gen_oh ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.6456664707424256d+00 v = 0.2513267174597564d-02 call gen_oh ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.2861289010307638d+00 v = 0.2302694782227416d-02 call gen_oh ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.7568084367178018d-01 v = 0.1462495621594614d-02 call gen_oh ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.3927259763368002d+00 v = 0.2445373437312980d-02 call gen_oh ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.8818132877794288d+00 v = 0.2417442375638981d-02 call gen_oh ( 5 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.9776428111182649d+00 v = 0.1910951282179532d-02 call gen_oh ( 5 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.2054823696403044d+00 b = 0.8689460322872412d+00 v = 0.2416930044324775d-02 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.5905157048925271d+00 b = 0.7999278543857286d+00 v = 0.2512236854563495d-02 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.5550152361076807d+00 b = 0.7717462626915901d+00 v = 0.2496644054553086d-02 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.9371809858553722d+00 b = 0.3344363145343455d+00 v = 0.2236607760437849d-02 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) n = n - 1 end subroutine subroutine ld0590 ( x , y , z , w , n ) real ( kind = dp ) :: x ( * ) real ( kind = dp ) :: y ( * ) real ( kind = dp ) :: z ( * ) real ( kind = dp ) :: w ( * ) integer :: n real ( kind = dp ) :: a , b , v ! !      LEBEDEV  590-POINT ANGULAR GRID ! ! !      THIS ROUTINE IS PART OF A SET OF ROUTINES THAT GENERATE !      LEBEDEV GRIDS [1-6] FOR INTEGRATION ON A SPHERE. THE ORIGINAL !      C-CODE [1] WAS KINDLY PROVIDED BY DR. DMITRI N. LAIKOV AND !      TRANSLATED INTO FORTRAN BY DR. CHRISTOPH VAN WUELLEN. !      THIS ROUTINE WAS TRANSLATED USING A C TO FORTRAN77 CONVERSION !      TOOL WRITTEN BY DR. CHRISTOPH VAN WUELLEN. ! !      USERS OF THIS CODE ARE ASKED TO INCLUDE REFERENCE [1] IN THEIR !      PUBLICATIONS, AND IN THE USER- AND PROGRAMMERS-MANUALS !      DESCRIBING THEIR CODES. ! !      THIS CODE WAS DISTRIBUTED THROUGH CCL (HTTP://WWW.CCL.NET/). ! !      [1] V.I. LEBEDEV, AND D.N. LAIKOV !          \"A QUADRATURE FORMULA FOR THE SPHERE OF THE 131ST !           ALGEBRAIC ORDER OF ACCURACY\" !          DOKLADY MATHEMATICS, VOL. 59, NO. 3, 1999, PP. 477-481. ! !      [2] V.I. LEBEDEV !          \"A QUADRATURE FORMULA FOR THE SPHERE OF 59TH ALGEBRAIC !           ORDER OF ACCURACY\" !          RUSSIAN ACAD. SCI. DOKL. MATH., VOL. 50, 1995, PP. 283-286. ! !      [3] V.I. LEBEDEV, AND A.L. SKOROKHODOV !          \"QUADRATURE FORMULAS OF ORDERS 41, 47, AND 53 FOR THE SPHERE\" !          RUSSIAN ACAD. SCI. DOKL. MATH., VOL. 45, 1992, PP. 587-592. ! !      [4] V.I. LEBEDEV !          \"SPHERICAL QUADRATURE FORMULAS EXACT TO ORDERS 25-29\" !          SIBERIAN MATHEMATICAL JOURNAL, VOL. 18, 1977, PP. 99-107. ! !      [5] V.I. LEBEDEV !          \"QUADRATURES ON A SPHERE\" !          COMPUTATIONAL MATHEMATICS AND MATHEMATICAL PHYSICS, VOL. 16, !          1976, PP. 10-24. ! !      [6] V.I. LEBEDEV !          \"VALUES OF THE NODES AND WEIGHTS OF NINTH TO SEVENTEENTH !           ORDER GAUSS-MARKOV QUADRATURE FORMULAE INVARIANT UNDER THE !           OCTAHEDRON GROUP WITH INVERSION\" !          COMPUTATIONAL MATHEMATICS AND MATHEMATICAL PHYSICS, VOL. 15, !          1975, PP. 44-51. ! n = 1 v = 0.3095121295306187d-03 call gen_oh ( 1 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) v = 0.1852379698597489d-02 call gen_oh ( 3 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.7040954938227469d+00 v = 0.1871790639277744d-02 call gen_oh ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.6807744066455243d+00 v = 0.1858812585438317d-02 call gen_oh ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.6372546939258752d+00 v = 0.1852028828296213d-02 call gen_oh ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.5044419707800358d+00 v = 0.1846715956151242d-02 call gen_oh ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.4215761784010967d+00 v = 0.1818471778162769d-02 call gen_oh ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.3317920736472123d+00 v = 0.1749564657281154d-02 call gen_oh ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.2384736701421887d+00 v = 0.1617210647254411d-02 call gen_oh ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.1459036449157763d+00 v = 0.1384737234851692d-02 call gen_oh ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.6095034115507196d-01 v = 0.9764331165051050d-03 call gen_oh ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.6116843442009876d+00 v = 0.1857161196774078d-02 call gen_oh ( 5 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.3964755348199858d+00 v = 0.1705153996395864d-02 call gen_oh ( 5 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.1724782009907724d+00 v = 0.1300321685886048d-02 call gen_oh ( 5 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.5610263808622060d+00 b = 0.3518280927733519d+00 v = 0.1842866472905286d-02 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.4742392842551980d+00 b = 0.2634716655937950d+00 v = 0.1802658934377451d-02 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.5984126497885380d+00 b = 0.1816640840360209d+00 v = 0.1849830560443660d-02 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.3791035407695563d+00 b = 0.1720795225656878d+00 v = 0.1713904507106709d-02 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.2778673190586244d+00 b = 0.8213021581932511d-01 v = 0.1555213603396808d-02 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.5033564271075117d+00 b = 0.8999205842074875d-01 v = 0.1802239128008525d-02 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) n = n - 1 end subroutine subroutine ld0770 ( x , y , z , w , n ) real ( kind = dp ) :: x ( * ) real ( kind = dp ) :: y ( * ) real ( kind = dp ) :: z ( * ) real ( kind = dp ) :: w ( * ) integer :: n real ( kind = dp ) :: a , b , v ! !      LEBEDEV  770-POINT ANGULAR GRID ! ! !      THIS ROUTINE IS PART OF A SET OF ROUTINES THAT GENERATE !      LEBEDEV GRIDS [1-6] FOR INTEGRATION ON A SPHERE. THE ORIGINAL !      C-CODE [1] WAS KINDLY PROVIDED BY DR. DMITRI N. LAIKOV AND !      TRANSLATED INTO FORTRAN BY DR. CHRISTOPH VAN WUELLEN. !      THIS ROUTINE WAS TRANSLATED USING A C TO FORTRAN77 CONVERSION !      TOOL WRITTEN BY DR. CHRISTOPH VAN WUELLEN. ! !      USERS OF THIS CODE ARE ASKED TO INCLUDE REFERENCE [1] IN THEIR !      PUBLICATIONS, AND IN THE USER- AND PROGRAMMERS-MANUALS !      DESCRIBING THEIR CODES. ! !      THIS CODE WAS DISTRIBUTED THROUGH CCL (HTTP://WWW.CCL.NET/). ! !      [1] V.I. LEBEDEV, AND D.N. LAIKOV !          \"A QUADRATURE FORMULA FOR THE SPHERE OF THE 131ST !           ALGEBRAIC ORDER OF ACCURACY\" !          DOKLADY MATHEMATICS, VOL. 59, NO. 3, 1999, PP. 477-481. ! !      [2] V.I. LEBEDEV !          \"A QUADRATURE FORMULA FOR THE SPHERE OF 59TH ALGEBRAIC !           ORDER OF ACCURACY\" !          RUSSIAN ACAD. SCI. DOKL. MATH., VOL. 50, 1995, PP. 283-286. ! !      [3] V.I. LEBEDEV, AND A.L. SKOROKHODOV !          \"QUADRATURE FORMULAS OF ORDERS 41, 47, AND 53 FOR THE SPHERE\" !          RUSSIAN ACAD. SCI. DOKL. MATH., VOL. 45, 1992, PP. 587-592. ! !      [4] V.I. LEBEDEV !          \"SPHERICAL QUADRATURE FORMULAS EXACT TO ORDERS 25-29\" !          SIBERIAN MATHEMATICAL JOURNAL, VOL. 18, 1977, PP. 99-107. ! !      [5] V.I. LEBEDEV !          \"QUADRATURES ON A SPHERE\" !          COMPUTATIONAL MATHEMATICS AND MATHEMATICAL PHYSICS, VOL. 16, !          1976, PP. 10-24. ! !      [6] V.I. LEBEDEV !          \"VALUES OF THE NODES AND WEIGHTS OF NINTH TO SEVENTEENTH !           ORDER GAUSS-MARKOV QUADRATURE FORMULAE INVARIANT UNDER THE !           OCTAHEDRON GROUP WITH INVERSION\" !          COMPUTATIONAL MATHEMATICS AND MATHEMATICAL PHYSICS, VOL. 15, !          1975, PP. 44-51. ! n = 1 v = 0.2192942088181184d-03 call gen_oh ( 1 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) v = 0.1436433617319080d-02 call gen_oh ( 2 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) v = 0.1421940344335877d-02 call gen_oh ( 3 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.5087204410502360d-01 v = 0.6798123511050502d-03 call gen_oh ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.1228198790178831d+00 v = 0.9913184235294912d-03 call gen_oh ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.2026890814408786d+00 v = 0.1180207833238949d-02 call gen_oh ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.2847745156464294d+00 v = 0.1296599602080921d-02 call gen_oh ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.3656719078978026d+00 v = 0.1365871427428316d-02 call gen_oh ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.4428264886713469d+00 v = 0.1402988604775325d-02 call gen_oh ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.5140619627249735d+00 v = 0.1418645563595609d-02 call gen_oh ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.6306401219166803d+00 v = 0.1421376741851662d-02 call gen_oh ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.6716883332022612d+00 v = 0.1423996475490962d-02 call gen_oh ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.6979792685336881d+00 v = 0.1431554042178567d-02 call gen_oh ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.1446865674195309d+00 v = 0.9254401499865368d-03 call gen_oh ( 5 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.3390263475411216d+00 v = 0.1250239995053509d-02 call gen_oh ( 5 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.5335804651263506d+00 v = 0.1394365843329230d-02 call gen_oh ( 5 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.6944024393349413d-01 b = 0.2355187894242326d+00 v = 0.1127089094671749d-02 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.2269004109529460d+00 b = 0.4102182474045730d+00 v = 0.1345753760910670d-02 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.8025574607775339d-01 b = 0.6214302417481605d+00 v = 0.1424957283316783d-02 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.1467999527896572d+00 b = 0.3245284345717394d+00 v = 0.1261523341237750d-02 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.1571507769824727d+00 b = 0.5224482189696630d+00 v = 0.1392547106052696d-02 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.2365702993157246d+00 b = 0.6017546634089558d+00 v = 0.1418761677877656d-02 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.7714815866765732d-01 b = 0.4346575516141163d+00 v = 0.1338366684479554d-02 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.3062936666210730d+00 b = 0.4908826589037616d+00 v = 0.1393700862676131d-02 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.3822477379524787d+00 b = 0.5648768149099500d+00 v = 0.1415914757466932d-02 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) n = n - 1 end subroutine subroutine ld0974 ( x , y , z , w , n ) real ( kind = dp ) :: x ( * ) real ( kind = dp ) :: y ( * ) real ( kind = dp ) :: z ( * ) real ( kind = dp ) :: w ( * ) integer :: n real ( kind = dp ) :: a , b , v ! !      LEBEDEV  974-POINT ANGULAR GRID ! ! !      THIS ROUTINE IS PART OF A SET OF ROUTINES THAT GENERATE !      LEBEDEV GRIDS [1-6] FOR INTEGRATION ON A SPHERE. THE ORIGINAL !      C-CODE [1] WAS KINDLY PROVIDED BY DR. DMITRI N. LAIKOV AND !      TRANSLATED INTO FORTRAN BY DR. CHRISTOPH VAN WUELLEN. !      THIS ROUTINE WAS TRANSLATED USING A C TO FORTRAN77 CONVERSION !      TOOL WRITTEN BY DR. CHRISTOPH VAN WUELLEN. ! !      USERS OF THIS CODE ARE ASKED TO INCLUDE REFERENCE [1] IN THEIR !      PUBLICATIONS, AND IN THE USER- AND PROGRAMMERS-MANUALS !      DESCRIBING THEIR CODES. ! !      THIS CODE WAS DISTRIBUTED THROUGH CCL (HTTP://WWW.CCL.NET/). ! !      [1] V.I. LEBEDEV, AND D.N. LAIKOV !          \"A QUADRATURE FORMULA FOR THE SPHERE OF THE 131ST !           ALGEBRAIC ORDER OF ACCURACY\" !          DOKLADY MATHEMATICS, VOL. 59, NO. 3, 1999, PP. 477-481. ! !      [2] V.I. LEBEDEV !          \"A QUADRATURE FORMULA FOR THE SPHERE OF 59TH ALGEBRAIC !           ORDER OF ACCURACY\" !          RUSSIAN ACAD. SCI. DOKL. MATH., VOL. 50, 1995, PP. 283-286. ! !      [3] V.I. LEBEDEV, AND A.L. SKOROKHODOV !          \"QUADRATURE FORMULAS OF ORDERS 41, 47, AND 53 FOR THE SPHERE\" !          RUSSIAN ACAD. SCI. DOKL. MATH., VOL. 45, 1992, PP. 587-592. ! !      [4] V.I. LEBEDEV !          \"SPHERICAL QUADRATURE FORMULAS EXACT TO ORDERS 25-29\" !          SIBERIAN MATHEMATICAL JOURNAL, VOL. 18, 1977, PP. 99-107. ! !      [5] V.I. LEBEDEV !          \"QUADRATURES ON A SPHERE\" !          COMPUTATIONAL MATHEMATICS AND MATHEMATICAL PHYSICS, VOL. 16, !          1976, PP. 10-24. ! !      [6] V.I. LEBEDEV !          \"VALUES OF THE NODES AND WEIGHTS OF NINTH TO SEVENTEENTH !           ORDER GAUSS-MARKOV QUADRATURE FORMULAE INVARIANT UNDER THE !           OCTAHEDRON GROUP WITH INVERSION\" !          COMPUTATIONAL MATHEMATICS AND MATHEMATICAL PHYSICS, VOL. 15, !          1975, PP. 44-51. ! n = 1 v = 0.1438294190527431d-03 call gen_oh ( 1 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) v = 0.1125772288287004d-02 call gen_oh ( 3 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.4292963545341347d-01 v = 0.4948029341949241d-03 call gen_oh ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.1051426854086404d+00 v = 0.7357990109125470d-03 call gen_oh ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.1750024867623087d+00 v = 0.8889132771304384d-03 call gen_oh ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.2477653379650257d+00 v = 0.9888347838921435d-03 call gen_oh ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.3206567123955957d+00 v = 0.1053299681709471d-02 call gen_oh ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.3916520749849983d+00 v = 0.1092778807014578d-02 call gen_oh ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.4590825874187624d+00 v = 0.1114389394063227d-02 call gen_oh ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.5214563888415861d+00 v = 0.1123724788051555d-02 call gen_oh ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.6253170244654199d+00 v = 0.1125239325243814d-02 call gen_oh ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.6637926744523170d+00 v = 0.1126153271815905d-02 call gen_oh ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.6910410398498301d+00 v = 0.1130286931123841d-02 call gen_oh ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.7052907007457760d+00 v = 0.1134986534363955d-02 call gen_oh ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.1236686762657990d+00 v = 0.6823367927109931d-03 call gen_oh ( 5 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.2940777114468387d+00 v = 0.9454158160447096d-03 call gen_oh ( 5 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.4697753849207649d+00 v = 0.1074429975385679d-02 call gen_oh ( 5 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.6334563241139567d+00 v = 0.1129300086569132d-02 call gen_oh ( 5 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.5974048614181342d-01 b = 0.2029128752777523d+00 v = 0.8436884500901954d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.1375760408473636d+00 b = 0.4602621942484054d+00 v = 0.1075255720448885d-02 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.3391016526336286d+00 b = 0.5030673999662036d+00 v = 0.1108577236864462d-02 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.1271675191439820d+00 b = 0.2817606422442134d+00 v = 0.9566475323783357d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.2693120740413512d+00 b = 0.4331561291720157d+00 v = 0.1080663250717391d-02 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.1419786452601918d+00 b = 0.6256167358580814d+00 v = 0.1126797131196295d-02 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.6709284600738255d-01 b = 0.3798395216859157d+00 v = 0.1022568715358061d-02 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.7057738183256172d-01 b = 0.5517505421423520d+00 v = 0.1108960267713108d-02 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.2783888477882155d+00 b = 0.6029619156159187d+00 v = 0.1122790653435766d-02 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.1979578938917407d+00 b = 0.3589606329589096d+00 v = 0.1032401847117460d-02 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.2087307061103274d+00 b = 0.5348666438135476d+00 v = 0.1107249382283854d-02 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.4055122137872836d+00 b = 0.5674997546074373d+00 v = 0.1121780048519972d-02 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) n = n - 1 end subroutine subroutine ld1202 ( x , y , z , w , n ) real ( kind = dp ) :: x ( * ) real ( kind = dp ) :: y ( * ) real ( kind = dp ) :: z ( * ) real ( kind = dp ) :: w ( * ) integer :: n real ( kind = dp ) :: a , b , v ! !      LEBEDEV 1202-POINT ANGULAR GRID ! ! !      THIS ROUTINE IS PART OF A SET OF ROUTINES THAT GENERATE !      LEBEDEV GRIDS [1-6] FOR INTEGRATION ON A SPHERE. THE ORIGINAL !      C-CODE [1] WAS KINDLY PROVIDED BY DR. DMITRI N. LAIKOV AND !      TRANSLATED INTO FORTRAN BY DR. CHRISTOPH VAN WUELLEN. !      THIS ROUTINE WAS TRANSLATED USING A C TO FORTRAN77 CONVERSION !      TOOL WRITTEN BY DR. CHRISTOPH VAN WUELLEN. ! !      USERS OF THIS CODE ARE ASKED TO INCLUDE REFERENCE [1] IN THEIR !      PUBLICATIONS, AND IN THE USER- AND PROGRAMMERS-MANUALS !      DESCRIBING THEIR CODES. ! !      THIS CODE WAS DISTRIBUTED THROUGH CCL (HTTP://WWW.CCL.NET/). ! !      [1] V.I. LEBEDEV, AND D.N. LAIKOV !          \"A QUADRATURE FORMULA FOR THE SPHERE OF THE 131ST !           ALGEBRAIC ORDER OF ACCURACY\" !          DOKLADY MATHEMATICS, VOL. 59, NO. 3, 1999, PP. 477-481. ! !      [2] V.I. LEBEDEV !          \"A QUADRATURE FORMULA FOR THE SPHERE OF 59TH ALGEBRAIC !           ORDER OF ACCURACY\" !          RUSSIAN ACAD. SCI. DOKL. MATH., VOL. 50, 1995, PP. 283-286. ! !      [3] V.I. LEBEDEV, AND A.L. SKOROKHODOV !          \"QUADRATURE FORMULAS OF ORDERS 41, 47, AND 53 FOR THE SPHERE\" !          RUSSIAN ACAD. SCI. DOKL. MATH., VOL. 45, 1992, PP. 587-592. ! !      [4] V.I. LEBEDEV !          \"SPHERICAL QUADRATURE FORMULAS EXACT TO ORDERS 25-29\" !          SIBERIAN MATHEMATICAL JOURNAL, VOL. 18, 1977, PP. 99-107. ! !      [5] V.I. LEBEDEV !          \"QUADRATURES ON A SPHERE\" !          COMPUTATIONAL MATHEMATICS AND MATHEMATICAL PHYSICS, VOL. 16, !          1976, PP. 10-24. ! !      [6] V.I. LEBEDEV !          \"VALUES OF THE NODES AND WEIGHTS OF NINTH TO SEVENTEENTH !           ORDER GAUSS-MARKOV QUADRATURE FORMULAE INVARIANT UNDER THE !           OCTAHEDRON GROUP WITH INVERSION\" !          COMPUTATIONAL MATHEMATICS AND MATHEMATICAL PHYSICS, VOL. 15, !          1975, PP. 44-51. ! n = 1 v = 0.1105189233267572d-03 call gen_oh ( 1 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) v = 0.9205232738090741d-03 call gen_oh ( 2 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) v = 0.9133159786443561d-03 call gen_oh ( 3 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.3712636449657089d-01 v = 0.3690421898017899d-03 call gen_oh ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.9140060412262223d-01 v = 0.5603990928680660d-03 call gen_oh ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.1531077852469906d+00 v = 0.6865297629282609d-03 call gen_oh ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.2180928891660612d+00 v = 0.7720338551145630d-03 call gen_oh ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.2839874532200175d+00 v = 0.8301545958894795d-03 call gen_oh ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.3491177600963764d+00 v = 0.8686692550179628d-03 call gen_oh ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.4121431461444309d+00 v = 0.8927076285846890d-03 call gen_oh ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.4718993627149127d+00 v = 0.9060820238568219d-03 call gen_oh ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.5273145452842337d+00 v = 0.9119777254940867d-03 call gen_oh ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.6209475332444019d+00 v = 0.9128720138604181d-03 call gen_oh ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.6569722711857291d+00 v = 0.9130714935691735d-03 call gen_oh ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.6841788309070143d+00 v = 0.9152873784554116d-03 call gen_oh ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.7012604330123631d+00 v = 0.9187436274321654d-03 call gen_oh ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.1072382215478166d+00 v = 0.5176977312965694d-03 call gen_oh ( 5 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.2582068959496968d+00 v = 0.7331143682101417d-03 call gen_oh ( 5 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.4172752955306717d+00 v = 0.8463232836379928d-03 call gen_oh ( 5 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.5700366911792503d+00 v = 0.9031122694253992d-03 call gen_oh ( 5 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.9827986018263947d+00 b = 0.1771774022615325d+00 v = 0.6485778453163257d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.9624249230326228d+00 b = 0.2475716463426288d+00 v = 0.7435030910982369d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.9402007994128811d+00 b = 0.3354616289066489d+00 v = 0.7998527891839054d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.9320822040143202d+00 b = 0.3173615246611977d+00 v = 0.8101731497468018d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.9043674199393299d+00 b = 0.4090268427085357d+00 v = 0.8483389574594331d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.8912407560074747d+00 b = 0.3854291150669224d+00 v = 0.8556299257311812d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.8676435628462708d+00 b = 0.4932221184851285d+00 v = 0.8803208679738260d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.8581979986041619d+00 b = 0.4785320675922435d+00 v = 0.8811048182425720d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.8396753624049856d+00 b = 0.4507422593157064d+00 v = 0.8850282341265444d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.8165288564022188d+00 b = 0.5632123020762100d+00 v = 0.9021342299040653d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.8015469370783529d+00 b = 0.5434303569693900d+00 v = 0.9010091677105086d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.7773563069070351d+00 b = 0.5123518486419871d+00 v = 0.9022692938426915d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.7661621213900394d+00 b = 0.6394279634749102d+00 v = 0.9158016174693465d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.7553584143533510d+00 b = 0.6269805509024392d+00 v = 0.9131578003189435d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.7344305757559503d+00 b = 0.6031161693096310d+00 v = 0.9107813579482705d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.7043837184021765d+00 b = 0.5693702498468441d+00 v = 0.9105760258970126d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) n = n - 1 end subroutine subroutine ld1454 ( x , y , z , w , n ) real ( kind = dp ) :: x ( * ) real ( kind = dp ) :: y ( * ) real ( kind = dp ) :: z ( * ) real ( kind = dp ) :: w ( * ) integer :: n real ( kind = dp ) :: a , b , v ! !      LEBEDEV 1454-POINT ANGULAR GRID ! ! !      THIS ROUTINE IS PART OF A SET OF ROUTINES THAT GENERATE !      LEBEDEV GRIDS [1-6] FOR INTEGRATION ON A SPHERE. THE ORIGINAL !      C-CODE [1] WAS KINDLY PROVIDED BY DR. DMITRI N. LAIKOV AND !      TRANSLATED INTO FORTRAN BY DR. CHRISTOPH VAN WUELLEN. !      THIS ROUTINE WAS TRANSLATED USING A C TO FORTRAN77 CONVERSION !      TOOL WRITTEN BY DR. CHRISTOPH VAN WUELLEN. ! !      USERS OF THIS CODE ARE ASKED TO INCLUDE REFERENCE [1] IN THEIR !      PUBLICATIONS, AND IN THE USER- AND PROGRAMMERS-MANUALS !      DESCRIBING THEIR CODES. ! !      THIS CODE WAS DISTRIBUTED THROUGH CCL (HTTP://WWW.CCL.NET/). ! !      [1] V.I. LEBEDEV, AND D.N. LAIKOV !          \"A QUADRATURE FORMULA FOR THE SPHERE OF THE 131ST !           ALGEBRAIC ORDER OF ACCURACY\" !          DOKLADY MATHEMATICS, VOL. 59, NO. 3, 1999, PP. 477-481. ! !      [2] V.I. LEBEDEV !          \"A QUADRATURE FORMULA FOR THE SPHERE OF 59TH ALGEBRAIC !           ORDER OF ACCURACY\" !          RUSSIAN ACAD. SCI. DOKL. MATH., VOL. 50, 1995, PP. 283-286. ! !      [3] V.I. LEBEDEV, AND A.L. SKOROKHODOV !          \"QUADRATURE FORMULAS OF ORDERS 41, 47, AND 53 FOR THE SPHERE\" !          RUSSIAN ACAD. SCI. DOKL. MATH., VOL. 45, 1992, PP. 587-592. ! !      [4] V.I. LEBEDEV !          \"SPHERICAL QUADRATURE FORMULAS EXACT TO ORDERS 25-29\" !          SIBERIAN MATHEMATICAL JOURNAL, VOL. 18, 1977, PP. 99-107. ! !      [5] V.I. LEBEDEV !          \"QUADRATURES ON A SPHERE\" !          COMPUTATIONAL MATHEMATICS AND MATHEMATICAL PHYSICS, VOL. 16, !          1976, PP. 10-24. ! !      [6] V.I. LEBEDEV !          \"VALUES OF THE NODES AND WEIGHTS OF NINTH TO SEVENTEENTH !           ORDER GAUSS-MARKOV QUADRATURE FORMULAE INVARIANT UNDER THE !           OCTAHEDRON GROUP WITH INVERSION\" !          COMPUTATIONAL MATHEMATICS AND MATHEMATICAL PHYSICS, VOL. 15, !          1975, PP. 44-51. ! n = 1 v = 0.7777160743261247d-04 call gen_oh ( 1 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) v = 0.7557646413004701d-03 call gen_oh ( 3 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.3229290663413854d-01 v = 0.2841633806090617d-03 call gen_oh ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.8036733271462222d-01 v = 0.4374419127053555d-03 call gen_oh ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.1354289960531653d+00 v = 0.5417174740872172d-03 call gen_oh ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.1938963861114426d+00 v = 0.6148000891358593d-03 call gen_oh ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.2537343715011275d+00 v = 0.6664394485800705d-03 call gen_oh ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.3135251434752570d+00 v = 0.7025039356923220d-03 call gen_oh ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.3721558339375338d+00 v = 0.7268511789249627d-03 call gen_oh ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.4286809575195696d+00 v = 0.7422637534208629d-03 call gen_oh ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.4822510128282994d+00 v = 0.7509545035841214d-03 call gen_oh ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.5320679333566263d+00 v = 0.7548535057718401d-03 call gen_oh ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.6172998195394274d+00 v = 0.7554088969774001d-03 call gen_oh ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.6510679849127481d+00 v = 0.7553147174442808d-03 call gen_oh ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.6777315251687360d+00 v = 0.7564767653292297d-03 call gen_oh ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.6963109410648741d+00 v = 0.7587991808518730d-03 call gen_oh ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.7058935009831749d+00 v = 0.7608261832033027d-03 call gen_oh ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.9955546194091857d+00 v = 0.4021680447874916d-03 call gen_oh ( 5 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.9734115901794209d+00 v = 0.5804871793945964d-03 call gen_oh ( 5 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.9275693732388626d+00 v = 0.6792151955945159d-03 call gen_oh ( 5 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.8568022422795103d+00 v = 0.7336741211286294d-03 call gen_oh ( 5 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.7623495553719372d+00 v = 0.7581866300989608d-03 call gen_oh ( 5 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.5707522908892223d+00 b = 0.4387028039889501d+00 v = 0.7538257859800743d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.5196463388403083d+00 b = 0.3858908414762617d+00 v = 0.7483517247053123d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.4646337531215351d+00 b = 0.3301937372343854d+00 v = 0.7371763661112059d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.4063901697557691d+00 b = 0.2725423573563777d+00 v = 0.7183448895756934d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.3456329466643087d+00 b = 0.2139510237495250d+00 v = 0.6895815529822191d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.2831395121050332d+00 b = 0.1555922309786647d+00 v = 0.6480105801792886d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.2197682022925330d+00 b = 0.9892878979686097d-01 v = 0.5897558896594636d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.1564696098650355d+00 b = 0.4598642910675510d-01 v = 0.5095708849247346d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.6027356673721295d+00 b = 0.3376625140173426d+00 v = 0.7536906428909755d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.5496032320255096d+00 b = 0.2822301309727988d+00 v = 0.7472505965575118d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.4921707755234567d+00 b = 0.2248632342592540d+00 v = 0.7343017132279698d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.4309422998598483d+00 b = 0.1666224723456479d+00 v = 0.7130871582177445d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.3664108182313672d+00 b = 0.1086964901822169d+00 v = 0.6817022032112776d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.2990189057758436d+00 b = 0.5251989784120085d-01 v = 0.6380941145604121d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.6268724013144998d+00 b = 0.2297523657550023d+00 v = 0.7550381377920310d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.5707324144834607d+00 b = 0.1723080607093800d+00 v = 0.7478646640144802d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.5096360901960365d+00 b = 0.1140238465390513d+00 v = 0.7335918720601220d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.4438729938312456d+00 b = 0.5611522095882537d-01 v = 0.7110120527658118d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.6419978471082389d+00 b = 0.1164174423140873d+00 v = 0.7571363978689501d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.5817218061802611d+00 b = 0.5797589531445219d-01 v = 0.7489908329079234d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) n = n - 1 end subroutine subroutine ld1730 ( x , y , z , w , n ) real ( kind = dp ) :: x ( * ) real ( kind = dp ) :: y ( * ) real ( kind = dp ) :: z ( * ) real ( kind = dp ) :: w ( * ) integer :: n real ( kind = dp ) :: a , b , v ! !      LEBEDEV 1730-POINT ANGULAR GRID ! ! !      THIS ROUTINE IS PART OF A SET OF ROUTINES THAT GENERATE !      LEBEDEV GRIDS [1-6] FOR INTEGRATION ON A SPHERE. THE ORIGINAL !      C-CODE [1] WAS KINDLY PROVIDED BY DR. DMITRI N. LAIKOV AND !      TRANSLATED INTO FORTRAN BY DR. CHRISTOPH VAN WUELLEN. !      THIS ROUTINE WAS TRANSLATED USING A C TO FORTRAN77 CONVERSION !      TOOL WRITTEN BY DR. CHRISTOPH VAN WUELLEN. ! !      USERS OF THIS CODE ARE ASKED TO INCLUDE REFERENCE [1] IN THEIR !      PUBLICATIONS, AND IN THE USER- AND PROGRAMMERS-MANUALS !      DESCRIBING THEIR CODES. ! !      THIS CODE WAS DISTRIBUTED THROUGH CCL (HTTP://WWW.CCL.NET/). ! !      [1] V.I. LEBEDEV, AND D.N. LAIKOV !          \"A QUADRATURE FORMULA FOR THE SPHERE OF THE 131ST !           ALGEBRAIC ORDER OF ACCURACY\" !          DOKLADY MATHEMATICS, VOL. 59, NO. 3, 1999, PP. 477-481. ! !      [2] V.I. LEBEDEV !          \"A QUADRATURE FORMULA FOR THE SPHERE OF 59TH ALGEBRAIC !           ORDER OF ACCURACY\" !          RUSSIAN ACAD. SCI. DOKL. MATH., VOL. 50, 1995, PP. 283-286. ! !      [3] V.I. LEBEDEV, AND A.L. SKOROKHODOV !          \"QUADRATURE FORMULAS OF ORDERS 41, 47, AND 53 FOR THE SPHERE\" !          RUSSIAN ACAD. SCI. DOKL. MATH., VOL. 45, 1992, PP. 587-592. ! !      [4] V.I. LEBEDEV !          \"SPHERICAL QUADRATURE FORMULAS EXACT TO ORDERS 25-29\" !          SIBERIAN MATHEMATICAL JOURNAL, VOL. 18, 1977, PP. 99-107. ! !      [5] V.I. LEBEDEV !          \"QUADRATURES ON A SPHERE\" !          COMPUTATIONAL MATHEMATICS AND MATHEMATICAL PHYSICS, VOL. 16, !          1976, PP. 10-24. ! !      [6] V.I. LEBEDEV !          \"VALUES OF THE NODES AND WEIGHTS OF NINTH TO SEVENTEENTH !           ORDER GAUSS-MARKOV QUADRATURE FORMULAE INVARIANT UNDER THE !           OCTAHEDRON GROUP WITH INVERSION\" !          COMPUTATIONAL MATHEMATICS AND MATHEMATICAL PHYSICS, VOL. 15, !          1975, PP. 44-51. ! n = 1 v = 0.6309049437420976d-04 call gen_oh ( 1 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) v = 0.6398287705571748d-03 call gen_oh ( 2 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) v = 0.6357185073530720d-03 call gen_oh ( 3 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.2860923126194662d-01 v = 0.2221207162188168d-03 call gen_oh ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.7142556767711522d-01 v = 0.3475784022286848d-03 call gen_oh ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.1209199540995559d+00 v = 0.4350742443589804d-03 call gen_oh ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.1738673106594379d+00 v = 0.4978569136522127d-03 call gen_oh ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.2284645438467734d+00 v = 0.5435036221998053d-03 call gen_oh ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.2834807671701512d+00 v = 0.5765913388219542d-03 call gen_oh ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.3379680145467339d+00 v = 0.6001200359226003d-03 call gen_oh ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.3911355454819537d+00 v = 0.6162178172717512d-03 call gen_oh ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.4422860353001403d+00 v = 0.6265218152438485d-03 call gen_oh ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.4907781568726057d+00 v = 0.6323987160974212d-03 call gen_oh ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.5360006153211468d+00 v = 0.6350767851540569d-03 call gen_oh ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.6142105973596603d+00 v = 0.6354362775297107d-03 call gen_oh ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.6459300387977504d+00 v = 0.6352302462706235d-03 call gen_oh ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.6718056125089225d+00 v = 0.6358117881417972d-03 call gen_oh ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.6910888533186254d+00 v = 0.6373101590310117d-03 call gen_oh ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.7030467416823252d+00 v = 0.6390428961368665d-03 call gen_oh ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.8354951166354646d-01 v = 0.3186913449946576d-03 call gen_oh ( 5 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.2050143009099486d+00 v = 0.4678028558591711d-03 call gen_oh ( 5 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.3370208290706637d+00 v = 0.5538829697598626d-03 call gen_oh ( 5 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.4689051484233963d+00 v = 0.6044475907190476d-03 call gen_oh ( 5 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.5939400424557334d+00 v = 0.6313575103509012d-03 call gen_oh ( 5 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.1394983311832261d+00 b = 0.4097581162050343d-01 v = 0.4078626431855630d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.1967999180485014d+00 b = 0.8851987391293348d-01 v = 0.4759933057812725d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.2546183732548967d+00 b = 0.1397680182969819d+00 v = 0.5268151186413440d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.3121281074713875d+00 b = 0.1929452542226526d+00 v = 0.5643048560507316d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.3685981078502492d+00 b = 0.2467898337061562d+00 v = 0.5914501076613073d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.4233760321547856d+00 b = 0.3003104124785409d+00 v = 0.6104561257874195d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.4758671236059246d+00 b = 0.3526684328175033d+00 v = 0.6230252860707806d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.5255178579796463d+00 b = 0.4031134861145713d+00 v = 0.6305618761760796d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.5718025633734589d+00 b = 0.4509426448342351d+00 v = 0.6343092767597889d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.2686927772723415d+00 b = 0.4711322502423248d-01 v = 0.5176268945737826d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.3306006819904809d+00 b = 0.9784487303942695d-01 v = 0.5564840313313692d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.3904906850594983d+00 b = 0.1505395810025273d+00 v = 0.5856426671038980d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.4479957951904390d+00 b = 0.2039728156296050d+00 v = 0.6066386925777091d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.5027076848919780d+00 b = 0.2571529941121107d+00 v = 0.6208824962234458d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.5542087392260217d+00 b = 0.3092191375815670d+00 v = 0.6296314297822907d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.6020850887375187d+00 b = 0.3593807506130276d+00 v = 0.6340423756791859d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.4019851409179594d+00 b = 0.5063389934378671d-01 v = 0.5829627677107342d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.4635614567449800d+00 b = 0.1032422269160612d+00 v = 0.6048693376081110d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.5215860931591575d+00 b = 0.1566322094006254d+00 v = 0.6202362317732461d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.5758202499099271d+00 b = 0.2098082827491099d+00 v = 0.6299005328403779d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.6259893683876795d+00 b = 0.2618824114553391d+00 v = 0.6347722390609353d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.5313795124811891d+00 b = 0.5263245019338556d-01 v = 0.6203778981238834d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.5893317955931995d+00 b = 0.1061059730982005d+00 v = 0.6308414671239979d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.6426246321215801d+00 b = 0.1594171564034221d+00 v = 0.6362706466959498d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.6511904367376113d+00 b = 0.5354789536565540d-01 v = 0.6375414170333233d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) n = n - 1 end subroutine subroutine ld2030 ( x , y , z , w , n ) real ( kind = dp ) :: x ( * ) real ( kind = dp ) :: y ( * ) real ( kind = dp ) :: z ( * ) real ( kind = dp ) :: w ( * ) integer :: n real ( kind = dp ) :: a , b , v ! !      LEBEDEV 2030-POINT ANGULAR GRID ! ! !      THIS ROUTINE IS PART OF A SET OF ROUTINES THAT GENERATE !      LEBEDEV GRIDS [1-6] FOR INTEGRATION ON A SPHERE. THE ORIGINAL !      C-CODE [1] WAS KINDLY PROVIDED BY DR. DMITRI N. LAIKOV AND !      TRANSLATED INTO FORTRAN BY DR. CHRISTOPH VAN WUELLEN. !      THIS ROUTINE WAS TRANSLATED USING A C TO FORTRAN77 CONVERSION !      TOOL WRITTEN BY DR. CHRISTOPH VAN WUELLEN. ! !      USERS OF THIS CODE ARE ASKED TO INCLUDE REFERENCE [1] IN THEIR !      PUBLICATIONS, AND IN THE USER- AND PROGRAMMERS-MANUALS !      DESCRIBING THEIR CODES. ! !      THIS CODE WAS DISTRIBUTED THROUGH CCL (HTTP://WWW.CCL.NET/). ! !      [1] V.I. LEBEDEV, AND D.N. LAIKOV !          \"A QUADRATURE FORMULA FOR THE SPHERE OF THE 131ST !           ALGEBRAIC ORDER OF ACCURACY\" !          DOKLADY MATHEMATICS, VOL. 59, NO. 3, 1999, PP. 477-481. ! !      [2] V.I. LEBEDEV !          \"A QUADRATURE FORMULA FOR THE SPHERE OF 59TH ALGEBRAIC !           ORDER OF ACCURACY\" !          RUSSIAN ACAD. SCI. DOKL. MATH., VOL. 50, 1995, PP. 283-286. ! !      [3] V.I. LEBEDEV, AND A.L. SKOROKHODOV !          \"QUADRATURE FORMULAS OF ORDERS 41, 47, AND 53 FOR THE SPHERE\" !          RUSSIAN ACAD. SCI. DOKL. MATH., VOL. 45, 1992, PP. 587-592. ! !      [4] V.I. LEBEDEV !          \"SPHERICAL QUADRATURE FORMULAS EXACT TO ORDERS 25-29\" !          SIBERIAN MATHEMATICAL JOURNAL, VOL. 18, 1977, PP. 99-107. ! !      [5] V.I. LEBEDEV !          \"QUADRATURES ON A SPHERE\" !          COMPUTATIONAL MATHEMATICS AND MATHEMATICAL PHYSICS, VOL. 16, !          1976, PP. 10-24. ! !      [6] V.I. LEBEDEV !          \"VALUES OF THE NODES AND WEIGHTS OF NINTH TO SEVENTEENTH !           ORDER GAUSS-MARKOV QUADRATURE FORMULAE INVARIANT UNDER THE !           OCTAHEDRON GROUP WITH INVERSION\" !          COMPUTATIONAL MATHEMATICS AND MATHEMATICAL PHYSICS, VOL. 15, !          1975, PP. 44-51. ! n = 1 v = 0.4656031899197431d-04 call gen_oh ( 1 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) v = 0.5421549195295507d-03 call gen_oh ( 3 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.2540835336814348d-01 v = 0.1778522133346553d-03 call gen_oh ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.6399322800504915d-01 v = 0.2811325405682796d-03 call gen_oh ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.1088269469804125d+00 v = 0.3548896312631459d-03 call gen_oh ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.1570670798818287d+00 v = 0.4090310897173364d-03 call gen_oh ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.2071163932282514d+00 v = 0.4493286134169965d-03 call gen_oh ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.2578914044450844d+00 v = 0.4793728447962723d-03 call gen_oh ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.3085687558169623d+00 v = 0.5015415319164265d-03 call gen_oh ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.3584719706267024d+00 v = 0.5175127372677937d-03 call gen_oh ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.4070135594428709d+00 v = 0.5285522262081019d-03 call gen_oh ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.4536618626222638d+00 v = 0.5356832703713962d-03 call gen_oh ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.4979195686463577d+00 v = 0.5397914736175170d-03 call gen_oh ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.5393075111126999d+00 v = 0.5416899441599930d-03 call gen_oh ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.6115617676843916d+00 v = 0.5419308476889938d-03 call gen_oh ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.6414308435160159d+00 v = 0.5416936902030596d-03 call gen_oh ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.6664099412721607d+00 v = 0.5419544338703164d-03 call gen_oh ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.6859161771214913d+00 v = 0.5428983656630975d-03 call gen_oh ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.6993625593503890d+00 v = 0.5442286500098193d-03 call gen_oh ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.7062393387719380d+00 v = 0.5452250345057301d-03 call gen_oh ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.7479028168349763d-01 v = 0.2568002497728530d-03 call gen_oh ( 5 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.1848951153969366d+00 v = 0.3827211700292145d-03 call gen_oh ( 5 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.3059529066581305d+00 v = 0.4579491561917824d-03 call gen_oh ( 5 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.4285556101021362d+00 v = 0.5042003969083574d-03 call gen_oh ( 5 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.5468758653496526d+00 v = 0.5312708889976025d-03 call gen_oh ( 5 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.6565821978343439d+00 v = 0.5438401790747117d-03 call gen_oh ( 5 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.1253901572367117d+00 b = 0.3681917226439641d-01 v = 0.3316041873197344d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.1775721510383941d+00 b = 0.7982487607213301d-01 v = 0.3899113567153771d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.2305693358216114d+00 b = 0.1264640966592335d+00 v = 0.4343343327201309d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.2836502845992063d+00 b = 0.1751585683418957d+00 v = 0.4679415262318919d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.3361794746232590d+00 b = 0.2247995907632670d+00 v = 0.4930847981631031d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.3875979172264824d+00 b = 0.2745299257422246d+00 v = 0.5115031867540091d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.4374019316999074d+00 b = 0.3236373482441118d+00 v = 0.5245217148457367d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.4851275843340022d+00 b = 0.3714967859436741d+00 v = 0.5332041499895321d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.5303391803806868d+00 b = 0.4175353646321745d+00 v = 0.5384583126021542d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.5726197380596287d+00 b = 0.4612084406355461d+00 v = 0.5411067210798852d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.2431520732564863d+00 b = 0.4258040133043952d-01 v = 0.4259797391468714d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.3002096800895869d+00 b = 0.8869424306722721d-01 v = 0.4604931368460021d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.3558554457457432d+00 b = 0.1368811706510655d+00 v = 0.4871814878255202d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.4097782537048887d+00 b = 0.1860739985015033d+00 v = 0.5072242910074885d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.4616337666067458d+00 b = 0.2354235077395853d+00 v = 0.5217069845235350d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.5110707008417874d+00 b = 0.2842074921347011d+00 v = 0.5315785966280310d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.5577415286163795d+00 b = 0.3317784414984102d+00 v = 0.5376833708758905d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.6013060431366950d+00 b = 0.3775299002040700d+00 v = 0.5408032092069521d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.3661596767261781d+00 b = 0.4599367887164592d-01 v = 0.4842744917904866d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.4237633153506581d+00 b = 0.9404893773654421d-01 v = 0.5048926076188130d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.4786328454658452d+00 b = 0.1431377109091971d+00 v = 0.5202607980478373d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.5305702076789774d+00 b = 0.1924186388843570d+00 v = 0.5309932388325743d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.5793436224231788d+00 b = 0.2411590944775190d+00 v = 0.5377419770895208d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.6247069017094747d+00 b = 0.2886871491583605d+00 v = 0.5411696331677717d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.4874315552535204d+00 b = 0.4804978774953206d-01 v = 0.5197996293282420d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.5427337322059053d+00 b = 0.9716857199366665d-01 v = 0.5311120836622945d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.5943493747246700d+00 b = 0.1465205839795055d+00 v = 0.5384309319956951d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.6421314033564943d+00 b = 0.1953579449803574d+00 v = 0.5421859504051886d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.6020628374713980d+00 b = 0.4916375015738108d-01 v = 0.5390948355046314d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.6529222529856881d+00 b = 0.9861621540127005d-01 v = 0.5433312705027845d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) n = n - 1 end subroutine subroutine ld2354 ( x , y , z , w , n ) real ( kind = dp ) :: x ( * ) real ( kind = dp ) :: y ( * ) real ( kind = dp ) :: z ( * ) real ( kind = dp ) :: w ( * ) integer :: n real ( kind = dp ) :: a , b , v ! !      LEBEDEV 2354-POINT ANGULAR GRID ! ! !      THIS ROUTINE IS PART OF A SET OF ROUTINES THAT GENERATE !      LEBEDEV GRIDS [1-6] FOR INTEGRATION ON A SPHERE. THE ORIGINAL !      C-CODE [1] WAS KINDLY PROVIDED BY DR. DMITRI N. LAIKOV AND !      TRANSLATED INTO FORTRAN BY DR. CHRISTOPH VAN WUELLEN. !      THIS ROUTINE WAS TRANSLATED USING A C TO FORTRAN77 CONVERSION !      TOOL WRITTEN BY DR. CHRISTOPH VAN WUELLEN. ! !      USERS OF THIS CODE ARE ASKED TO INCLUDE REFERENCE [1] IN THEIR !      PUBLICATIONS, AND IN THE USER- AND PROGRAMMERS-MANUALS !      DESCRIBING THEIR CODES. ! !      THIS CODE WAS DISTRIBUTED THROUGH CCL (HTTP://WWW.CCL.NET/). ! !      [1] V.I. LEBEDEV, AND D.N. LAIKOV !          \"A QUADRATURE FORMULA FOR THE SPHERE OF THE 131ST !           ALGEBRAIC ORDER OF ACCURACY\" !          DOKLADY MATHEMATICS, VOL. 59, NO. 3, 1999, PP. 477-481. ! !      [2] V.I. LEBEDEV !          \"A QUADRATURE FORMULA FOR THE SPHERE OF 59TH ALGEBRAIC !           ORDER OF ACCURACY\" !          RUSSIAN ACAD. SCI. DOKL. MATH., VOL. 50, 1995, PP. 283-286. ! !      [3] V.I. LEBEDEV, AND A.L. SKOROKHODOV !          \"QUADRATURE FORMULAS OF ORDERS 41, 47, AND 53 FOR THE SPHERE\" !          RUSSIAN ACAD. SCI. DOKL. MATH., VOL. 45, 1992, PP. 587-592. ! !      [4] V.I. LEBEDEV !          \"SPHERICAL QUADRATURE FORMULAS EXACT TO ORDERS 25-29\" !          SIBERIAN MATHEMATICAL JOURNAL, VOL. 18, 1977, PP. 99-107. ! !      [5] V.I. LEBEDEV !          \"QUADRATURES ON A SPHERE\" !          COMPUTATIONAL MATHEMATICS AND MATHEMATICAL PHYSICS, VOL. 16, !          1976, PP. 10-24. ! !      [6] V.I. LEBEDEV !          \"VALUES OF THE NODES AND WEIGHTS OF NINTH TO SEVENTEENTH !           ORDER GAUSS-MARKOV QUADRATURE FORMULAE INVARIANT UNDER THE !           OCTAHEDRON GROUP WITH INVERSION\" !          COMPUTATIONAL MATHEMATICS AND MATHEMATICAL PHYSICS, VOL. 15, !          1975, PP. 44-51. ! n = 1 v = 0.3922616270665292d-04 call gen_oh ( 1 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) v = 0.4703831750854424d-03 call gen_oh ( 2 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) v = 0.4678202801282136d-03 call gen_oh ( 3 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.2290024646530589d-01 v = 0.1437832228979900d-03 call gen_oh ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.5779086652271284d-01 v = 0.2303572493577644d-03 call gen_oh ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.9863103576375984d-01 v = 0.2933110752447454d-03 call gen_oh ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.1428155792982185d+00 v = 0.3402905998359838d-03 call gen_oh ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.1888978116601463d+00 v = 0.3759138466870372d-03 call gen_oh ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.2359091682970210d+00 v = 0.4030638447899798d-03 call gen_oh ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.2831228833706171d+00 v = 0.4236591432242211d-03 call gen_oh ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.3299495857966693d+00 v = 0.4390522656946746d-03 call gen_oh ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.3758840802660796d+00 v = 0.4502523466626247d-03 call gen_oh ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.4204751831009480d+00 v = 0.4580577727783541d-03 call gen_oh ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.4633068518751051d+00 v = 0.4631391616615899d-03 call gen_oh ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.5039849474507313d+00 v = 0.4660928953698676d-03 call gen_oh ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.5421265793440747d+00 v = 0.4674751807936953d-03 call gen_oh ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.6092660230557310d+00 v = 0.4676414903932920d-03 call gen_oh ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.6374654204984869d+00 v = 0.4674086492347870d-03 call gen_oh ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.6615136472609892d+00 v = 0.4674928539483207d-03 call gen_oh ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.6809487285958127d+00 v = 0.4680748979686447d-03 call gen_oh ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.6952980021665196d+00 v = 0.4690449806389040d-03 call gen_oh ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.7041245497695400d+00 v = 0.4699877075860818d-03 call gen_oh ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.6744033088306065d-01 v = 0.2099942281069176d-03 call gen_oh ( 5 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.1678684485334166d+00 v = 0.3172269150712804d-03 call gen_oh ( 5 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.2793559049539613d+00 v = 0.3832051358546523d-03 call gen_oh ( 5 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.3935264218057639d+00 v = 0.4252193818146985d-03 call gen_oh ( 5 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.5052629268232558d+00 v = 0.4513807963755000d-03 call gen_oh ( 5 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.6107905315437531d+00 v = 0.4657797469114178d-03 call gen_oh ( 5 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.1135081039843524d+00 b = 0.3331954884662588d-01 v = 0.2733362800522836d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.1612866626099378d+00 b = 0.7247167465436538d-01 v = 0.3235485368463559d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.2100786550168205d+00 b = 0.1151539110849745d+00 v = 0.3624908726013453d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.2592282009459942d+00 b = 0.1599491097143677d+00 v = 0.3925540070712828d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.3081740561320203d+00 b = 0.2058699956028027d+00 v = 0.4156129781116235d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.3564289781578164d+00 b = 0.2521624953502911d+00 v = 0.4330644984623263d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.4035587288240703d+00 b = 0.2982090785797674d+00 v = 0.4459677725921312d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.4491671196373903d+00 b = 0.3434762087235733d+00 v = 0.4551593004456795d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.4928854782917489d+00 b = 0.3874831357203437d+00 v = 0.4613341462749918d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.5343646791958988d+00 b = 0.4297814821746926d+00 v = 0.4651019618269806d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.5732683216530990d+00 b = 0.4699402260943537d+00 v = 0.4670249536100625d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.2214131583218986d+00 b = 0.3873602040643895d-01 v = 0.3549555576441708d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.2741796504750071d+00 b = 0.8089496256902013d-01 v = 0.3856108245249010d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.3259797439149485d+00 b = 0.1251732177620872d+00 v = 0.4098622845756882d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.3765441148826891d+00 b = 0.1706260286403185d+00 v = 0.4286328604268950d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.4255773574530558d+00 b = 0.2165115147300408d+00 v = 0.4427802198993945d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.4727795117058430d+00 b = 0.2622089812225259d+00 v = 0.4530473511488561d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.5178546895819012d+00 b = 0.3071721431296201d+00 v = 0.4600805475703138d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.5605141192097460d+00 b = 0.3508998998801138d+00 v = 0.4644599059958017d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.6004763319352512d+00 b = 0.3929160876166931d+00 v = 0.4667274455712508d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.3352842634946949d+00 b = 0.4202563457288019d-01 v = 0.4069360518020356d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.3891971629814670d+00 b = 0.8614309758870850d-01 v = 0.4260442819919195d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.4409875565542281d+00 b = 0.1314500879380001d+00 v = 0.4408678508029063d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.4904893058592484d+00 b = 0.1772189657383859d+00 v = 0.4518748115548597d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.5375056138769549d+00 b = 0.2228277110050294d+00 v = 0.4595564875375116d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.5818255708669969d+00 b = 0.2677179935014386d+00 v = 0.4643988774315846d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.6232334858144959d+00 b = 0.3113675035544165d+00 v = 0.4668827491646946d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.4489485354492058d+00 b = 0.4409162378368174d-01 v = 0.4400541823741973d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.5015136875933150d+00 b = 0.8939009917748489d-01 v = 0.4514512890193797d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.5511300550512623d+00 b = 0.1351806029383365d+00 v = 0.4596198627347549d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.5976720409858000d+00 b = 0.1808370355053196d+00 v = 0.4648659016801781d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.6409956378989354d+00 b = 0.2257852192301602d+00 v = 0.4675502017157673d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.5581222330827514d+00 b = 0.4532173421637160d-01 v = 0.4598494476455523d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.6074705984161695d+00 b = 0.9117488031840314d-01 v = 0.4654916955152048d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.6532272537379033d+00 b = 0.1369294213140155d+00 v = 0.4684709779505137d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.6594761494500487d+00 b = 0.4589901487275583d-01 v = 0.4691445539106986d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) n = n - 1 end subroutine subroutine ld2702 ( x , y , z , w , n ) real ( kind = dp ) :: x ( * ) real ( kind = dp ) :: y ( * ) real ( kind = dp ) :: z ( * ) real ( kind = dp ) :: w ( * ) integer :: n real ( kind = dp ) :: a , b , v ! !      LEBEDEV 2702-POINT ANGULAR GRID ! ! !      THIS ROUTINE IS PART OF A SET OF ROUTINES THAT GENERATE !      LEBEDEV GRIDS [1-6] FOR INTEGRATION ON A SPHERE. THE ORIGINAL !      C-CODE [1] WAS KINDLY PROVIDED BY DR. DMITRI N. LAIKOV AND !      TRANSLATED INTO FORTRAN BY DR. CHRISTOPH VAN WUELLEN. !      THIS ROUTINE WAS TRANSLATED USING A C TO FORTRAN77 CONVERSION !      TOOL WRITTEN BY DR. CHRISTOPH VAN WUELLEN. ! !      USERS OF THIS CODE ARE ASKED TO INCLUDE REFERENCE [1] IN THEIR !      PUBLICATIONS, AND IN THE USER- AND PROGRAMMERS-MANUALS !      DESCRIBING THEIR CODES. ! !      THIS CODE WAS DISTRIBUTED THROUGH CCL (HTTP://WWW.CCL.NET/). ! !      [1] V.I. LEBEDEV, AND D.N. LAIKOV !          \"A QUADRATURE FORMULA FOR THE SPHERE OF THE 131ST !           ALGEBRAIC ORDER OF ACCURACY\" !          DOKLADY MATHEMATICS, VOL. 59, NO. 3, 1999, PP. 477-481. ! !      [2] V.I. LEBEDEV !          \"A QUADRATURE FORMULA FOR THE SPHERE OF 59TH ALGEBRAIC !           ORDER OF ACCURACY\" !          RUSSIAN ACAD. SCI. DOKL. MATH., VOL. 50, 1995, PP. 283-286. ! !      [3] V.I. LEBEDEV, AND A.L. SKOROKHODOV !          \"QUADRATURE FORMULAS OF ORDERS 41, 47, AND 53 FOR THE SPHERE\" !          RUSSIAN ACAD. SCI. DOKL. MATH., VOL. 45, 1992, PP. 587-592. ! !      [4] V.I. LEBEDEV !          \"SPHERICAL QUADRATURE FORMULAS EXACT TO ORDERS 25-29\" !          SIBERIAN MATHEMATICAL JOURNAL, VOL. 18, 1977, PP. 99-107. ! !      [5] V.I. LEBEDEV !          \"QUADRATURES ON A SPHERE\" !          COMPUTATIONAL MATHEMATICS AND MATHEMATICAL PHYSICS, VOL. 16, !          1976, PP. 10-24. ! !      [6] V.I. LEBEDEV !          \"VALUES OF THE NODES AND WEIGHTS OF NINTH TO SEVENTEENTH !           ORDER GAUSS-MARKOV QUADRATURE FORMULAE INVARIANT UNDER THE !           OCTAHEDRON GROUP WITH INVERSION\" !          COMPUTATIONAL MATHEMATICS AND MATHEMATICAL PHYSICS, VOL. 15, !          1975, PP. 44-51. ! n = 1 v = 0.2998675149888161d-04 call gen_oh ( 1 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) v = 0.4077860529495355d-03 call gen_oh ( 3 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.2065562538818703d-01 v = 0.1185349192520667d-03 call gen_oh ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.5250918173022379d-01 v = 0.1913408643425751d-03 call gen_oh ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.8993480082038376d-01 v = 0.2452886577209897d-03 call gen_oh ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.1306023924436019d+00 v = 0.2862408183288702d-03 call gen_oh ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.1732060388531418d+00 v = 0.3178032258257357d-03 call gen_oh ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.2168727084820249d+00 v = 0.3422945667633690d-03 call gen_oh ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.2609528309173586d+00 v = 0.3612790520235922d-03 call gen_oh ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.3049252927938952d+00 v = 0.3758638229818521d-03 call gen_oh ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.3483484138084404d+00 v = 0.3868711798859953d-03 call gen_oh ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.3908321549106406d+00 v = 0.3949429933189938d-03 call gen_oh ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.4320210071894814d+00 v = 0.4006068107541156d-03 call gen_oh ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.4715824795890053d+00 v = 0.4043192149672723d-03 call gen_oh ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.5091984794078453d+00 v = 0.4064947495808078d-03 call gen_oh ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.5445580145650803d+00 v = 0.4075245619813152d-03 call gen_oh ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.6072575796841768d+00 v = 0.4076423540893566d-03 call gen_oh ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.6339484505755803d+00 v = 0.4074280862251555d-03 call gen_oh ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.6570718257486958d+00 v = 0.4074163756012244d-03 call gen_oh ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.6762557330090709d+00 v = 0.4077647795071246d-03 call gen_oh ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.6911161696923790d+00 v = 0.4084517552782530d-03 call gen_oh ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.7012841911659961d+00 v = 0.4092468459224052d-03 call gen_oh ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.7064559272410020d+00 v = 0.4097872687240906d-03 call gen_oh ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.6123554989894765d-01 v = 0.1738986811745028d-03 call gen_oh ( 5 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.1533070348312393d+00 v = 0.2659616045280191d-03 call gen_oh ( 5 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.2563902605244206d+00 v = 0.3240596008171533d-03 call gen_oh ( 5 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.3629346991663361d+00 v = 0.3621195964432943d-03 call gen_oh ( 5 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.4683949968987538d+00 v = 0.3868838330760539d-03 call gen_oh ( 5 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.5694479240657952d+00 v = 0.4018911532693111d-03 call gen_oh ( 5 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.6634465430993955d+00 v = 0.4089929432983252d-03 call gen_oh ( 5 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.1033958573552305d+00 b = 0.3034544009063584d-01 v = 0.2279907527706409d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.1473521412414395d+00 b = 0.6618803044247135d-01 v = 0.2715205490578897d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.1924552158705967d+00 b = 0.1054431128987715d+00 v = 0.3057917896703976d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.2381094362890328d+00 b = 0.1468263551238858d+00 v = 0.3326913052452555d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.2838121707936760d+00 b = 0.1894486108187886d+00 v = 0.3537334711890037d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.3291323133373415d+00 b = 0.2326374238761579d+00 v = 0.3700567500783129d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.3736896978741460d+00 b = 0.2758485808485768d+00 v = 0.3825245372589122d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.4171406040760013d+00 b = 0.3186179331996921d+00 v = 0.3918125171518296d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.4591677985256915d+00 b = 0.3605329796303794d+00 v = 0.3984720419937579d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.4994733831718418d+00 b = 0.4012147253586509d+00 v = 0.4029746003338211d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.5377731830445096d+00 b = 0.4403050025570692d+00 v = 0.4057428632156627d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.5737917830001331d+00 b = 0.4774565904277483d+00 v = 0.4071719274114857d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.2027323586271389d+00 b = 0.3544122504976147d-01 v = 0.2990236950664119d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.2516942375187273d+00 b = 0.7418304388646328d-01 v = 0.3262951734212878d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.3000227995257181d+00 b = 0.1150502745727186d+00 v = 0.3482634608242413d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.3474806691046342d+00 b = 0.1571963371209364d+00 v = 0.3656596681700892d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.3938103180359209d+00 b = 0.1999631877247100d+00 v = 0.3791740467794218d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.4387519590455703d+00 b = 0.2428073457846535d+00 v = 0.3894034450156905d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.4820503960077787d+00 b = 0.2852575132906155d+00 v = 0.3968600245508371d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.5234573778475101d+00 b = 0.3268884208674639d+00 v = 0.4019931351420050d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.5627318647235282d+00 b = 0.3673033321675939d+00 v = 0.4052108801278599d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.5996390607156954d+00 b = 0.4061211551830290d+00 v = 0.4068978613940934d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.3084780753791947d+00 b = 0.3860125523100059d-01 v = 0.3454275351319704d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.3589988275920223d+00 b = 0.7928938987104867d-01 v = 0.3629963537007920d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.4078628415881973d+00 b = 0.1212614643030087d+00 v = 0.3770187233889873d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.4549287258889735d+00 b = 0.1638770827382693d+00 v = 0.3878608613694378d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.5000278512957279d+00 b = 0.2065965798260176d+00 v = 0.3959065270221274d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.5429785044928199d+00 b = 0.2489436378852235d+00 v = 0.4015286975463570d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.5835939850491711d+00 b = 0.2904811368946891d+00 v = 0.4050866785614717d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.6216870353444856d+00 b = 0.3307941957666609d+00 v = 0.4069320185051913d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.4151104662709091d+00 b = 0.4064829146052554d-01 v = 0.3760120964062763d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.4649804275009218d+00 b = 0.8258424547294755d-01 v = 0.3870969564418064d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.5124695757009662d+00 b = 0.1251841962027289d+00 v = 0.3955287790534055d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.5574711100606224d+00 b = 0.1679107505976331d+00 v = 0.4015361911302668d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.5998597333287227d+00 b = 0.2102805057358715d+00 v = 0.4053836986719548d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.6395007148516600d+00 b = 0.2518418087774107d+00 v = 0.4073578673299117d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.5188456224746252d+00 b = 0.4194321676077518d-01 v = 0.3954628379231406d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.5664190707942778d+00 b = 0.8457661551921499d-01 v = 0.4017645508847530d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.6110464353283153d+00 b = 0.1273652932519396d+00 v = 0.4059030348651293d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.6526430302051563d+00 b = 0.1698173239076354d+00 v = 0.4080565809484880d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.6167551880377548d+00 b = 0.4266398851548864d-01 v = 0.4063018753664651d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.6607195418355383d+00 b = 0.8551925814238349d-01 v = 0.4087191292799671d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) n = n - 1 end subroutine subroutine ld3074 ( x , y , z , w , n ) real ( kind = dp ) :: x ( * ) real ( kind = dp ) :: y ( * ) real ( kind = dp ) :: z ( * ) real ( kind = dp ) :: w ( * ) integer :: n real ( kind = dp ) :: a , b , v ! !      LEBEDEV 3074-POINT ANGULAR GRID ! ! !      THIS ROUTINE IS PART OF A SET OF ROUTINES THAT GENERATE !      LEBEDEV GRIDS [1-6] FOR INTEGRATION ON A SPHERE. THE ORIGINAL !      C-CODE [1] WAS KINDLY PROVIDED BY DR. DMITRI N. LAIKOV AND !      TRANSLATED INTO FORTRAN BY DR. CHRISTOPH VAN WUELLEN. !      THIS ROUTINE WAS TRANSLATED USING A C TO FORTRAN77 CONVERSION !      TOOL WRITTEN BY DR. CHRISTOPH VAN WUELLEN. ! !      USERS OF THIS CODE ARE ASKED TO INCLUDE REFERENCE [1] IN THEIR !      PUBLICATIONS, AND IN THE USER- AND PROGRAMMERS-MANUALS !      DESCRIBING THEIR CODES. ! !      THIS CODE WAS DISTRIBUTED THROUGH CCL (HTTP://WWW.CCL.NET/). ! !      [1] V.I. LEBEDEV, AND D.N. LAIKOV !          \"A QUADRATURE FORMULA FOR THE SPHERE OF THE 131ST !           ALGEBRAIC ORDER OF ACCURACY\" !          DOKLADY MATHEMATICS, VOL. 59, NO. 3, 1999, PP. 477-481. ! !      [2] V.I. LEBEDEV !          \"A QUADRATURE FORMULA FOR THE SPHERE OF 59TH ALGEBRAIC !           ORDER OF ACCURACY\" !          RUSSIAN ACAD. SCI. DOKL. MATH., VOL. 50, 1995, PP. 283-286. ! !      [3] V.I. LEBEDEV, AND A.L. SKOROKHODOV !          \"QUADRATURE FORMULAS OF ORDERS 41, 47, AND 53 FOR THE SPHERE\" !          RUSSIAN ACAD. SCI. DOKL. MATH., VOL. 45, 1992, PP. 587-592. ! !      [4] V.I. LEBEDEV !          \"SPHERICAL QUADRATURE FORMULAS EXACT TO ORDERS 25-29\" !          SIBERIAN MATHEMATICAL JOURNAL, VOL. 18, 1977, PP. 99-107. ! !      [5] V.I. LEBEDEV !          \"QUADRATURES ON A SPHERE\" !          COMPUTATIONAL MATHEMATICS AND MATHEMATICAL PHYSICS, VOL. 16, !          1976, PP. 10-24. ! !      [6] V.I. LEBEDEV !          \"VALUES OF THE NODES AND WEIGHTS OF NINTH TO SEVENTEENTH !           ORDER GAUSS-MARKOV QUADRATURE FORMULAE INVARIANT UNDER THE !           OCTAHEDRON GROUP WITH INVERSION\" !          COMPUTATIONAL MATHEMATICS AND MATHEMATICAL PHYSICS, VOL. 15, !          1975, PP. 44-51. ! n = 1 v = 0.2599095953754734d-04 call gen_oh ( 1 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) v = 0.3603134089687541d-03 call gen_oh ( 2 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) v = 0.3586067974412447d-03 call gen_oh ( 3 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.1886108518723392d-01 v = 0.9831528474385880d-04 call gen_oh ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.4800217244625303d-01 v = 0.1605023107954450d-03 call gen_oh ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.8244922058397242d-01 v = 0.2072200131464099d-03 call gen_oh ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.1200408362484023d+00 v = 0.2431297618814187d-03 call gen_oh ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.1595773530809965d+00 v = 0.2711819064496707d-03 call gen_oh ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.2002635973434064d+00 v = 0.2932762038321116d-03 call gen_oh ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.2415127590139982d+00 v = 0.3107032514197368d-03 call gen_oh ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.2828584158458477d+00 v = 0.3243808058921213d-03 call gen_oh ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.3239091015338138d+00 v = 0.3349899091374030d-03 call gen_oh ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.3643225097962194d+00 v = 0.3430580688505218d-03 call gen_oh ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.4037897083691802d+00 v = 0.3490124109290343d-03 call gen_oh ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.4420247515194127d+00 v = 0.3532148948561955d-03 call gen_oh ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.4787572538464938d+00 v = 0.3559862669062833d-03 call gen_oh ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.5137265251275234d+00 v = 0.3576224317551411d-03 call gen_oh ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.5466764056654611d+00 v = 0.3584050533086076d-03 call gen_oh ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.6054859420813535d+00 v = 0.3584903581373224d-03 call gen_oh ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.6308106701764562d+00 v = 0.3582991879040586d-03 call gen_oh ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.6530369230179584d+00 v = 0.3582371187963125d-03 call gen_oh ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.6718609524611158d+00 v = 0.3584353631122350d-03 call gen_oh ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.6869676499894013d+00 v = 0.3589120166517785d-03 call gen_oh ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.6980467077240748d+00 v = 0.3595445704531601d-03 call gen_oh ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.7048241721250522d+00 v = 0.3600943557111074d-03 call gen_oh ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.5591105222058232d-01 v = 0.1456447096742039d-03 call gen_oh ( 5 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.1407384078513916d+00 v = 0.2252370188283782d-03 call gen_oh ( 5 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.2364035438976309d+00 v = 0.2766135443474897d-03 call gen_oh ( 5 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.3360602737818170d+00 v = 0.3110729491500851d-03 call gen_oh ( 5 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.4356292630054665d+00 v = 0.3342506712303391d-03 call gen_oh ( 5 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.5321569415256174d+00 v = 0.3491981834026860d-03 call gen_oh ( 5 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.6232956305040554d+00 v = 0.3576003604348932d-03 call gen_oh ( 5 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.9469870086838469d-01 b = 0.2778748387309470d-01 v = 0.1921921305788564d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.1353170300568141d+00 b = 0.6076569878628364d-01 v = 0.2301458216495632d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.1771679481726077d+00 b = 0.9703072762711040d-01 v = 0.2604248549522893d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.2197066664231751d+00 b = 0.1354112458524762d+00 v = 0.2845275425870697d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.2624783557374927d+00 b = 0.1750996479744100d+00 v = 0.3036870897974840d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.3050969521214442d+00 b = 0.2154896907449802d+00 v = 0.3188414832298066d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.3472252637196021d+00 b = 0.2560954625740152d+00 v = 0.3307046414722089d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.3885610219026360d+00 b = 0.2965070050624096d+00 v = 0.3398330969031360d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.4288273776062765d+00 b = 0.3363641488734497d+00 v = 0.3466757899705373d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.4677662471302948d+00 b = 0.3753400029836788d+00 v = 0.3516095923230054d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.5051333589553359d+00 b = 0.4131297522144286d+00 v = 0.3549645184048486d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.5406942145810492d+00 b = 0.4494423776081795d+00 v = 0.3570415969441392d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.5742204122576457d+00 b = 0.4839938958841502d+00 v = 0.3581251798496118d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.1865407027225188d+00 b = 0.3259144851070796d-01 v = 0.2543491329913348d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.2321186453689432d+00 b = 0.6835679505297343d-01 v = 0.2786711051330776d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.2773159142523882d+00 b = 0.1062284864451989d+00 v = 0.2985552361083679d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.3219200192237254d+00 b = 0.1454404409323047d+00 v = 0.3145867929154039d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.3657032593944029d+00 b = 0.1854018282582510d+00 v = 0.3273290662067609d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.4084376778363622d+00 b = 0.2256297412014750d+00 v = 0.3372705511943501d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.4499004945751427d+00 b = 0.2657104425000896d+00 v = 0.3448274437851510d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.4898758141326335d+00 b = 0.3052755487631557d+00 v = 0.3503592783048583d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.5281547442266309d+00 b = 0.3439863920645423d+00 v = 0.3541854792663162d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.5645346989813992d+00 b = 0.3815229456121914d+00 v = 0.3565995517909428d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.5988181252159848d+00 b = 0.4175752420966734d+00 v = 0.3578802078302898d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.2850425424471603d+00 b = 0.3562149509862536d-01 v = 0.2958644592860982d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.3324619433027876d+00 b = 0.7330318886871096d-01 v = 0.3119548129116835d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.3785848333076282d+00 b = 0.1123226296008472d+00 v = 0.3250745225005984d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.4232891028562115d+00 b = 0.1521084193337708d+00 v = 0.3355153415935208d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.4664287050829722d+00 b = 0.1921844459223610d+00 v = 0.3435847568549328d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.5078458493735726d+00 b = 0.2321360989678303d+00 v = 0.3495786831622488d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.5473779816204180d+00 b = 0.2715886486360520d+00 v = 0.3537767805534621d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.5848617133811376d+00 b = 0.3101924707571355d+00 v = 0.3564459815421428d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.6201348281584888d+00 b = 0.3476121052890973d+00 v = 0.3578464061225468d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.3852191185387871d+00 b = 0.3763224880035108d-01 v = 0.3239748762836212d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.4325025061073423d+00 b = 0.7659581935637135d-01 v = 0.3345491784174287d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.4778486229734490d+00 b = 0.1163381306083900d+00 v = 0.3429126177301782d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.5211663693009000d+00 b = 0.1563890598752899d+00 v = 0.3492420343097421d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.5623469504853703d+00 b = 0.1963320810149200d+00 v = 0.3537399050235257d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.6012718188659246d+00 b = 0.2357847407258738d+00 v = 0.3566209152659172d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.6378179206390117d+00 b = 0.2743846121244060d+00 v = 0.3581084321919782d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.4836936460214534d+00 b = 0.3895902610739024d-01 v = 0.3426522117591512d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.5293792562683797d+00 b = 0.7871246819312640d-01 v = 0.3491848770121379d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.5726281253100033d+00 b = 0.1187963808202981d+00 v = 0.3539318235231476d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.6133658776169068d+00 b = 0.1587914708061787d+00 v = 0.3570231438458694d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.6515085491865307d+00 b = 0.1983058575227646d+00 v = 0.3586207335051714d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.5778692716064976d+00 b = 0.3977209689791542d-01 v = 0.3541196205164025d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.6207904288086192d+00 b = 0.7990157592981152d-01 v = 0.3574296911573953d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.6608688171046802d+00 b = 0.1199671308754309d+00 v = 0.3591993279818963d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.6656263089489130d+00 b = 0.4015955957805969d-01 v = 0.3595855034661997d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) n = n - 1 end subroutine subroutine ld3470 ( x , y , z , w , n ) real ( kind = dp ) :: x ( * ) real ( kind = dp ) :: y ( * ) real ( kind = dp ) :: z ( * ) real ( kind = dp ) :: w ( * ) integer :: n real ( kind = dp ) :: a , b , v ! !      LEBEDEV 3470-POINT ANGULAR GRID ! !      This routine is part of a set of routines that generate !      Lebedev grids [1-6] for integration on a sphere. The original !      C-code [1] was kindly provided by Dr. Dmitri N. Laikov and !      translated into Fortran by Dr. Christoph van Wüllen. !      This routine was translated using a C to Fortran77 conversion !      tool written by Dr. Christoph van Wüllen. ! !      Users of this code are asked to include reference [1] in their !      publications, and in the user and programmer manuals !      describing their codes. ! !      This code was distributed through CCL (http://www.ccl.net/). ! !      References: ! !      [1] V.I. Lebedev and D.N. Laikov, !          \"A Quadrature Formula for the Sphere of the 131st !          Algebraic Order of Accuracy,\" !          Doklady Mathematics, Vol. 59, No. 3, 1999, pp. 477-481. ! !      [2] V.I. Lebedev, !          \"A Quadrature Formula for the Sphere of 59th Algebraic !          Order of Accuracy,\" !          Russian Acad. Sci. Dokl. Math., Vol. 50, 1995, pp. 283-286. ! !      [3] V.I. Lebedev and A.L. Skorokhodov, !          \"Quadrature Formulas of Orders 41, 47, and 53 for the Sphere,\" !          Russian Acad. Sci. Dokl. Math., Vol. 45, 1992, pp. 587-592. ! !      [4] V.I. Lebedev, !          \"Spherical Quadrature Formulas Exact to Orders 25-29,\" !          Siberian Mathematical Journal, Vol. 18, 1977, pp. 99-107. ! !      [5] V.I. Lebedev, !          \"Quadratures on a Sphere,\" !          Computational Mathematics and Mathematical Physics, Vol. 16, !          1976, pp. 10-24. ! !      [6] V.I. Lebedev, !          \"Values of the Nodes and Weights of Ninth to Seventeenth !          Order Gauss-Markov Quadrature Formulae Invariant under the !          Octahedron Group with Inversion,\" !          Computational Mathematics and Mathematical Physics, Vol. 15, !          1975, pp. 44-51. ! n = 1 v = 0.2040382730826330d-04 call gen_oh ( 1 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) v = 0.3178149703889544d-03 call gen_oh ( 3 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.1721420832906233d-01 v = 0.8288115128076110d-04 call gen_oh ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.4408875374981770d-01 v = 0.1360883192522954d-03 call gen_oh ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.7594680813878681d-01 v = 0.1766854454542662d-03 call gen_oh ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.1108335359204799d+00 v = 0.2083153161230153d-03 call gen_oh ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.1476517054388567d+00 v = 0.2333279544657158d-03 call gen_oh ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.1856731870860615d+00 v = 0.2532809539930247d-03 call gen_oh ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.2243634099428821d+00 v = 0.2692472184211158d-03 call gen_oh ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.2633006881662727d+00 v = 0.2819949946811885d-03 call gen_oh ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.3021340904916283d+00 v = 0.2920953593973030d-03 call gen_oh ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.3405594048030089d+00 v = 0.2999889782948352d-03 call gen_oh ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.3783044434007372d+00 v = 0.3060292120496902d-03 call gen_oh ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.4151194767407910d+00 v = 0.3105109167522192d-03 call gen_oh ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.4507705766443257d+00 v = 0.3136902387550312d-03 call gen_oh ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.4850346056573187d+00 v = 0.3157984652454632d-03 call gen_oh ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.5176950817792470d+00 v = 0.3170516518425422d-03 call gen_oh ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.5485384240820989d+00 v = 0.3176568425633755d-03 call gen_oh ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.6039117238943308d+00 v = 0.3177198411207062d-03 call gen_oh ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.6279956655573113d+00 v = 0.3175519492394733d-03 call gen_oh ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.6493636169568952d+00 v = 0.3174654952634756d-03 call gen_oh ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.6677644117704504d+00 v = 0.3175676415467654d-03 call gen_oh ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.6829368572115624d+00 v = 0.3178923417835410d-03 call gen_oh ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.6946195818184121d+00 v = 0.3183788287531909d-03 call gen_oh ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.7025711542057026d+00 v = 0.3188755151918807d-03 call gen_oh ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.7066004767140119d+00 v = 0.3191916889313849d-03 call gen_oh ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.5132537689946062d-01 v = 0.1231779611744508d-03 call gen_oh ( 5 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.1297994661331225d+00 v = 0.1924661373839880d-03 call gen_oh ( 5 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.2188852049401307d+00 v = 0.2380881867403424d-03 call gen_oh ( 5 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.3123174824903457d+00 v = 0.2693100663037885d-03 call gen_oh ( 5 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.4064037620738195d+00 v = 0.2908673382834366d-03 call gen_oh ( 5 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.4984958396944782d+00 v = 0.3053914619381535d-03 call gen_oh ( 5 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.5864975046021365d+00 v = 0.3143916684147777d-03 call gen_oh ( 5 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.6686711634580175d+00 v = 0.3187042244055363d-03 call gen_oh ( 5 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.8715738780835950d-01 b = 0.2557175233367578d-01 v = 0.1635219535869790d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.1248383123134007d+00 b = 0.5604823383376681d-01 v = 0.1968109917696070d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.1638062693383378d+00 b = 0.8968568601900765d-01 v = 0.2236754342249974d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.2035586203373176d+00 b = 0.1254086651976279d+00 v = 0.2453186687017181d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.2436798975293774d+00 b = 0.1624780150162012d+00 v = 0.2627551791580541d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.2838207507773806d+00 b = 0.2003422342683208d+00 v = 0.2767654860152220d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.3236787502217692d+00 b = 0.2385628026255263d+00 v = 0.2879467027765895d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.3629849554840691d+00 b = 0.2767731148783578d+00 v = 0.2967639918918702d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.4014948081992087d+00 b = 0.3146542308245309d+00 v = 0.3035900684660351d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.4389818379260225d+00 b = 0.3519196415895088d+00 v = 0.3087338237298308d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.4752331143674377d+00 b = 0.3883050984023654d+00 v = 0.3124608838860167d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.5100457318374018d+00 b = 0.4235613423908649d+00 v = 0.3150084294226743d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.5432238388954868d+00 b = 0.4574484717196220d+00 v = 0.3165958398598402d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.5745758685072442d+00 b = 0.4897311639255524d+00 v = 0.3174320440957372d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.1723981437592809d+00 b = 0.3010630597881105d-01 v = 0.2182188909812599d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.2149553257844597d+00 b = 0.6326031554204694d-01 v = 0.2399727933921445d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.2573256081247422d+00 b = 0.9848566980258631d-01 v = 0.2579796133514652d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.2993163751238106d+00 b = 0.1350835952384266d+00 v = 0.2727114052623535d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.3407238005148000d+00 b = 0.1725184055442181d+00 v = 0.2846327656281355d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.3813454978483264d+00 b = 0.2103559279730725d+00 v = 0.2941491102051334d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.4209848104423343d+00 b = 0.2482278774554860d+00 v = 0.3016049492136107d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.4594519699996300d+00 b = 0.2858099509982883d+00 v = 0.3072949726175648d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.4965640166185930d+00 b = 0.3228075659915428d+00 v = 0.3114768142886460d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.5321441655571562d+00 b = 0.3589459907204151d+00 v = 0.3143823673666223d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.5660208438582166d+00 b = 0.3939630088864310d+00 v = 0.3162269764661535d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.5980264315964364d+00 b = 0.4276029922949089d+00 v = 0.3172164663759821d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.2644215852350733d+00 b = 0.3300939429072552d-01 v = 0.2554575398967435d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.3090113743443063d+00 b = 0.6803887650078501d-01 v = 0.2701704069135677d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.3525871079197808d+00 b = 0.1044326136206709d+00 v = 0.2823693413468940d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.3950418005354029d+00 b = 0.1416751597517679d+00 v = 0.2922898463214289d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.4362475663430163d+00 b = 0.1793408610504821d+00 v = 0.3001829062162428d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.4760661812145854d+00 b = 0.2170630750175722d+00 v = 0.3062890864542953d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.5143551042512103d+00 b = 0.2545145157815807d+00 v = 0.3108328279264746d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.5509709026935597d+00 b = 0.2913940101706601d+00 v = 0.3140243146201245d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.5857711030329428d+00 b = 0.3274169910910705d+00 v = 0.3160638030977130d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.6186149917404392d+00 b = 0.3623081329317265d+00 v = 0.3171462882206275d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.3586894569557064d+00 b = 0.3497354386450040d-01 v = 0.2812388416031796d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.4035266610019441d+00 b = 0.7129736739757095d-01 v = 0.2912137500288045d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.4467775312332510d+00 b = 0.1084758620193165d+00 v = 0.2993241256502206d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.4883638346608543d+00 b = 0.1460915689241772d+00 v = 0.3057101738983822d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.5281908348434601d+00 b = 0.1837790832369980d+00 v = 0.3105319326251432d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.5661542687149311d+00 b = 0.2212075390874021d+00 v = 0.3139565514428167d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.6021450102031452d+00 b = 0.2580682841160985d+00 v = 0.3161543006806366d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.6360520783610050d+00 b = 0.2940656362094121d+00 v = 0.3172985960613294d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.4521611065087196d+00 b = 0.3631055365867002d-01 v = 0.2989400336901431d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.4959365651560963d+00 b = 0.7348318468484350d-01 v = 0.3054555883947677d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.5376815804038283d+00 b = 0.1111087643812648d+00 v = 0.3104764960807702d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.5773314480243768d+00 b = 0.1488226085145408d+00 v = 0.3141015825977616d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.6148113245575056d+00 b = 0.1862892274135151d+00 v = 0.3164520621159896d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.6500407462842380d+00 b = 0.2231909701714456d+00 v = 0.3176652305912204d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.5425151448707213d+00 b = 0.3718201306118944d-01 v = 0.3105097161023939d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.5841860556907931d+00 b = 0.7483616335067346d-01 v = 0.3143014117890550d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.6234632186851500d+00 b = 0.1125990834266120d+00 v = 0.3168172866287200d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.6602934551848843d+00 b = 0.1501303813157619d+00 v = 0.3181401865570968d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.6278573968375105d+00 b = 0.3767559930245720d-01 v = 0.3170663659156037d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.6665611711264577d+00 b = 0.7548443301360158d-01 v = 0.3185447944625510d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) n = n - 1 end subroutine subroutine ld3890 ( x , y , z , w , n ) real ( kind = dp ) :: x ( * ) real ( kind = dp ) :: y ( * ) real ( kind = dp ) :: z ( * ) real ( kind = dp ) :: w ( * ) integer :: n real ( kind = dp ) :: a , b , v ! !      LEBEDEV 3890-POINT ANGULAR GRID ! ! !      THIS ROUTINE IS PART OF A SET OF ROUTINES THAT GENERATE !      LEBEDEV GRIDS [1-6] FOR INTEGRATION ON A SPHERE. THE ORIGINAL !      C-CODE [1] WAS KINDLY PROVIDED BY DR. DMITRI N. LAIKOV AND !      TRANSLATED INTO FORTRAN BY DR. CHRISTOPH VAN WUELLEN. !      THIS ROUTINE WAS TRANSLATED USING A C TO FORTRAN77 CONVERSION !      TOOL WRITTEN BY DR. CHRISTOPH VAN WUELLEN. ! !      USERS OF THIS CODE ARE ASKED TO INCLUDE REFERENCE [1] IN THEIR !      PUBLICATIONS, AND IN THE USER- AND PROGRAMMERS-MANUALS !      DESCRIBING THEIR CODES. ! !      THIS CODE WAS DISTRIBUTED THROUGH CCL (HTTP://WWW.CCL.NET/). ! !      [1] V.I. LEBEDEV, AND D.N. LAIKOV !          \"A QUADRATURE FORMULA FOR THE SPHERE OF THE 131ST !           ALGEBRAIC ORDER OF ACCURACY\" !          DOKLADY MATHEMATICS, VOL. 59, NO. 3, 1999, PP. 477-481. ! !      [2] V.I. LEBEDEV !          \"A QUADRATURE FORMULA FOR THE SPHERE OF 59TH ALGEBRAIC !           ORDER OF ACCURACY\" !          RUSSIAN ACAD. SCI. DOKL. MATH., VOL. 50, 1995, PP. 283-286. ! !      [3] V.I. LEBEDEV, AND A.L. SKOROKHODOV !          \"QUADRATURE FORMULAS OF ORDERS 41, 47, AND 53 FOR THE SPHERE\" !          RUSSIAN ACAD. SCI. DOKL. MATH., VOL. 45, 1992, PP. 587-592. ! !      [4] V.I. LEBEDEV !          \"SPHERICAL QUADRATURE FORMULAS EXACT TO ORDERS 25-29\" !          SIBERIAN MATHEMATICAL JOURNAL, VOL. 18, 1977, PP. 99-107. ! !      [5] V.I. LEBEDEV !          \"QUADRATURES ON A SPHERE\" !          COMPUTATIONAL MATHEMATICS AND MATHEMATICAL PHYSICS, VOL. 16, !          1976, PP. 10-24. ! !      [6] V.I. LEBEDEV !          \"VALUES OF THE NODES AND WEIGHTS OF NINTH TO SEVENTEENTH !           ORDER GAUSS-MARKOV QUADRATURE FORMULAE INVARIANT UNDER THE !           OCTAHEDRON GROUP WITH INVERSION\" !          COMPUTATIONAL MATHEMATICS AND MATHEMATICAL PHYSICS, VOL. 15, !          1975, PP. 44-51. ! n = 1 v = 0.1807395252196920d-04 call gen_oh ( 1 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) v = 0.2848008782238827d-03 call gen_oh ( 2 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) v = 0.2836065837530581d-03 call gen_oh ( 3 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.1587876419858352d-01 v = 0.7013149266673816d-04 call gen_oh ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.4069193593751206d-01 v = 0.1162798021956766d-03 call gen_oh ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.7025888115257997d-01 v = 0.1518728583972105d-03 call gen_oh ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.1027495450028704d+00 v = 0.1798796108216934d-03 call gen_oh ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.1371457730893426d+00 v = 0.2022593385972785d-03 call gen_oh ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.1727758532671953d+00 v = 0.2203093105575464d-03 call gen_oh ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.2091492038929037d+00 v = 0.2349294234299855d-03 call gen_oh ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.2458813281751915d+00 v = 0.2467682058747003d-03 call gen_oh ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.2826545859450066d+00 v = 0.2563092683572224d-03 call gen_oh ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.3191957291799622d+00 v = 0.2639253896763318d-03 call gen_oh ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.3552621469299578d+00 v = 0.2699137479265108d-03 call gen_oh ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.3906329503406230d+00 v = 0.2745196420166739d-03 call gen_oh ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.4251028614093031d+00 v = 0.2779529197397593d-03 call gen_oh ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.4584777520111870d+00 v = 0.2803996086684265d-03 call gen_oh ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.4905711358710193d+00 v = 0.2820302356715842d-03 call gen_oh ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.5212011669847385d+00 v = 0.2830056747491068d-03 call gen_oh ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.5501878488737995d+00 v = 0.2834808950776839d-03 call gen_oh ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.6025037877479342d+00 v = 0.2835282339078929d-03 call gen_oh ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.6254572689549016d+00 v = 0.2833819267065800d-03 call gen_oh ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.6460107179528248d+00 v = 0.2832858336906784d-03 call gen_oh ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.6639541138154251d+00 v = 0.2833268235451244d-03 call gen_oh ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.6790688515667495d+00 v = 0.2835432677029253d-03 call gen_oh ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.6911338580371512d+00 v = 0.2839091722743049d-03 call gen_oh ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.6999385956126490d+00 v = 0.2843308178875841d-03 call gen_oh ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.7053037748656896d+00 v = 0.2846703550533846d-03 call gen_oh ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.4732224387180115d-01 v = 0.1051193406971900d-03 call gen_oh ( 5 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.1202100529326803d+00 v = 0.1657871838796974d-03 call gen_oh ( 5 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.2034304820664855d+00 v = 0.2064648113714232d-03 call gen_oh ( 5 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.2912285643573002d+00 v = 0.2347942745819741d-03 call gen_oh ( 5 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.3802361792726768d+00 v = 0.2547775326597726d-03 call gen_oh ( 5 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.4680598511056146d+00 v = 0.2686876684847025d-03 call gen_oh ( 5 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.5528151052155599d+00 v = 0.2778665755515867d-03 call gen_oh ( 5 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.6329386307803041d+00 v = 0.2830996616782929d-03 call gen_oh ( 5 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.8056516651369069d-01 b = 0.2363454684003124d-01 v = 0.1403063340168372d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.1156476077139389d+00 b = 0.5191291632545936d-01 v = 0.1696504125939477d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.1520473382760421d+00 b = 0.8322715736994519d-01 v = 0.1935787242745390d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.1892986699745931d+00 b = 0.1165855667993712d+00 v = 0.2130614510521968d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.2270194446777792d+00 b = 0.1513077167409504d+00 v = 0.2289381265931048d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.2648908185093273d+00 b = 0.1868882025807859d+00 v = 0.2418630292816186d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.3026389259574136d+00 b = 0.2229277629776224d+00 v = 0.2523400495631193d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.3400220296151384d+00 b = 0.2590951840746235d+00 v = 0.2607623973449605d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.3768217953335510d+00 b = 0.2951047291750847d+00 v = 0.2674441032689209d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.4128372900921884d+00 b = 0.3307019714169930d+00 v = 0.2726432360343356d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.4478807131815630d+00 b = 0.3656544101087634d+00 v = 0.2765787685924545d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.4817742034089257d+00 b = 0.3997448951939695d+00 v = 0.2794428690642224d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.5143472814653344d+00 b = 0.4327667110812024d+00 v = 0.2814099002062895d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.5454346213905650d+00 b = 0.4645196123532293d+00 v = 0.2826429531578994d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.5748739313170252d+00 b = 0.4948063555703345d+00 v = 0.2832983542550884d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.1599598738286342d+00 b = 0.2792357590048985d-01 v = 0.1886695565284976d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.1998097412500951d+00 b = 0.5877141038139065d-01 v = 0.2081867882748234d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.2396228952566202d+00 b = 0.9164573914691377d-01 v = 0.2245148680600796d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.2792228341097746d+00 b = 0.1259049641962687d+00 v = 0.2380370491511872d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.3184251107546741d+00 b = 0.1610594823400863d+00 v = 0.2491398041852455d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.3570481164426244d+00 b = 0.1967151653460898d+00 v = 0.2581632405881230d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.3949164710492144d+00 b = 0.2325404606175168d+00 v = 0.2653965506227417d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.4318617293970503d+00 b = 0.2682461141151439d+00 v = 0.2710857216747087d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.4677221009931678d+00 b = 0.3035720116011973d+00 v = 0.2754434093903659d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.5023417939270955d+00 b = 0.3382781859197439d+00 v = 0.2786579932519380d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.5355701836636128d+00 b = 0.3721383065625942d+00 v = 0.2809011080679474d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.5672608451328771d+00 b = 0.4049346360466055d+00 v = 0.2823336184560987d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.5972704202540162d+00 b = 0.4364538098633802d+00 v = 0.2831101175806309d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.2461687022333596d+00 b = 0.3070423166833368d-01 v = 0.2221679970354546d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.2881774566286831d+00 b = 0.6338034669281885d-01 v = 0.2356185734270703d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.3293963604116978d+00 b = 0.9742862487067941d-01 v = 0.2469228344805590d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.3697303822241377d+00 b = 0.1323799532282290d+00 v = 0.2562726348642046d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.4090663023135127d+00 b = 0.1678497018129336d+00 v = 0.2638756726753028d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.4472819355411712d+00 b = 0.2035095105326114d+00 v = 0.2699311157390862d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.4842513377231437d+00 b = 0.2390692566672091d+00 v = 0.2746233268403837d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.5198477629962928d+00 b = 0.2742649818076149d+00 v = 0.2781225674454771d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.5539453011883145d+00 b = 0.3088503806580094d+00 v = 0.2805881254045684d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.5864196762401251d+00 b = 0.3425904245906614d+00 v = 0.2821719877004913d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.6171484466668390d+00 b = 0.3752562294789468d+00 v = 0.2830222502333124d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.3350337830565727d+00 b = 0.3261589934634747d-01 v = 0.2457995956744870d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.3775773224758284d+00 b = 0.6658438928081572d-01 v = 0.2551474407503706d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.4188155229848973d+00 b = 0.1014565797157954d+00 v = 0.2629065335195311d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.4586805892009344d+00 b = 0.1368573320843822d+00 v = 0.2691900449925075d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.4970895714224235d+00 b = 0.1724614851951608d+00 v = 0.2741275485754276d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.5339505133960747d+00 b = 0.2079779381416412d+00 v = 0.2778530970122595d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.5691665792531440d+00 b = 0.2431385788322288d+00 v = 0.2805010567646741d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.6026387682680377d+00 b = 0.2776901883049853d+00 v = 0.2822055834031040d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.6342676150163307d+00 b = 0.3113881356386632d+00 v = 0.2831016901243473d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.4237951119537067d+00 b = 0.3394877848664351d-01 v = 0.2624474901131803d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.4656918683234929d+00 b = 0.6880219556291447d-01 v = 0.2688034163039377d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.5058857069185980d+00 b = 0.1041946859721635d+00 v = 0.2738932751287636d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.5443204666713996d+00 b = 0.1398039738736393d+00 v = 0.2777944791242523d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.5809298813759742d+00 b = 0.1753373381196155d+00 v = 0.2806011661660987d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.6156416039447128d+00 b = 0.2105215793514010d+00 v = 0.2824181456597460d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.6483801351066604d+00 b = 0.2450953312157051d+00 v = 0.2833585216577828d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.5103616577251688d+00 b = 0.3485560643800719d-01 v = 0.2738165236962878d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.5506738792580681d+00 b = 0.7026308631512033d-01 v = 0.2778365208203180d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.5889573040995292d+00 b = 0.1059035061296403d+00 v = 0.2807852940418966d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.6251641589516930d+00 b = 0.1414823925236026d+00 v = 0.2827245949674705d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.6592414921570178d+00 b = 0.1767207908214530d+00 v = 0.2837342344829828d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.5930314017533384d+00 b = 0.3542189339561672d-01 v = 0.2809233907610981d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.6309812253390175d+00 b = 0.7109574040369549d-01 v = 0.2829930809742694d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.6666296011353230d+00 b = 0.1067259792282730d+00 v = 0.2841097874111479d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.6703715271049922d+00 b = 0.3569455268820809d-01 v = 0.2843455206008783d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) n = n - 1 end subroutine subroutine ld4334 ( x , y , z , w , n ) real ( kind = dp ) :: x ( * ) real ( kind = dp ) :: y ( * ) real ( kind = dp ) :: z ( * ) real ( kind = dp ) :: w ( * ) integer :: n real ( kind = dp ) :: a , b , v ! !      LEBEDEV 4334-POINT ANGULAR GRID ! ! !      THIS ROUTINE IS PART OF A SET OF ROUTINES THAT GENERATE !      LEBEDEV GRIDS [1-6] FOR INTEGRATION ON A SPHERE. THE ORIGINAL !      C-CODE [1] WAS KINDLY PROVIDED BY DR. DMITRI N. LAIKOV AND !      TRANSLATED INTO FORTRAN BY DR. CHRISTOPH VAN WUELLEN. !      THIS ROUTINE WAS TRANSLATED USING A C TO FORTRAN77 CONVERSION !      TOOL WRITTEN BY DR. CHRISTOPH VAN WUELLEN. ! !      USERS OF THIS CODE ARE ASKED TO INCLUDE REFERENCE [1] IN THEIR !      PUBLICATIONS, AND IN THE USER- AND PROGRAMMERS-MANUALS !      DESCRIBING THEIR CODES. ! !      THIS CODE WAS DISTRIBUTED THROUGH CCL (HTTP://WWW.CCL.NET/). ! !      [1] V.I. LEBEDEV, AND D.N. LAIKOV !          \"A QUADRATURE FORMULA FOR THE SPHERE OF THE 131ST !           ALGEBRAIC ORDER OF ACCURACY\" !          DOKLADY MATHEMATICS, VOL. 59, NO. 3, 1999, PP. 477-481. ! !      [2] V.I. LEBEDEV !          \"A QUADRATURE FORMULA FOR THE SPHERE OF 59TH ALGEBRAIC !           ORDER OF ACCURACY\" !          RUSSIAN ACAD. SCI. DOKL. MATH., VOL. 50, 1995, PP. 283-286. ! !      [3] V.I. LEBEDEV, AND A.L. SKOROKHODOV !          \"QUADRATURE FORMULAS OF ORDERS 41, 47, AND 53 FOR THE SPHERE\" !          RUSSIAN ACAD. SCI. DOKL. MATH., VOL. 45, 1992, PP. 587-592. ! !      [4] V.I. LEBEDEV !          \"SPHERICAL QUADRATURE FORMULAS EXACT TO ORDERS 25-29\" !          SIBERIAN MATHEMATICAL JOURNAL, VOL. 18, 1977, PP. 99-107. ! !      [5] V.I. LEBEDEV !          \"QUADRATURES ON A SPHERE\" !          COMPUTATIONAL MATHEMATICS AND MATHEMATICAL PHYSICS, VOL. 16, !          1976, PP. 10-24. ! !      [6] V.I. LEBEDEV !          \"VALUES OF THE NODES AND WEIGHTS OF NINTH TO SEVENTEENTH !           ORDER GAUSS-MARKOV QUADRATURE FORMULAE INVARIANT UNDER THE !           OCTAHEDRON GROUP WITH INVERSION\" !          COMPUTATIONAL MATHEMATICS AND MATHEMATICAL PHYSICS, VOL. 15, !          1975, PP. 44-51. ! n = 1 v = 0.1449063022537883d-04 call gen_oh ( 1 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) v = 0.2546377329828424d-03 call gen_oh ( 3 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.1462896151831013d-01 v = 0.6018432961087496d-04 call gen_oh ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.3769840812493139d-01 v = 0.1002286583263673d-03 call gen_oh ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.6524701904096891d-01 v = 0.1315222931028093d-03 call gen_oh ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.9560543416134648d-01 v = 0.1564213746876724d-03 call gen_oh ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.1278335898929198d+00 v = 0.1765118841507736d-03 call gen_oh ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.1613096104466031d+00 v = 0.1928737099311080d-03 call gen_oh ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.1955806225745371d+00 v = 0.2062658534263270d-03 call gen_oh ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.2302935218498028d+00 v = 0.2172395445953787d-03 call gen_oh ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.2651584344113027d+00 v = 0.2262076188876047d-03 call gen_oh ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.2999276825183209d+00 v = 0.2334885699462397d-03 call gen_oh ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.3343828669718798d+00 v = 0.2393355273179203d-03 call gen_oh ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.3683265013750518d+00 v = 0.2439559200468863d-03 call gen_oh ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.4015763206518108d+00 v = 0.2475251866060002d-03 call gen_oh ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.4339612026399770d+00 v = 0.2501965558158773d-03 call gen_oh ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.4653180651114582d+00 v = 0.2521081407925925d-03 call gen_oh ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.4954893331080803d+00 v = 0.2533881002388081d-03 call gen_oh ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.5243207068924930d+00 v = 0.2541582900848261d-03 call gen_oh ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.5516590479041704d+00 v = 0.2545365737525860d-03 call gen_oh ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.6012371927804176d+00 v = 0.2545726993066799d-03 call gen_oh ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.6231574466449819d+00 v = 0.2544456197465555d-03 call gen_oh ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.6429416514181271d+00 v = 0.2543481596881064d-03 call gen_oh ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.6604124272943595d+00 v = 0.2543506451429194d-03 call gen_oh ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.6753851470408250d+00 v = 0.2544905675493763d-03 call gen_oh ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.6876717970626160d+00 v = 0.2547611407344429d-03 call gen_oh ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.6970895061319234d+00 v = 0.2551060375448869d-03 call gen_oh ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.7034746912553310d+00 v = 0.2554291933816039d-03 call gen_oh ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.7067017217542295d+00 v = 0.2556255710686343d-03 call gen_oh ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.4382223501131123d-01 v = 0.9041339695118195d-04 call gen_oh ( 5 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.1117474077400006d+00 v = 0.1438426330079022d-03 call gen_oh ( 5 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.1897153252911440d+00 v = 0.1802523089820518d-03 call gen_oh ( 5 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.2724023009910331d+00 v = 0.2060052290565496d-03 call gen_oh ( 5 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.3567163308709902d+00 v = 0.2245002248967466d-03 call gen_oh ( 5 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.4404784483028087d+00 v = 0.2377059847731150d-03 call gen_oh ( 5 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.5219833154161411d+00 v = 0.2468118955882525d-03 call gen_oh ( 5 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.5998179868977553d+00 v = 0.2525410872966528d-03 call gen_oh ( 5 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.6727803154548222d+00 v = 0.2553101409933397d-03 call gen_oh ( 5 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.7476563943166086d-01 b = 0.2193168509461185d-01 v = 0.1212879733668632d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.1075341482001416d+00 b = 0.4826419281533887d-01 v = 0.1472872881270931d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.1416344885203259d+00 b = 0.7751191883575742d-01 v = 0.1686846601010828d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.1766325315388586d+00 b = 0.1087558139247680d+00 v = 0.1862698414660208d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.2121744174481514d+00 b = 0.1413661374253096d+00 v = 0.2007430956991861d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.2479669443408145d+00 b = 0.1748768214258880d+00 v = 0.2126568125394796d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.2837600452294113d+00 b = 0.2089216406612073d+00 v = 0.2224394603372113d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.3193344933193984d+00 b = 0.2431987685545972d+00 v = 0.2304264522673135d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.3544935442438745d+00 b = 0.2774497054377770d+00 v = 0.2368854288424087d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.3890571932288154d+00 b = 0.3114460356156915d+00 v = 0.2420352089461772d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.4228581214259090d+00 b = 0.3449806851913012d+00 v = 0.2460597113081295d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.4557387211304052d+00 b = 0.3778618641248256d+00 v = 0.2491181912257687d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.4875487950541643d+00 b = 0.4099086391698978d+00 v = 0.2513528194205857d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.5181436529962997d+00 b = 0.4409474925853973d+00 v = 0.2528943096693220d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.5473824095600661d+00 b = 0.4708094517711291d+00 v = 0.2538660368488136d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.5751263398976174d+00 b = 0.4993275140354637d+00 v = 0.2543868648299022d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.1489515746840028d+00 b = 0.2599381993267017d-01 v = 0.1642595537825183d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.1863656444351767d+00 b = 0.5479286532462190d-01 v = 0.1818246659849308d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.2238602880356348d+00 b = 0.8556763251425254d-01 v = 0.1966565649492420d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.2612723375728160d+00 b = 0.1177257802267011d+00 v = 0.2090677905657991d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.2984332990206190d+00 b = 0.1508168456192700d+00 v = 0.2193820409510504d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.3351786584663333d+00 b = 0.1844801892177727d+00 v = 0.2278870827661928d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.3713505522209120d+00 b = 0.2184145236087598d+00 v = 0.2348283192282090d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.4067981098954663d+00 b = 0.2523590641486229d+00 v = 0.2404139755581477d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.4413769993687534d+00 b = 0.2860812976901373d+00 v = 0.2448227407760734d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.4749487182516394d+00 b = 0.3193686757808996d+00 v = 0.2482110455592573d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.5073798105075426d+00 b = 0.3520226949547602d+00 v = 0.2507192397774103d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.5385410448878654d+00 b = 0.3838544395667890d+00 v = 0.2524765968534880d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.5683065353670530d+00 b = 0.4146810037640963d+00 v = 0.2536052388539425d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.5965527620663510d+00 b = 0.4443224094681121d+00 v = 0.2542230588033068d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.2299227700856157d+00 b = 0.2865757664057584d-01 v = 0.1944817013047896d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.2695752998553267d+00 b = 0.5923421684485993d-01 v = 0.2067862362746635d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.3086178716611389d+00 b = 0.9117817776057715d-01 v = 0.2172440734649114d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.3469649871659077d+00 b = 0.1240593814082605d+00 v = 0.2260125991723423d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.3845153566319655d+00 b = 0.1575272058259175d+00 v = 0.2332655008689523d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.4211600033403215d+00 b = 0.1912845163525413d+00 v = 0.2391699681532458d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.4567867834329882d+00 b = 0.2250710177858171d+00 v = 0.2438801528273928d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.4912829319232061d+00 b = 0.2586521303440910d+00 v = 0.2475370504260665d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.5245364793303812d+00 b = 0.2918112242865407d+00 v = 0.2502707235640574d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.5564369788915756d+00 b = 0.3243439239067890d+00 v = 0.2522031701054241d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.5868757697775287d+00 b = 0.3560536787835351d+00 v = 0.2534511269978784d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.6157458853519617d+00 b = 0.3867480821242581d+00 v = 0.2541284914955151d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.3138461110672113d+00 b = 0.3051374637507278d-01 v = 0.2161509250688394d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.3542495872050569d+00 b = 0.6237111233730755d-01 v = 0.2248778513437852d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.3935751553120181d+00 b = 0.9516223952401907d-01 v = 0.2322388803404617d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.4317634668111147d+00 b = 0.1285467341508517d+00 v = 0.2383265471001355d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.4687413842250821d+00 b = 0.1622318931656033d+00 v = 0.2432476675019525d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.5044274237060283d+00 b = 0.1959581153836453d+00 v = 0.2471122223750674d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.5387354077925727d+00 b = 0.2294888081183837d+00 v = 0.2500291752486870d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.5715768898356105d+00 b = 0.2626031152713945d+00 v = 0.2521055942764682d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.6028627200136111d+00 b = 0.2950904075286713d+00 v = 0.2534472785575503d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.6325039812653463d+00 b = 0.3267458451113286d+00 v = 0.2541599713080121d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.3981986708423407d+00 b = 0.3183291458749821d-01 v = 0.2317380975862936d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.4382791182133300d+00 b = 0.6459548193880908d-01 v = 0.2378550733719775d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.4769233057218166d+00 b = 0.9795757037087952d-01 v = 0.2428884456739118d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.5140823911194238d+00 b = 0.1316307235126655d+00 v = 0.2469002655757292d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.5496977833862983d+00 b = 0.1653556486358704d+00 v = 0.2499657574265851d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.5837047306512727d+00 b = 0.1988931724126510d+00 v = 0.2521676168486082d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.6160349566926879d+00 b = 0.2320174581438950d+00 v = 0.2535935662645334d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.6466185353209440d+00 b = 0.2645106562168662d+00 v = 0.2543356743363214d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.4810835158795404d+00 b = 0.3275917807743992d-01 v = 0.2427353285201535d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.5199925041324341d+00 b = 0.6612546183967181d-01 v = 0.2468258039744386d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.5571717692207494d+00 b = 0.9981498331474143d-01 v = 0.2500060956440310d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.5925789250836378d+00 b = 0.1335687001410374d+00 v = 0.2523238365420979d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.6261658523859670d+00 b = 0.1671444402896463d+00 v = 0.2538399260252846d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.6578811126669331d+00 b = 0.2003106382156076d+00 v = 0.2546255927268069d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.5609624612998100d+00 b = 0.3337500940231335d-01 v = 0.2500583360048449d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.5979959659984670d+00 b = 0.6708750335901803d-01 v = 0.2524777638260203d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.6330523711054002d+00 b = 0.1008792126424850d+00 v = 0.2540951193860656d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.6660960998103972d+00 b = 0.1345050343171794d+00 v = 0.2549524085027472d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.6365384364585819d+00 b = 0.3372799460737052d-01 v = 0.2542569507009158d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.6710994302899275d+00 b = 0.6755249309678028d-01 v = 0.2552114127580376d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) n = n - 1 end subroutine subroutine ld4802 ( x , y , z , w , n ) real ( kind = dp ) :: x ( * ) real ( kind = dp ) :: y ( * ) real ( kind = dp ) :: z ( * ) real ( kind = dp ) :: w ( * ) integer :: n real ( kind = dp ) :: a , b , v ! !      LEBEDEV 4802-POINT ANGULAR GRID ! ! !      THIS ROUTINE IS PART OF A SET OF ROUTINES THAT GENERATE !      LEBEDEV GRIDS [1-6] FOR INTEGRATION ON A SPHERE. THE ORIGINAL !      C-CODE [1] WAS KINDLY PROVIDED BY DR. DMITRI N. LAIKOV AND !      TRANSLATED INTO FORTRAN BY DR. CHRISTOPH VAN WUELLEN. !      THIS ROUTINE WAS TRANSLATED USING A C TO FORTRAN77 CONVERSION !      TOOL WRITTEN BY DR. CHRISTOPH VAN WUELLEN. ! !      USERS OF THIS CODE ARE ASKED TO INCLUDE REFERENCE [1] IN THEIR !      PUBLICATIONS, AND IN THE USER- AND PROGRAMMERS-MANUALS !      DESCRIBING THEIR CODES. ! !      THIS CODE WAS DISTRIBUTED THROUGH CCL (HTTP://WWW.CCL.NET/). ! !      [1] V.I. LEBEDEV, AND D.N. LAIKOV !          \"A QUADRATURE FORMULA FOR THE SPHERE OF THE 131ST !           ALGEBRAIC ORDER OF ACCURACY\" !          DOKLADY MATHEMATICS, VOL. 59, NO. 3, 1999, PP. 477-481. ! !      [2] V.I. LEBEDEV !          \"A QUADRATURE FORMULA FOR THE SPHERE OF 59TH ALGEBRAIC !           ORDER OF ACCURACY\" !          RUSSIAN ACAD. SCI. DOKL. MATH., VOL. 50, 1995, PP. 283-286. ! !      [3] V.I. LEBEDEV, AND A.L. SKOROKHODOV !          \"QUADRATURE FORMULAS OF ORDERS 41, 47, AND 53 FOR THE SPHERE\" !          RUSSIAN ACAD. SCI. DOKL. MATH., VOL. 45, 1992, PP. 587-592. ! !      [4] V.I. LEBEDEV !          \"SPHERICAL QUADRATURE FORMULAS EXACT TO ORDERS 25-29\" !          SIBERIAN MATHEMATICAL JOURNAL, VOL. 18, 1977, PP. 99-107. ! !      [5] V.I. LEBEDEV !          \"QUADRATURES ON A SPHERE\" !          COMPUTATIONAL MATHEMATICS AND MATHEMATICAL PHYSICS, VOL. 16, !          1976, PP. 10-24. ! !      [6] V.I. LEBEDEV !          \"VALUES OF THE NODES AND WEIGHTS OF NINTH TO SEVENTEENTH !           ORDER GAUSS-MARKOV QUADRATURE FORMULAE INVARIANT UNDER THE !           OCTAHEDRON GROUP WITH INVERSION\" !          COMPUTATIONAL MATHEMATICS AND MATHEMATICAL PHYSICS, VOL. 15, !          1975, PP. 44-51. ! n = 1 v = 0.9687521879420705d-04 call gen_oh ( 1 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) v = 0.2307897895367918d-03 call gen_oh ( 2 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) v = 0.2297310852498558d-03 call gen_oh ( 3 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.2335728608887064d-01 v = 0.7386265944001919d-04 call gen_oh ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.4352987836550653d-01 v = 0.8257977698542210d-04 call gen_oh ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.6439200521088801d-01 v = 0.9706044762057630d-04 call gen_oh ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.9003943631993181d-01 v = 0.1302393847117003d-03 call gen_oh ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.1196706615548473d+00 v = 0.1541957004600968d-03 call gen_oh ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.1511715412838134d+00 v = 0.1704459770092199d-03 call gen_oh ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.1835982828503801d+00 v = 0.1827374890942906d-03 call gen_oh ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.2165081259155405d+00 v = 0.1926360817436107d-03 call gen_oh ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.2496208720417563d+00 v = 0.2008010239494833d-03 call gen_oh ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.2827200673567900d+00 v = 0.2075635983209175d-03 call gen_oh ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.3156190823994346d+00 v = 0.2131306638690909d-03 call gen_oh ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.3481476793749115d+00 v = 0.2176562329937335d-03 call gen_oh ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.3801466086947226d+00 v = 0.2212682262991018d-03 call gen_oh ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.4114652119634011d+00 v = 0.2240799515668565d-03 call gen_oh ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.4419598786519751d+00 v = 0.2261959816187525d-03 call gen_oh ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.4714925949329543d+00 v = 0.2277156368808855d-03 call gen_oh ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.4999293972879466d+00 v = 0.2287351772128336d-03 call gen_oh ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.5271387221431248d+00 v = 0.2293490814084085d-03 call gen_oh ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.5529896780837761d+00 v = 0.2296505312376273d-03 call gen_oh ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.6000856099481712d+00 v = 0.2296793832318756d-03 call gen_oh ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.6210562192785175d+00 v = 0.2295785443842974d-03 call gen_oh ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.6401165879934240d+00 v = 0.2295017931529102d-03 call gen_oh ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.6571144029244334d+00 v = 0.2295059638184868d-03 call gen_oh ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.6718910821718863d+00 v = 0.2296232343237362d-03 call gen_oh ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.6842845591099010d+00 v = 0.2298530178740771d-03 call gen_oh ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.6941353476269816d+00 v = 0.2301579790280501d-03 call gen_oh ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.7012965242212991d+00 v = 0.2304690404996513d-03 call gen_oh ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.7056471428242644d+00 v = 0.2307027995907102d-03 call gen_oh ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.4595557643585895d-01 v = 0.9312274696671092d-04 call gen_oh ( 5 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.1049316742435023d+00 v = 0.1199919385876926d-03 call gen_oh ( 5 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.1773548879549274d+00 v = 0.1598039138877690d-03 call gen_oh ( 5 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.2559071411236127d+00 v = 0.1822253763574900d-03 call gen_oh ( 5 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.3358156837985898d+00 v = 0.1988579593655040d-03 call gen_oh ( 5 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.4155835743763893d+00 v = 0.2112620102533307d-03 call gen_oh ( 5 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.4937894296167472d+00 v = 0.2201594887699007d-03 call gen_oh ( 5 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.5691569694793316d+00 v = 0.2261622590895036d-03 call gen_oh ( 5 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.6405840854894251d+00 v = 0.2296458453435705d-03 call gen_oh ( 5 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.7345133894143348d-01 b = 0.2177844081486067d-01 v = 0.1006006990267000d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.1009859834044931d+00 b = 0.4590362185775188d-01 v = 0.1227676689635876d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.1324289619748758d+00 b = 0.7255063095690877d-01 v = 0.1467864280270117d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.1654272109607127d+00 b = 0.1017825451960684d+00 v = 0.1644178912101232d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.1990767186776461d+00 b = 0.1325652320980364d+00 v = 0.1777664890718961d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.2330125945523278d+00 b = 0.1642765374496765d+00 v = 0.1884825664516690d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.2670080611108287d+00 b = 0.1965360374337889d+00 v = 0.1973269246453848d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.3008753376294316d+00 b = 0.2290726770542238d+00 v = 0.2046767775855328d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.3344475596167860d+00 b = 0.2616645495370823d+00 v = 0.2107600125918040d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.3675709724070786d+00 b = 0.2941150728843141d+00 v = 0.2157416362266829d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.4001000887587812d+00 b = 0.3262440400919066d+00 v = 0.2197557816920721d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.4318956350436028d+00 b = 0.3578835350611916d+00 v = 0.2229192611835437d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.4628239056795531d+00 b = 0.3888751854043678d+00 v = 0.2253385110212775d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.4927563229773636d+00 b = 0.4190678003222840d+00 v = 0.2271137107548774d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.5215687136707969d+00 b = 0.4483151836883852d+00 v = 0.2283414092917525d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.5491402346984905d+00 b = 0.4764740676087880d+00 v = 0.2291161673130077d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.5753520160126075d+00 b = 0.5034021310998277d+00 v = 0.2295313908576598d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.1388326356417754d+00 b = 0.2435436510372806d-01 v = 0.1438204721359031d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.1743686900537244d+00 b = 0.5118897057342652d-01 v = 0.1607738025495257d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.2099737037950268d+00 b = 0.8014695048539634d-01 v = 0.1741483853528379d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.2454492590908548d+00 b = 0.1105117874155699d+00 v = 0.1851918467519151d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.2807219257864278d+00 b = 0.1417950531570966d+00 v = 0.1944628638070613d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.3156842271975842d+00 b = 0.1736604945719597d+00 v = 0.2022495446275152d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.3502090945177752d+00 b = 0.2058466324693981d+00 v = 0.2087462382438514d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.3841684849519686d+00 b = 0.2381284261195919d+00 v = 0.2141074754818308d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.4174372367906016d+00 b = 0.2703031270422569d+00 v = 0.2184640913748162d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.4498926465011892d+00 b = 0.3021845683091309d+00 v = 0.2219309165220329d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.4814146229807701d+00 b = 0.3335993355165720d+00 v = 0.2246123118340624d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.5118863625734701d+00 b = 0.3643833735518232d+00 v = 0.2266062766915125d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.5411947455119144d+00 b = 0.3943789541958179d+00 v = 0.2280072952230796d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.5692301500357246d+00 b = 0.4234320144403542d+00 v = 0.2289082025202583d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.5958857204139576d+00 b = 0.4513897947419260d+00 v = 0.2294012695120025d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.2156270284785766d+00 b = 0.2681225755444491d-01 v = 0.1722434488736947d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.2532385054909710d+00 b = 0.5557495747805614d-01 v = 0.1830237421455091d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.2902564617771537d+00 b = 0.8569368062950249d-01 v = 0.1923855349997633d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.3266979823143256d+00 b = 0.1167367450324135d+00 v = 0.2004067861936271d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.3625039627493614d+00 b = 0.1483861994003304d+00 v = 0.2071817297354263d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.3975838937548699d+00 b = 0.1803821503011405d+00 v = 0.2128250834102103d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.4318396099009774d+00 b = 0.2124962965666424d+00 v = 0.2174513719440102d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.4651706555732742d+00 b = 0.2445221837805913d+00 v = 0.2211661839150214d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.4974752649620969d+00 b = 0.2762701224322987d+00 v = 0.2240665257813102d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.5286517579627517d+00 b = 0.3075627775211328d+00 v = 0.2262439516632620d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.5586001195731895d+00 b = 0.3382311089826877d+00 v = 0.2277874557231869d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.5872229902021319d+00 b = 0.3681108834741399d+00 v = 0.2287854314454994d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.6144258616235123d+00 b = 0.3970397446872839d+00 v = 0.2293268499615575d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.2951676508064861d+00 b = 0.2867499538750441d-01 v = 0.1912628201529828d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.3335085485472725d+00 b = 0.5867879341903510d-01 v = 0.1992499672238701d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.3709561760636381d+00 b = 0.8961099205022284d-01 v = 0.2061275533454027d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.4074722861667498d+00 b = 0.1211627927626297d+00 v = 0.2119318215968572d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.4429923648839117d+00 b = 0.1530748903554898d+00 v = 0.2167416581882652d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.4774428052721736d+00 b = 0.1851176436721877d+00 v = 0.2206430730516600d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.5107446539535904d+00 b = 0.2170829107658179d+00 v = 0.2237186938699523d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.5428151370542935d+00 b = 0.2487786689026271d+00 v = 0.2260480075032884d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.5735699292556964d+00 b = 0.2800239952795016d+00 v = 0.2277098884558542d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.6029253794562866d+00 b = 0.3106445702878119d+00 v = 0.2287845715109671d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.6307998987073145d+00 b = 0.3404689500841194d+00 v = 0.2293547268236294d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.3752652273692719d+00 b = 0.2997145098184479d-01 v = 0.2056073839852528d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.4135383879344028d+00 b = 0.6086725898678011d-01 v = 0.2114235865831876d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.4506113885153907d+00 b = 0.9238849548435643d-01 v = 0.2163175629770551d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.4864401554606072d+00 b = 0.1242786603851851d+00 v = 0.2203392158111650d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.5209708076611709d+00 b = 0.1563086731483386d+00 v = 0.2235473176847839d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.5541422135830122d+00 b = 0.1882696509388506d+00 v = 0.2260024141501235d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.5858880915113817d+00 b = 0.2199672979126059d+00 v = 0.2277675929329182d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.6161399390603444d+00 b = 0.2512165482924867d+00 v = 0.2289102112284834d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.6448296482255090d+00 b = 0.2818368701871888d+00 v = 0.2295027954625118d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.4544796274917948d+00 b = 0.3088970405060312d-01 v = 0.2161281589879992d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.4919389072146628d+00 b = 0.6240947677636835d-01 v = 0.2201980477395102d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.5279313026985183d+00 b = 0.9430706144280313d-01 v = 0.2234952066593166d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.5624169925571135d+00 b = 0.1263547818770374d+00 v = 0.2260540098520838d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.5953484627093287d+00 b = 0.1583430788822594d+00 v = 0.2279157981899988d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.6266730715339185d+00 b = 0.1900748462555988d+00 v = 0.2291296918565571d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.6563363204278871d+00 b = 0.2213599519592567d+00 v = 0.2297533752536649d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.5314574716585696d+00 b = 0.3152508811515374d-01 v = 0.2234927356465995d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.5674614932298185d+00 b = 0.6343865291465561d-01 v = 0.2261288012985219d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.6017706004970264d+00 b = 0.9551503504223951d-01 v = 0.2280818160923688d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.6343471270264178d+00 b = 0.1275440099801196d+00 v = 0.2293773295180159d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.6651494599127802d+00 b = 0.1593252037671960d+00 v = 0.2300528767338634d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.6050184986005704d+00 b = 0.3192538338496105d-01 v = 0.2281893855065666d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.6390163550880400d+00 b = 0.6402824353962306d-01 v = 0.2295720444840727d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.6711199107088448d+00 b = 0.9609805077002909d-01 v = 0.2303227649026753d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.6741354429572275d+00 b = 0.3211853196273233d-01 v = 0.2304831913227114d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) n = n - 1 end subroutine subroutine ld5294 ( x , y , z , w , n ) real ( kind = dp ) :: x ( * ) real ( kind = dp ) :: y ( * ) real ( kind = dp ) :: z ( * ) real ( kind = dp ) :: w ( * ) integer :: n real ( kind = dp ) :: a , b , v ! !      LEBEDEV 5294-POINT ANGULAR GRID ! ! !      THIS ROUTINE IS PART OF A SET OF ROUTINES THAT GENERATE !      LEBEDEV GRIDS [1-6] FOR INTEGRATION ON A SPHERE. THE ORIGINAL !      C-CODE [1] WAS KINDLY PROVIDED BY DR. DMITRI N. LAIKOV AND !      TRANSLATED INTO FORTRAN BY DR. CHRISTOPH VAN WUELLEN. !      THIS ROUTINE WAS TRANSLATED USING A C TO FORTRAN77 CONVERSION !      TOOL WRITTEN BY DR. CHRISTOPH VAN WUELLEN. ! !      USERS OF THIS CODE ARE ASKED TO INCLUDE REFERENCE [1] IN THEIR !      PUBLICATIONS, AND IN THE USER- AND PROGRAMMERS-MANUALS !      DESCRIBING THEIR CODES. ! !      THIS CODE WAS DISTRIBUTED THROUGH CCL (HTTP://WWW.CCL.NET/). ! !      [1] V.I. LEBEDEV, AND D.N. LAIKOV !          \"A QUADRATURE FORMULA FOR THE SPHERE OF THE 131ST !           ALGEBRAIC ORDER OF ACCURACY\" !          DOKLADY MATHEMATICS, VOL. 59, NO. 3, 1999, PP. 477-481. ! !      [2] V.I. LEBEDEV !          \"A QUADRATURE FORMULA FOR THE SPHERE OF 59TH ALGEBRAIC !           ORDER OF ACCURACY\" !          RUSSIAN ACAD. SCI. DOKL. MATH., VOL. 50, 1995, PP. 283-286. ! !      [3] V.I. LEBEDEV, AND A.L. SKOROKHODOV !          \"QUADRATURE FORMULAS OF ORDERS 41, 47, AND 53 FOR THE SPHERE\" !          RUSSIAN ACAD. SCI. DOKL. MATH., VOL. 45, 1992, PP. 587-592. ! !      [4] V.I. LEBEDEV !          \"SPHERICAL QUADRATURE FORMULAS EXACT TO ORDERS 25-29\" !          SIBERIAN MATHEMATICAL JOURNAL, VOL. 18, 1977, PP. 99-107. ! !      [5] V.I. LEBEDEV !          \"QUADRATURES ON A SPHERE\" !          COMPUTATIONAL MATHEMATICS AND MATHEMATICAL PHYSICS, VOL. 16, !          1976, PP. 10-24. ! !      [6] V.I. LEBEDEV !          \"VALUES OF THE NODES AND WEIGHTS OF NINTH TO SEVENTEENTH !           ORDER GAUSS-MARKOV QUADRATURE FORMULAE INVARIANT UNDER THE !           OCTAHEDRON GROUP WITH INVERSION\" !          COMPUTATIONAL MATHEMATICS AND MATHEMATICAL PHYSICS, VOL. 15, !          1975, PP. 44-51. ! n = 1 v = 0.9080510764308163d-04 call gen_oh ( 1 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) v = 0.2084824361987793d-03 call gen_oh ( 3 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.2303261686261450d-01 v = 0.5011105657239616d-04 call gen_oh ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.3757208620162394d-01 v = 0.5942520409683854d-04 call gen_oh ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.5821912033821852d-01 v = 0.9564394826109721d-04 call gen_oh ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.8403127529194872d-01 v = 0.1185530657126338d-03 call gen_oh ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.1122927798060578d+00 v = 0.1364510114230331d-03 call gen_oh ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.1420125319192987d+00 v = 0.1505828825605415d-03 call gen_oh ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.1726396437341978d+00 v = 0.1619298749867023d-03 call gen_oh ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.2038170058115696d+00 v = 0.1712450504267789d-03 call gen_oh ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.2352849892876508d+00 v = 0.1789891098164999d-03 call gen_oh ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.2668363354312461d+00 v = 0.1854474955629795d-03 call gen_oh ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.2982941279900452d+00 v = 0.1908148636673661d-03 call gen_oh ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.3295002922087076d+00 v = 0.1952377405281833d-03 call gen_oh ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.3603094918363593d+00 v = 0.1988349254282232d-03 call gen_oh ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.3905857895173920d+00 v = 0.2017079807160050d-03 call gen_oh ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.4202005758160837d+00 v = 0.2039473082709094d-03 call gen_oh ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.4490310061597227d+00 v = 0.2056360279288953d-03 call gen_oh ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.4769586160311491d+00 v = 0.2068525823066865d-03 call gen_oh ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.5038679887049750d+00 v = 0.2076724877534488d-03 call gen_oh ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.5296454286519961d+00 v = 0.2081694278237885d-03 call gen_oh ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.5541776207164850d+00 v = 0.2084157631219326d-03 call gen_oh ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.5990467321921213d+00 v = 0.2084381531128593d-03 call gen_oh ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.6191467096294587d+00 v = 0.2083476277129307d-03 call gen_oh ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.6375251212901849d+00 v = 0.2082686194459732d-03 call gen_oh ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.6540514381131168d+00 v = 0.2082475686112415d-03 call gen_oh ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.6685899064391510d+00 v = 0.2083139860289915d-03 call gen_oh ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.6810013009681648d+00 v = 0.2084745561831237d-03 call gen_oh ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.6911469578730340d+00 v = 0.2087091313375890d-03 call gen_oh ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.6988956915141736d+00 v = 0.2089718413297697d-03 call gen_oh ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.7041335794868720d+00 v = 0.2092003303479793d-03 call gen_oh ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.7067754398018567d+00 v = 0.2093336148263241d-03 call gen_oh ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.3840368707853623d-01 v = 0.7591708117365267d-04 call gen_oh ( 5 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.9835485954117399d-01 v = 0.1083383968169186d-03 call gen_oh ( 5 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.1665774947612998d+00 v = 0.1403019395292510d-03 call gen_oh ( 5 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.2405702335362910d+00 v = 0.1615970179286436d-03 call gen_oh ( 5 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.3165270770189046d+00 v = 0.1771144187504911d-03 call gen_oh ( 5 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.3927386145645443d+00 v = 0.1887760022988168d-03 call gen_oh ( 5 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.4678825918374656d+00 v = 0.1973474670768214d-03 call gen_oh ( 5 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.5408022024266935d+00 v = 0.2033787661234659d-03 call gen_oh ( 5 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.6104967445752438d+00 v = 0.2072343626517331d-03 call gen_oh ( 5 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.6760910702685738d+00 v = 0.2091177834226918d-03 call gen_oh ( 5 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.6655644120217392d-01 b = 0.1936508874588424d-01 v = 0.9316684484675566d-04 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.9446246161270182d-01 b = 0.4252442002115869d-01 v = 0.1116193688682976d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.1242651925452509d+00 b = 0.6806529315354374d-01 v = 0.1298623551559414d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.1553438064846751d+00 b = 0.9560957491205369d-01 v = 0.1450236832456426d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.1871137110542670d+00 b = 0.1245931657452888d+00 v = 0.1572719958149914d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.2192612628836257d+00 b = 0.1545385828778978d+00 v = 0.1673234785867195d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.2515682807206955d+00 b = 0.1851004249723368d+00 v = 0.1756860118725188d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.2838535866287290d+00 b = 0.2160182608272384d+00 v = 0.1826776290439367d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.3159578817528521d+00 b = 0.2470799012277111d+00 v = 0.1885116347992865d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.3477370882791392d+00 b = 0.2781014208986402d+00 v = 0.1933457860170574d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.3790576960890540d+00 b = 0.3089172523515731d+00 v = 0.1973060671902064d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.4097938317810200d+00 b = 0.3393750055472244d+00 v = 0.2004987099616311d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.4398256572859637d+00 b = 0.3693322470987730d+00 v = 0.2030170909281499d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.4690384114718480d+00 b = 0.3986541005609877d+00 v = 0.2049461460119080d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.4973216048301053d+00 b = 0.4272112491408562d+00 v = 0.2063653565200186d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.5245681526132446d+00 b = 0.4548781735309936d+00 v = 0.2073507927381027d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.5506733911803888d+00 b = 0.4815315355023251d+00 v = 0.2079764593256122d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.5755339829522475d+00 b = 0.5070486445801855d+00 v = 0.2083150534968778d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.1305472386056362d+00 b = 0.2284970375722366d-01 v = 0.1262715121590664d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.1637327908216477d+00 b = 0.4812254338288384d-01 v = 0.1414386128545972d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.1972734634149637d+00 b = 0.7531734457511935d-01 v = 0.1538740401313898d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.2308694653110130d+00 b = 0.1039043639882017d+00 v = 0.1642434942331432d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.2643899218338160d+00 b = 0.1334526587117626d+00 v = 0.1729790609237496d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.2977171599622171d+00 b = 0.1636414868936382d+00 v = 0.1803505190260828d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.3307293903032310d+00 b = 0.1942195406166568d+00 v = 0.1865475350079657d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.3633069198219073d+00 b = 0.2249752879943753d+00 v = 0.1917182669679069d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.3953346955922727d+00 b = 0.2557218821820032d+00 v = 0.1959851709034382d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.4267018394184914d+00 b = 0.2862897925213193d+00 v = 0.1994529548117882d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.4573009622571704d+00 b = 0.3165224536636518d+00 v = 0.2022138911146548d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.4870279559856109d+00 b = 0.3462730221636496d+00 v = 0.2043518024208592d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.5157819581450322d+00 b = 0.3754016870282835d+00 v = 0.2059450313018110d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.5434651666465393d+00 b = 0.4037733784993613d+00 v = 0.2070685715318472d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.5699823887764627d+00 b = 0.4312557784139123d+00 v = 0.2077955310694373d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.5952403350947741d+00 b = 0.4577175367122110d+00 v = 0.2081980387824712d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.2025152599210369d+00 b = 0.2520253617719557d-01 v = 0.1521318610377956d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.2381066653274425d+00 b = 0.5223254506119000d-01 v = 0.1622772720185755d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.2732823383651612d+00 b = 0.8060669688588620d-01 v = 0.1710498139420709d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.3080137692611118d+00 b = 0.1099335754081255d+00 v = 0.1785911149448736d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.3422405614587601d+00 b = 0.1399120955959857d+00 v = 0.1850125313687736d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.3758808773890420d+00 b = 0.1702977801651705d+00 v = 0.1904229703933298d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.4088458383438932d+00 b = 0.2008799256601680d+00 v = 0.1949259956121987d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.4410450550841152d+00 b = 0.2314703052180836d+00 v = 0.1986161545363960d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.4723879420561312d+00 b = 0.2618972111375892d+00 v = 0.2015790585641370d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.5027843561874343d+00 b = 0.2920013195600270d+00 v = 0.2038934198707418d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.5321453674452458d+00 b = 0.3216322555190551d+00 v = 0.2056334060538251d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.5603839113834030d+00 b = 0.3506456615934198d+00 v = 0.2068705959462289d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.5874150706875146d+00 b = 0.3789007181306267d+00 v = 0.2076753906106002d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.6131559381660038d+00 b = 0.4062580170572782d+00 v = 0.2081179391734803d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.2778497016394506d+00 b = 0.2696271276876226d-01 v = 0.1700345216228943d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.3143733562261912d+00 b = 0.5523469316960465d-01 v = 0.1774906779990410d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.3501485810261827d+00 b = 0.8445193201626464d-01 v = 0.1839659377002642d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.3851430322303653d+00 b = 0.1143263119336083d+00 v = 0.1894987462975169d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.4193013979470415d+00 b = 0.1446177898344475d+00 v = 0.1941548809452595d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.4525585960458567d+00 b = 0.1751165438438091d+00 v = 0.1980078427252384d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.4848447779622947d+00 b = 0.2056338306745660d+00 v = 0.2011296284744488d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.5160871208276894d+00 b = 0.2359965487229226d+00 v = 0.2035888456966776d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.5462112185696926d+00 b = 0.2660430223139146d+00 v = 0.2054516325352142d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.5751425068101757d+00 b = 0.2956193664498032d+00 v = 0.2067831033092635d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.6028073872853596d+00 b = 0.3245763905312779d+00 v = 0.2076485320284876d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.6291338275278409d+00 b = 0.3527670026206972d+00 v = 0.2081141439525255d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.3541797528439391d+00 b = 0.2823853479435550d-01 v = 0.1834383015469222d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.3908234972074657d+00 b = 0.5741296374713106d-01 v = 0.1889540591777677d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.4264408450107590d+00 b = 0.8724646633650199d-01 v = 0.1936677023597375d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.4609949666553286d+00 b = 0.1175034422915616d+00 v = 0.1976176495066504d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.4944389496536006d+00 b = 0.1479755652628428d+00 v = 0.2008536004560983d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.5267194884346086d+00 b = 0.1784740659484352d+00 v = 0.2034280351712291d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.5577787810220990d+00 b = 0.2088245700431244d+00 v = 0.2053944466027758d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.5875563763536670d+00 b = 0.2388628136570763d+00 v = 0.2068077642882360d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.6159910016391269d+00 b = 0.2684308928769185d+00 v = 0.2077250949661599d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.6430219602956268d+00 b = 0.2973740761960252d+00 v = 0.2082062440705320d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.4300647036213646d+00 b = 0.2916399920493977d-01 v = 0.1934374486546626d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.4661486308935531d+00 b = 0.5898803024755659d-01 v = 0.1974107010484300d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.5009658555287261d+00 b = 0.8924162698525409d-01 v = 0.2007129290388658d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.5344824270447704d+00 b = 0.1197185199637321d+00 v = 0.2033736947471293d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.5666575997416371d+00 b = 0.1502300756161382d+00 v = 0.2054287125902493d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.5974457471404752d+00 b = 0.1806004191913564d+00 v = 0.2069184936818894d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.6267984444116886d+00 b = 0.2106621764786252d+00 v = 0.2078883689808782d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.6546664713575417d+00 b = 0.2402526932671914d+00 v = 0.2083886366116359d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.5042711004437253d+00 b = 0.2982529203607657d-01 v = 0.2006593275470817d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.5392127456774380d+00 b = 0.6008728062339922d-01 v = 0.2033728426135397d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.5726819437668618d+00 b = 0.9058227674571398d-01 v = 0.2055008781377608d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.6046469254207278d+00 b = 0.1211219235803400d+00 v = 0.2070651783518502d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.6350716157434952d+00 b = 0.1515286404791580d+00 v = 0.2080953335094320d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.6639177679185454d+00 b = 0.1816314681255552d+00 v = 0.2086284998988521d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.5757276040972253d+00 b = 0.3026991752575440d-01 v = 0.2055549387644668d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.6090265823139755d+00 b = 0.6078402297870770d-01 v = 0.2071871850267654d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.6406735344387661d+00 b = 0.9135459984176636d-01 v = 0.2082856600431965d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.6706397927793709d+00 b = 0.1218024155966590d+00 v = 0.2088705858819358d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.6435019674426665d+00 b = 0.3052608357660639d-01 v = 0.2083995867536322d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.6747218676375681d+00 b = 0.6112185773983089d-01 v = 0.2090509712889637d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) n = n - 1 end subroutine subroutine ld5810 ( x , y , z , w , n ) real ( kind = dp ) :: x ( * ) real ( kind = dp ) :: y ( * ) real ( kind = dp ) :: z ( * ) real ( kind = dp ) :: w ( * ) integer :: n real ( kind = dp ) :: a , b , v ! !      LEBEDEV 5810-POINT ANGULAR GRID ! ! !      THIS ROUTINE IS PART OF A SET OF ROUTINES THAT GENERATE !      LEBEDEV GRIDS [1-6] FOR INTEGRATION ON A SPHERE. THE ORIGINAL !      C-CODE [1] WAS KINDLY PROVIDED BY DR. DMITRI N. LAIKOV AND !      TRANSLATED INTO FORTRAN BY DR. CHRISTOPH VAN WUELLEN. !      THIS ROUTINE WAS TRANSLATED USING A C TO FORTRAN77 CONVERSION !      TOOL WRITTEN BY DR. CHRISTOPH VAN WUELLEN. ! !      USERS OF THIS CODE ARE ASKED TO INCLUDE REFERENCE [1] IN THEIR !      PUBLICATIONS, AND IN THE USER- AND PROGRAMMERS-MANUALS !      DESCRIBING THEIR CODES. ! !      THIS CODE WAS DISTRIBUTED THROUGH CCL (HTTP://WWW.CCL.NET/). ! !      [1] V.I. LEBEDEV, AND D.N. LAIKOV !          \"A QUADRATURE FORMULA FOR THE SPHERE OF THE 131ST !           ALGEBRAIC ORDER OF ACCURACY\" !          DOKLADY MATHEMATICS, VOL. 59, NO. 3, 1999, PP. 477-481. ! !      [2] V.I. LEBEDEV !          \"A QUADRATURE FORMULA FOR THE SPHERE OF 59TH ALGEBRAIC !           ORDER OF ACCURACY\" !          RUSSIAN ACAD. SCI. DOKL. MATH., VOL. 50, 1995, PP. 283-286. ! !      [3] V.I. LEBEDEV, AND A.L. SKOROKHODOV !          \"QUADRATURE FORMULAS OF ORDERS 41, 47, AND 53 FOR THE SPHERE\" !          RUSSIAN ACAD. SCI. DOKL. MATH., VOL. 45, 1992, PP. 587-592. ! !      [4] V.I. LEBEDEV !          \"SPHERICAL QUADRATURE FORMULAS EXACT TO ORDERS 25-29\" !          SIBERIAN MATHEMATICAL JOURNAL, VOL. 18, 1977, PP. 99-107. ! !      [5] V.I. LEBEDEV !          \"QUADRATURES ON A SPHERE\" !          COMPUTATIONAL MATHEMATICS AND MATHEMATICAL PHYSICS, VOL. 16, !          1976, PP. 10-24. ! !      [6] V.I. LEBEDEV !          \"VALUES OF THE NODES AND WEIGHTS OF NINTH TO SEVENTEENTH !           ORDER GAUSS-MARKOV QUADRATURE FORMULAE INVARIANT UNDER THE !           OCTAHEDRON GROUP WITH INVERSION\" !          COMPUTATIONAL MATHEMATICS AND MATHEMATICAL PHYSICS, VOL. 15, !          1975, PP. 44-51. ! n = 1 v = 0.9735347946175486d-05 call gen_oh ( 1 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) v = 0.1907581241803167d-03 call gen_oh ( 2 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) v = 0.1901059546737578d-03 call gen_oh ( 3 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.1182361662400277d-01 v = 0.3926424538919212d-04 call gen_oh ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.3062145009138958d-01 v = 0.6667905467294382d-04 call gen_oh ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.5329794036834243d-01 v = 0.8868891315019135d-04 call gen_oh ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.7848165532862220d-01 v = 0.1066306000958872d-03 call gen_oh ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.1054038157636201d+00 v = 0.1214506743336128d-03 call gen_oh ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.1335577797766211d+00 v = 0.1338054681640871d-03 call gen_oh ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.1625769955502252d+00 v = 0.1441677023628504d-03 call gen_oh ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.1921787193412792d+00 v = 0.1528880200826557d-03 call gen_oh ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.2221340534690548d+00 v = 0.1602330623773609d-03 call gen_oh ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.2522504912791132d+00 v = 0.1664102653445244d-03 call gen_oh ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.2823610860679697d+00 v = 0.1715845854011323d-03 call gen_oh ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.3123173966267560d+00 v = 0.1758901000133069d-03 call gen_oh ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.3419847036953789d+00 v = 0.1794382485256736d-03 call gen_oh ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.3712386456999758d+00 v = 0.1823238106757407d-03 call gen_oh ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.3999627649876828d+00 v = 0.1846293252959976d-03 call gen_oh ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.4280466458648093d+00 v = 0.1864284079323098d-03 call gen_oh ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.4553844360185711d+00 v = 0.1877882694626914d-03 call gen_oh ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.4818736094437834d+00 v = 0.1887716321852025d-03 call gen_oh ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.5074138709260629d+00 v = 0.1894381638175673d-03 call gen_oh ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.5319061304570707d+00 v = 0.1898454899533629d-03 call gen_oh ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.5552514978677286d+00 v = 0.1900497929577815d-03 call gen_oh ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.5981009025246183d+00 v = 0.1900671501924092d-03 call gen_oh ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.6173990192228116d+00 v = 0.1899837555533510d-03 call gen_oh ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.6351365239411131d+00 v = 0.1899014113156229d-03 call gen_oh ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.6512010228227200d+00 v = 0.1898581257705106d-03 call gen_oh ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.6654758363948120d+00 v = 0.1898804756095753d-03 call gen_oh ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.6778410414853370d+00 v = 0.1899793610426402d-03 call gen_oh ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.6881760887484110d+00 v = 0.1901464554844117d-03 call gen_oh ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.6963645267094598d+00 v = 0.1903533246259542d-03 call gen_oh ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.7023010617153579d+00 v = 0.1905556158463228d-03 call gen_oh ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.7059004636628753d+00 v = 0.1907037155663528d-03 call gen_oh ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.3552470312472575d-01 v = 0.5992997844249967d-04 call gen_oh ( 5 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.9151176620841283d-01 v = 0.9749059382456978d-04 call gen_oh ( 5 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.1566197930068980d+00 v = 0.1241680804599158d-03 call gen_oh ( 5 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.2265467599271907d+00 v = 0.1437626154299360d-03 call gen_oh ( 5 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.2988242318581361d+00 v = 0.1584200054793902d-03 call gen_oh ( 5 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.3717482419703886d+00 v = 0.1694436550982744d-03 call gen_oh ( 5 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.4440094491758889d+00 v = 0.1776617014018108d-03 call gen_oh ( 5 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.5145337096756642d+00 v = 0.1836132434440077d-03 call gen_oh ( 5 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.5824053672860230d+00 v = 0.1876494727075983d-03 call gen_oh ( 5 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.6468283961043370d+00 v = 0.1899906535336482d-03 call gen_oh ( 5 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.6095964259104373d-01 b = 0.1787828275342931d-01 v = 0.8143252820767350d-04 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.8811962270959388d-01 b = 0.3953888740792096d-01 v = 0.9998859890887728d-04 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.1165936722428831d+00 b = 0.6378121797722990d-01 v = 0.1156199403068359d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.1460232857031785d+00 b = 0.8985890813745037d-01 v = 0.1287632092635513d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.1761197110181755d+00 b = 0.1172606510576162d+00 v = 0.1398378643365139d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.2066471190463718d+00 b = 0.1456102876970995d+00 v = 0.1491876468417391d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.2374076026328152d+00 b = 0.1746153823011775d+00 v = 0.1570855679175456d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.2682305474337051d+00 b = 0.2040383070295584d+00 v = 0.1637483948103775d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.2989653312142369d+00 b = 0.2336788634003698d+00 v = 0.1693500566632843d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.3294762752772209d+00 b = 0.2633632752654219d+00 v = 0.1740322769393633d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.3596390887276086d+00 b = 0.2929369098051601d+00 v = 0.1779126637278296d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.3893383046398812d+00 b = 0.3222592785275512d+00 v = 0.1810908108835412d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.4184653789358347d+00 b = 0.3512004791195743d+00 v = 0.1836529132600190d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.4469172319076166d+00 b = 0.3796385677684537d+00 v = 0.1856752841777379d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.4745950813276976d+00 b = 0.4074575378263879d+00 v = 0.1872270566606832d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.5014034601410262d+00 b = 0.4345456906027828d+00 v = 0.1883722645591307d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.5272493404551239d+00 b = 0.4607942515205134d+00 v = 0.1891714324525297d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.5520413051846366d+00 b = 0.4860961284181720d+00 v = 0.1896827480450146d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.5756887237503077d+00 b = 0.5103447395342790d+00 v = 0.1899628417059528d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.1225039430588352d+00 b = 0.2136455922655793d-01 v = 0.1123301829001669d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.1539113217321372d+00 b = 0.4520926166137188d-01 v = 0.1253698826711277d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.1856213098637712d+00 b = 0.7086468177864818d-01 v = 0.1366266117678531d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.2174998728035131d+00 b = 0.9785239488772918d-01 v = 0.1462736856106918d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.2494128336938330d+00 b = 0.1258106396267210d+00 v = 0.1545076466685412d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.2812321562143480d+00 b = 0.1544529125047001d+00 v = 0.1615096280814007d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.3128372276456111d+00 b = 0.1835433512202753d+00 v = 0.1674366639741759d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.3441145160177973d+00 b = 0.2128813258619585d+00 v = 0.1724225002437900d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.3749567714853510d+00 b = 0.2422913734880829d+00 v = 0.1765810822987288d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.4052621732015610d+00 b = 0.2716163748391453d+00 v = 0.1800104126010751d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.4349335453522385d+00 b = 0.3007127671240280d+00 v = 0.1827960437331284d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.4638776641524965d+00 b = 0.3294470677216479d+00 v = 0.1850140300716308d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.4920046410462687d+00 b = 0.3576932543699155d+00 v = 0.1867333507394938d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.5192273554861704d+00 b = 0.3853307059757764d+00 v = 0.1880178688638289d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.5454609081136522d+00 b = 0.4122425044452694d+00 v = 0.1889278925654758d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.5706220661424140d+00 b = 0.4383139587781027d+00 v = 0.1895213832507346d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.5946286755181518d+00 b = 0.4634312536300553d+00 v = 0.1898548277397420d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.1905370790924295d+00 b = 0.2371311537781979d-01 v = 0.1349105935937341d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.2242518717748009d+00 b = 0.4917878059254806d-01 v = 0.1444060068369326d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.2577190808025936d+00 b = 0.7595498960495142d-01 v = 0.1526797390930008d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.2908724534927187d+00 b = 0.1036991083191100d+00 v = 0.1598208771406474d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.3236354020056219d+00 b = 0.1321348584450234d+00 v = 0.1659354368615331d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.3559267359304543d+00 b = 0.1610316571314789d+00 v = 0.1711279910946440d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.3876637123676956d+00 b = 0.1901912080395707d+00 v = 0.1754952725601440d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.4187636705218842d+00 b = 0.2194384950137950d+00 v = 0.1791247850802529d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.4491449019883107d+00 b = 0.2486155334763858d+00 v = 0.1820954300877716d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.4787270932425445d+00 b = 0.2775768931812335d+00 v = 0.1844788524548449d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.5074315153055574d+00 b = 0.3061863786591120d+00 v = 0.1863409481706220d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.5351810507738336d+00 b = 0.3343144718152556d+00 v = 0.1877433008795068d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.5619001025975381d+00 b = 0.3618362729028427d+00 v = 0.1887444543705232d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.5875144035268046d+00 b = 0.3886297583620408d+00 v = 0.1894009829375006d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.6119507308734495d+00 b = 0.4145742277792031d+00 v = 0.1897683345035198d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.2619733870119463d+00 b = 0.2540047186389353d-01 v = 0.1517327037467653d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.2968149743237949d+00 b = 0.5208107018543989d-01 v = 0.1587740557483543d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.3310451504860488d+00 b = 0.7971828470885599d-01 v = 0.1649093382274097d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.3646215567376676d+00 b = 0.1080465999177927d+00 v = 0.1701915216193265d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.3974916785279360d+00 b = 0.1368413849366629d+00 v = 0.1746847753144065d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.4295967403772029d+00 b = 0.1659073184763559d+00 v = 0.1784555512007570d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.4608742854473447d+00 b = 0.1950703730454614d+00 v = 0.1815687562112174d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.4912598858949903d+00 b = 0.2241721144376724d+00 v = 0.1840864370663302d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.5206882758945558d+00 b = 0.2530655255406489d+00 v = 0.1860676785390006d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.5490940914019819d+00 b = 0.2816118409731066d+00 v = 0.1875690583743703d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.5764123302025542d+00 b = 0.3096780504593238d+00 v = 0.1886453236347225d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.6025786004213506d+00 b = 0.3371348366394987d+00 v = 0.1893501123329645d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.6275291964794956d+00 b = 0.3638547827694396d+00 v = 0.1897366184519868d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.3348189479861771d+00 b = 0.2664841935537443d-01 v = 0.1643908815152736d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.3699515545855295d+00 b = 0.5424000066843495d-01 v = 0.1696300350907768d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.4042003071474669d+00 b = 0.8251992715430854d-01 v = 0.1741553103844483d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.4375320100182624d+00 b = 0.1112695182483710d+00 v = 0.1780015282386092d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.4699054490335947d+00 b = 0.1402964116467816d+00 v = 0.1812116787077125d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.5012739879431952d+00 b = 0.1694275117584291d+00 v = 0.1838323158085421d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.5315874883754966d+00 b = 0.1985038235312689d+00 v = 0.1859113119837737d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.5607937109622117d+00 b = 0.2273765660020893d+00 v = 0.1874969220221698d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.5888393223495521d+00 b = 0.2559041492849764d+00 v = 0.1886375612681076d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.6156705979160163d+00 b = 0.2839497251976899d+00 v = 0.1893819575809276d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.6412338809078123d+00 b = 0.3113791060500690d+00 v = 0.1897794748256767d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.4076051259257167d+00 b = 0.2757792290858463d-01 v = 0.1738963926584846d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.4423788125791520d+00 b = 0.5584136834984293d-01 v = 0.1777442359873466d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.4760480917328258d+00 b = 0.8457772087727143d-01 v = 0.1810010815068719d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.5085838725946297d+00 b = 0.1135975846359248d+00 v = 0.1836920318248129d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.5399513637391218d+00 b = 0.1427286904765053d+00 v = 0.1858489473214328d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.5701118433636380d+00 b = 0.1718112740057635d+00 v = 0.1875079342496592d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.5990240530606021d+00 b = 0.2006944855985351d+00 v = 0.1887080239102310d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.6266452685139695d+00 b = 0.2292335090598907d+00 v = 0.1894905752176822d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.6529320971415942d+00 b = 0.2572871512353714d+00 v = 0.1898991061200695d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.4791583834610126d+00 b = 0.2826094197735932d-01 v = 0.1809065016458791d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.5130373952796940d+00 b = 0.5699871359683649d-01 v = 0.1836297121596799d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.5456252429628476d+00 b = 0.8602712528554394d-01 v = 0.1858426916241869d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.5768956329682385d+00 b = 0.1151748137221281d+00 v = 0.1875654101134641d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.6068186944699046d+00 b = 0.1442811654136362d+00 v = 0.1888240751833503d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.6353622248024907d+00 b = 0.1731930321657680d+00 v = 0.1896497383866979d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.6624927035731797d+00 b = 0.2017619958756061d+00 v = 0.1900775530219121d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.5484933508028488d+00 b = 0.2874219755907391d-01 v = 0.1858525041478814d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.5810207682142106d+00 b = 0.5778312123713695d-01 v = 0.1876248690077947d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.6120955197181352d+00 b = 0.8695262371439526d-01 v = 0.1889404439064607d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.6416944284294319d+00 b = 0.1160893767057166d+00 v = 0.1898168539265290d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.6697926391731260d+00 b = 0.1450378826743251d+00 v = 0.1902779940661772d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.6147594390585488d+00 b = 0.2904957622341456d-01 v = 0.1890125641731815d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.6455390026356783d+00 b = 0.5823809152617197d-01 v = 0.1899434637795751d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.6747258588365477d+00 b = 0.8740384899884715d-01 v = 0.1904520856831751d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) a = 0.6772135750395347d+00 b = 0.2919946135808105d-01 v = 0.1905534498734563d-03 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) n = n - 1 end subroutine !===================================================================== !      Lebedev-Laikov grids end here !===================================================================== ! !      Octahedral symmetry (w/o inversion) 246-point angular grid !      Order: 26 ! !      [1] A.S. POPOV !          \"THE SEARCH FOR THE SPHERE OF THE BEST CUBATURE FORMULAE !           INVARIANT UNDER OCTAHEDRAL GROUP OF ROTATIONS\" !          SIB. ZH. VYCHISL. MAT., VOL. 5, NO. 4, 2002, PP. 367–372 ! subroutine od0246 ( x , y , z , w , n ) real ( kind = dp ) :: x ( * ) real ( kind = dp ) :: y ( * ) real ( kind = dp ) :: z ( * ) real ( kind = dp ) :: w ( * ) integer :: n real ( kind = dp ) :: a , b , v n = 1 v = 0.3897235138937088d-02 call gen_oh ( 1 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) v = 0.3493936461315880d-02 a = 0.9566807992266356d+00 b = 0.2833386636495198d+00 call gen_oh ( 7 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) v = 0.3591650554371342d-02 a = 0.9757117308401445d+00 b = 0.1167317879067011d+00 call gen_oh ( 7 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) v = 0.3967953538531415d-02 a = 0.9001427110863452d+00 b = 0.1004016871311435d+00 call gen_oh ( 7 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) v = 0.4044472616286787d-02 a = 0.9016081884868434d+00 b = 0.3046563962638665d+00 call gen_oh ( 7 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) v = 0.4158726826302798d-02 a = 0.8657185254531113d+00 b = 0.4789871418590519d+00 call gen_oh ( 7 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) v = 0.4223724523384502d-02 a = 0.7958577819235757d+00 b = 0.2817783845311169d+00 call gen_oh ( 7 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) v = 0.4287698313089224d-02 a = 0.7828854398832512d+00 b = 0.3632315411734175d-01 call gen_oh ( 7 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) v = 0.4295521563270202d-02 a = 0.7797755454487808d+00 b = 0.4876721073724419d+00 call gen_oh ( 7 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) v = 0.4306264958684786d-02 a = 0.6482368665122326d+00 b = 0.4557085192757556d+00 call gen_oh ( 7 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) v = 0.4322408526695458d-02 a = 0.7237785649544816d+00 b = 0.6543863740765325d+00 call gen_oh ( 7 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) n = n - 1 end subroutine ! !      Octahedral symmetry (w/o inversion) 264-point angular grid !      Order: 27 ! !      [1] A.S. POPOV !          \"THE SEARCH FOR THE SPHERE OF THE BEST CUBATURE FORMULAE !           INVARIANT UNDER OCTAHEDRAL GROUP OF ROTATIONS\" !          SIB. ZH. VYCHISL. MAT., VOL. 5, NO. 4, 2002, PP. 367–372 ! subroutine od0264 ( x , y , z , w , n ) real ( kind = dp ) :: x ( * ) real ( kind = dp ) :: y ( * ) real ( kind = dp ) :: z ( * ) real ( kind = dp ) :: w ( * ) integer :: n real ( kind = dp ) :: a , b , v n = 1 v = 3.404743138426950d-03 a = 7.501162447877730d-01 b = 6.569874882943270d-01 call gen_oh ( 7 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) v = 3.527346280748710d-03 a = 8.810738528375910d-01 b = 2.804539315326130d-01 call gen_oh ( 7 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) v = 3.560705552891180d-03 a = 6.985522168362600d-01 b = 6.638349164875560d-01 call gen_oh ( 7 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) v = 3.661015502447230d-03 a = 9.884416293559190d-01 b = 4.187763670001430d-02 call gen_oh ( 7 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) v = 3.734364518407020d-03 a = 8.703452942381050d-01 b = 4.831216465940420d-01 call gen_oh ( 7 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) v = 3.786218818475490d-03 a = 7.577370457280040d-01 b = 3.737914001474930d-01 call gen_oh ( 7 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) v = 3.812295213144400d-03 a = 9.340175312890680d-01 b = 7.308888363903200d-02 call gen_oh ( 7 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) v = 3.922282615281700d-03 a = 6.702365796250490d-01 b = 5.696274199623510d-01 call gen_oh ( 7 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) v = 3.934290436352150d-03 a = 8.218581364908940d-01 b = 4.788479450589300d-01 call gen_oh ( 7 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) v = 4.143508784124530d-03 a = 9.465732078368030d-01 b = 2.750687576636780d-01 call gen_oh ( 7 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) v = 4.179895806367260d-03 a = 8.172239405554010d-01 b = 1.335491891058270d-01 call gen_oh ( 7 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) n = n - 1 end subroutine ! !      Octahedral symmetry (w/o inversion) 342-point angular grid !      Order: 31 ! !      [1] A.S. POPOV !          \"CUBATURE FORMULAE FOR THE SPHERE !           INVARIANT UNDER OCTAHEDRAL GROUP OF ROTATIONS\" (IN RUSSIAN) !          COMPUT. MATH. MATH. PHYS., VOL. 38, NO. 1, 1998, PP. 30-37 ! subroutine od0342 ( x , y , z , w , n ) real ( kind = dp ) :: x ( * ) real ( kind = dp ) :: y ( * ) real ( kind = dp ) :: z ( * ) real ( kind = dp ) :: w ( * ) integer :: n real ( kind = dp ) :: a , b , v n = 1 v = 0.3023648748223408d-02 call gen_oh ( 1 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) v = 0.2640009601341421d-02 a = 0.8596638928344739d+00 b = 0.4062242558266217d+00 call gen_oh ( 7 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) v = 0.2743272994096360d-02 a = 0.9048298313140403d+00 b = 0.2370253708753523d+00 call gen_oh ( 7 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) v = 0.2892274286735084d-02 a = 0.7919900954039140d+00 b = 0.3635572640746994d+00 call gen_oh ( 7 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) v = 0.2898956168072910d-02 a = 0.9246930024023610d+00 b = 0.5409950346576234d-01 call gen_oh ( 7 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) v = 0.2922211185898755d-02 a = 0.7983845764909109d+00 b = 0.5645514094465199d+00 call gen_oh ( 7 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) v = 0.2926667482335111d-02 a = 0.9629723259634715d+00 b = 0.2038117136355577d+00 call gen_oh ( 7 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) v = 0.2931773085197849d-02 a = 0.9120669247729113d+00 b = 0.3877575423799307d+00 call gen_oh ( 7 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) v = 0.2936869297379136d-02 a = 0.7377581016329626d+00 b = 0.5411494384156677d+00 call gen_oh ( 7 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) v = 0.2975927626183587d-02 a = 0.9810590688132057d+00 b = 0.1311454620366076d-01 call gen_oh ( 7 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) v = 0.2986111941772548d-02 a = 0.6522834517550465d+00 b = 0.4833339354284559d+00 call gen_oh ( 7 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) v = 0.2987229421263409d-02 a = 0.6952847727766393d+00 b = 0.2919213249111464d+00 call gen_oh ( 7 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) v = 0.2995506191909761d-02 a = 0.8278662627227689d+00 b = 0.1738700791494905d+00 call gen_oh ( 7 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) v = 0.3035869254195839d-02 a = 0.8316507582159955d+00 b = 0.5548939979903705d+00 call gen_oh ( 7 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) v = 0.3038075943229046d-02 a = 0.7126773308879356d+00 b = 0.9613108329184178d-01 call gen_oh ( 7 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) n = n - 1 end subroutine !      Oh symmetry 350-point angular grid !      Order: 31 ! !      [1] A.S. POPOV !          \"THE SEARCH FOR THE SPHERE OF THE BEST CUBATURE FORMULAE !           INVARIANT UNDER OCTAHEDRAL GROUP OF ROTATIONS !           WITH INVERSION FOR A SPHERE\" !          SIB. ZH. VYCHISL. MAT., VOL. 8, NO. 2, 2005, PP. 143–148 ! subroutine ohd0350 ( x , y , z , w , n ) real ( kind = dp ) :: x ( * ) real ( kind = dp ) :: y ( * ) real ( kind = dp ) :: z ( * ) real ( kind = dp ) :: w ( * ) integer :: n real ( kind = dp ) :: a , b , v n = 1 v = 0.3022655957073096d-02 call gen_oh ( 1 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) v = 0.3053589782677049d-02 call gen_oh ( 3 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) v = 0.1606436947071299d-02 a = 0.7240037770684867d+00 call gen_oh ( 5 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) v = 0.2894462580088764d-02 a = 0.9249389183479164d+00 call gen_oh ( 5 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) v = 0.2992303278280904d-02 a = 0.9810676749667857d+00 call gen_oh ( 5 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) v = 0.2705550334445959d-02 a = 0.3622473127982810d+00 call gen_oh ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) v = 0.2966242835900409d-02 a = 0.1917690066919518d+00 call gen_oh ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) v = 0.2999330613486812d-02 a = 0.4801685990565060d+00 call gen_oh ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) v = 0.3041905028826839d-02 a = 0.6502682026896775d+00 call gen_oh ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) v = 0.3044469577443018d-02 a = 0.6935461975932684d+00 call gen_oh ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) v = 0.2846671108207593d-02 a = 0.9077761244847474d+00 b = 0.3765168541264181d+00 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) v = 0.2954001654360567d-02 a = 0.7932087174843227d+00 b = 0.5354121187940431d+00 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) v = 0.3020546347912858d-02 a = 0.8290201309029455d+00 b = 0.5505983319551926d+00 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) n = n - 1 end subroutine ! !      Oh symmetry 398-point angular grid !      Order: 33 ! !      [1] A.S. POPOV !          \"THE SEARCH FOR THE SPHERE OF THE BEST CUBATURE FORMULAE !           INVARIANT UNDER OCTAHEDRAL GROUP OF ROTATIONS !           WITH INVERSION FOR A SPHERE\" !          SIB. ZH. VYCHISL. MAT., VOL. 8, NO. 2, 2005, PP. 143–148 ! subroutine ohd0398 ( x , y , z , w , n ) real ( kind = dp ) :: x ( * ) real ( kind = dp ) :: y ( * ) real ( kind = dp ) :: z ( * ) real ( kind = dp ) :: w ( * ) integer :: n real ( kind = dp ) :: a , b , v n = 1 v = 0.1822084579093247d-02 call gen_oh ( 1 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) v = 0.2827377032685751d-02 call gen_oh ( 3 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) v = 0.1575484799105965d-02 a = 0.7062503174494366d+00 call gen_oh ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) v = 0.2580087158579662d-02 a = 0.1133790435116091d+00 call gen_oh ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) v = 0.2639846092802613d-02 a = 0.6901038654954956d+00 call gen_oh ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) v = 0.2783844769874123d-02 a = 0.6457774767552608d+00 call gen_oh ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) v = 0.2846001949687294d-02 a = 0.4796087844363489d+00 call gen_oh ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) v = 0.2873971674037779d-02 a = 0.3632128775162115d+00 call gen_oh ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) v = 0.2553168380704661d-02 a = 0.9648952557917490d+00 call gen_oh ( 5 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) v = 0.2654875161144892d-02 a = 0.9014928604201154d+00 call gen_oh ( 5 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) v = 0.2220113527157410d-02 a = 0.8797615447057731d+00 b = 0.4380336735755111d+00 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) v = 0.2326306559741858d-02 a = 0.9388803094389767d+00 b = 0.2946263848640117d+00 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) v = 0.2611549635094245d-02 a = 0.8091315291511537d+00 b = 0.5793558553216747d+00 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) v = 0.2722733540537044d-02 a = 0.7838817431841564d+00 b = 0.5439488406950955d+00 call gen_oh ( 6 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) n = n - 1 end subroutine ! !      Octahedral symmetry (w/o inversion) 432-point angular grid !      Order: 25 ! !      [1] A.S. POPOV !          \"CUBATURE FORMULAE FOR THE SPHERE !           INVARIANT UNDER OCTAHEDRAL GROUP OF ROTATIONS\" (IN RUSSIAN) !          COMPUT. MATH. MATH. PHYS., VOL. 38, NO. 1, 1998, PP. 30-37 ! subroutine od0432 ( x , y , z , w , n ) real ( kind = dp ) :: x ( * ) real ( kind = dp ) :: y ( * ) real ( kind = dp ) :: z ( * ) real ( kind = dp ) :: w ( * ) integer :: n real ( kind = dp ) :: a , b , v n = 1 v = 0.2073915331320519d-02 a = 0.7489806258088988d+00 b = 0.6108701068802251d+00 call gen_oh ( 7 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) v = 0.2107255030397068d-02 a = 0.9161730444214968d+00 b = 0.3197412043673950d+00 call gen_oh ( 7 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) v = 0.2115342322975654d-02 a = 0.9641217858844791d+00 b = 0.1775069067845282d+00 call gen_oh ( 7 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) v = 0.2139217879967886d-02 a = 0.9932625280244080d+00 b = 0.4909487312548763d-01 call gen_oh ( 7 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) v = 0.2213455223136293d-02 a = 0.9350867590143857d+00 b = 0.1021948630931257d+00 call gen_oh ( 7 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) v = 0.2220017128107630d-02 a = 0.8328350332317131d+00 b = 0.5345156354592039d+00 call gen_oh ( 7 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) v = 0.2255553046127313d-02 a = 0.9113314027451442d+00 b = 0.4001239125939150d+00 call gen_oh ( 7 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) v = 0.2317129463567652d-02 a = 0.8726339023393756d+00 b = 0.5449493821656796d-01 call gen_oh ( 7 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) v = 0.2319753441076136d-02 a = 0.9678242462766119d+00 b = 0.2485055252796990d+00 call gen_oh ( 7 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) v = 0.2346020122932169d-02 a = 0.7078265977814910d+00 b = 0.1321992811820306d+00 call gen_oh ( 7 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) v = 0.2365479437733548d-02 a = 0.7070053872543563d+00 b = 0.3277599108679579d+00 call gen_oh ( 7 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) v = 0.2373641673707936d-02 a = 0.7815225804060471d+00 b = 0.6238577434353162d+00 call gen_oh ( 7 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) v = 0.2434041150670229d-02 a = 0.7200100968665680d+00 b = 0.5549556437629704d+00 call gen_oh ( 7 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) v = 0.2458995407627726d-02 a = 0.8068208852018608d+00 b = 0.1984078314629552d+00 call gen_oh ( 7 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) v = 0.2465111275848897d-02 a = 0.8385089184456621d+00 b = 0.4494208832677718d+00 call gen_oh ( 7 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) v = 0.2466377894866924d-02 a = 0.8801102003441889d+00 b = 0.2566114675058704d+00 call gen_oh ( 7 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) v = 0.2496086422248489d-02 a = 0.7879155638776240d+00 b = 0.3902320295286575d+00 call gen_oh ( 7 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) v = 0.2499274414354599d-02 a = 0.6504900372238729d+00 b = 0.4941000883702588d+00 call gen_oh ( 7 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) n = n - 1 end subroutine ! Icosahedral symmetry (w/o inversion) 132-point angular grid ! Order: 19 ! ! [1] Popov, A. S. (1994). Cubature formulae for a sphere invariant under !     cyclic rotation groups. !     Russian Journal of Numerical Analysis and Mathematical Modelling, 9(6), 535–546. subroutine id0132 ( x , y , z , w , n ) real ( kind = dp ) :: x ( * ) real ( kind = dp ) :: y ( * ) real ( kind = dp ) :: z ( * ) real ( kind = dp ) :: w ( * ) integer :: n real ( kind = dp ) :: a , b , v n = 1 v = 0.6359381359381359d-02 call gen_ih ( 1 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) v = 0.7540532344007263d-02 a = 0.8222245632603329d+00 b = 0.4844155031786994d+00 call gen_ih ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) v = 0.7854258050783132d-02 a = 0.6921548451959329d+00 b = 0.4181234628202419d+00 call gen_ih ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) n = n - 1 end subroutine ! Icosahedral symmetry (w/o inversion) 152-point angular grid ! Order: 20 ! ! [1] Popov, A. S. (1994). Cubature formulae for a sphere invariant under !     cyclic rotation groups. !     Russian Journal of Numerical Analysis and Mathematical Modelling, 9(6), 535–546. subroutine id0152 ( x , y , z , w , n ) real ( kind = dp ) :: x ( * ) real ( kind = dp ) :: y ( * ) real ( kind = dp ) :: z ( * ) real ( kind = dp ) :: w ( * ) integer :: n real ( kind = dp ) :: a , b , v n = 1 v = 0.6611961667098409d-02 call gen_ih ( 1 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) v = 0.4648223955885233d-02 call gen_ih ( 2 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) v = 0.6409543073731093d-02 a = 0.7539155496229768d+00 b = 0.4457443002522118d+00 call gen_ih ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) v = 0.7385323274220814d-02 a = 0.7228854451847260d+00 b = 0.6440377245132042d+00 call gen_ih ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) n = n - 1 end subroutine ! Icosahedral symmetry (w/o inversion) 180-point angular grid ! Order: 21 ! ! [1] Popov, A. S. (1994). Cubature formulae for a sphere invariant under !     cyclic rotation groups. !     Russian Journal of Numerical Analysis and Mathematical Modelling, 9(6), 535–546. subroutine id0180 ( x , y , z , w , n ) real ( kind = dp ) :: x ( * ) real ( kind = dp ) :: y ( * ) real ( kind = dp ) :: z ( * ) real ( kind = dp ) :: w ( * ) integer :: n real ( kind = dp ) :: a , b , v n = 1 v = 0.5018022982483986d-02 a = 0.8243592074145533d+00 b = 0.5307071420708551d+00 call gen_ih ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) v = 0.5592501087262595d-02 a = 0.7425058274010514d+00 b = 0.2794547353533492d+00 call gen_ih ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) v = 0.6056142596920085d-02 a = 0.6952402305312859d+00 b = 0.5565510052111179d+00 call gen_ih ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) n = n - 1 end subroutine ! Icosahedral symmetry (w/o inversion) 192-point angular grid ! Order: 23 ! ! [1] Popov, A. S. (1994). Cubature formulae for a sphere invariant under !     cyclic rotation groups. !     Russian Journal of Numerical Analysis and Mathematical Modelling, 9(6), 535–546. subroutine id0192 ( x , y , z , w , n ) real ( kind = dp ) :: x ( * ) real ( kind = dp ) :: y ( * ) real ( kind = dp ) :: z ( * ) real ( kind = dp ) :: w ( * ) integer :: n real ( kind = dp ) :: a , b , v n = 1 v = 0.4164880157580243d-02 call gen_ih ( 1 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) v = 0.5077679306001083d-02 a = 0.8032626540631647d+00 b = 0.5443960115691368d+00 call gen_ih ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) v = 0.5349546802216597d-02 a = 0.6978513452732168d+00 b = 0.5282061903582911d+00 call gen_ih ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) v = 0.5406464526932938d-02 a = 0.7323722630950026d+00 b = 0.2934089823272757d+00 call gen_ih ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) n = n - 1 end subroutine ! Icosahedral symmetry (w/o inversion) 212-point angular grid ! Order: 24 ! ! [1] Popov, A. S. (1994). Cubature formulae for a sphere invariant under !     cyclic rotation groups. !     Russian Journal of Numerical Analysis and Mathematical Modelling, 9(6), 535–546. subroutine id0212 ( x , y , z , w , n ) real ( kind = dp ) :: x ( * ) real ( kind = dp ) :: y ( * ) real ( kind = dp ) :: z ( * ) real ( kind = dp ) :: w ( * ) integer :: n real ( kind = dp ) :: a , b , v n = 1 v = 0.3741936943619837d-02 call gen_ih ( 1 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) v = 0.4935771576102468d-02 call gen_ih ( 2 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) v = 0.4551001693496304d-02 a = 0.8452548782475415d+00 b = 0.4824136177694623d+00 call gen_ih ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) v = 0.4855145722266675d-02 a = 0.6779115110470655d+00 b = 0.6479557053061163d+00 call gen_ih ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) v = 0.4866874670145564d-02 a = 0.7753898899839309d+00 b = 0.4269810983100433d+00 call gen_ih ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) n = n - 1 end subroutine ! Icosahedral symmetry (w/o inversion) 242-point angular grid ! Order: 25 ! ! [1] Popov, A. S. (1994). Cubature formulae for a sphere invariant under !     cyclic rotation groups. !     Russian Journal of Numerical Analysis and Mathematical Modelling, 9(6), 535–546. subroutine id0242 ( x , y , z , w , n ) real ( kind = dp ) :: x ( * ) real ( kind = dp ) :: y ( * ) real ( kind = dp ) :: z ( * ) real ( kind = dp ) :: w ( * ) integer :: n real ( kind = dp ) :: a , b , v n = 1 v = 0.3773233796543805d-02 call gen_ih ( 1 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) v = 0.4742703016240548d-02 call gen_ih ( 2 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) v = 0.2350527849974790d-02 call gen_ih ( 3 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) v = 0.3976391306805966d-02 a = 0.7588635353153991d+00 b = 0.4631578933426286d+00 call gen_ih ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) v = 0.4548524050513189d-02 a = 0.8418750816582262d+00 b = 0.4876800613655622d+00 call gen_ih ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) v = 0.4630939619637840d-02 a = 0.6718027690441337d+00 b = 0.6591034254439872d+00 call gen_ih ( 4 , n , x ( n ), y ( n ), z ( n ), w ( n ), a , b , v ) n = n - 1 end subroutine end module","tags":"","url":"sourcefile/lebedev.f90.html"},{"title":"basis_api.F90 – OpenQP Fortran API","text":"Source Code !> @brief Basis ingestion API bridging external handles to OpenQP basis_set. !> @detail Collects electron shells and ECP data from C/handles, builds the !>         internal basis_set (cartesian AO layout), normalizes primitives, !>         and prints a compact basis/ECP summary to the log. !> @author Mohsen Mazaherifar !> @date November 2025 module basis_api use iso_c_binding , only : c_f_pointer , c_ptr , c_double use iso_fortran_env , only : real64 use physical_constants , only : UNITS_ANGSTROM use libecpint_wrapper implicit none !############################################################################### type , abstract :: base_shell integer :: id integer :: element_id integer , pointer :: n_exponents (:) real ( real64 ), pointer :: exponents (:) real ( real64 ), pointer :: coefficient (:) contains procedure ( base_shell_clear ), deferred , pass :: clear end type base_shell abstract interface subroutine base_shell_clear ( this ) import base_shell class ( base_shell ), intent ( inout ) :: this end subroutine base_shell_clear end interface !############################################################################### type , extends ( base_shell ) :: electron_shell integer :: angular_momentum integer :: harmonic = 0 !< 1 = pure spherical-harmonic shell, 0 = Cartesian type ( electron_shell ), pointer :: next => null () contains procedure :: clear => electron_shell_clear end type electron_shell !############################################################################### type , extends ( base_shell ) :: ecpdata integer :: n_angular_m integer , pointer :: ecp_zn (:) integer , pointer :: ecp_r_expo (:) integer , pointer :: ecp_am (:) real ( real64 ), pointer :: ecp_coord (:) contains procedure :: clear => ecpdata_clear end type ecpdata type ( electron_shell ), pointer :: head => null () type ( ecpdata ) :: ecp_head private public append_shell public append_ecp public map_shell2basis_set public print_basis contains !> @brief Append the current electron shell from an external handle. !> @detail Pulls one shell from `oqp_handle_get_info(c_handle)%elshell` and !>         pushes it to the internal linked list (`head`). !> @param[in] c_handle  Foreign handle carrying an `information` pointer. !> @note C binding: name=\"append_shell\". !> @author Mohsen !> @date November 2025 subroutine append_shell ( c_handle ) bind ( C , name = \"append_shell\" ) use c_interop , only : oqp_handle_t , oqp_handle_get_info use types , only : information type ( oqp_handle_t ) :: c_handle type ( information ), pointer :: inf inf => oqp_handle_get_info ( c_handle ) call oqp_append_shell ( inf ) end subroutine append_shell !> @brief Append ECP metadata from an external handle. !> @detail Copies global ECP arrays (per-element exponents/coeffs, AM, radii, !>         coords, and removed core Z) into `ecp_head` buffers. !> @param[in] c_handle  Foreign handle carrying an `information` pointer. !> @note C binding: name=\"append_ecp\". No-op if element_id==0 (no ECP). !> @author Mohsen !> @date November 2025 subroutine append_ecp ( c_handle ) bind ( C , name = \"append_ecp\" ) use c_interop , only : oqp_handle_t , oqp_handle_get_info use types , only : information type ( oqp_handle_t ) :: c_handle type ( information ), pointer :: inf inf => oqp_handle_get_info ( c_handle ) call oqp_append_ecp ( inf ) end subroutine append_ecp !> @brief Internal: stage ECP data from `information%elshell` into `ecp_head`. !> @param[in] info  Read-only `information` snapshot with ECP fields populated. !> @author Mohsen !> @date November 2025 subroutine oqp_append_ecp ( info ) use types , only : information type ( information ), intent ( in ) :: info real ( c_double ), pointer :: expo_ptr (:), coef_ptr (:), rexpo_ptr (:),& am_ptr (:), coord_ptr (:) integer ( c_int ) , pointer :: n_expo_ptr (:), ecp_zn_ptr (:) integer :: natm , f_expo_len natm = info % mol_prop % natom ! No ECP for this element: do NOT read the C/Python ecp_zn buffer (it is ! empty/short for non-ECP systems, so reading natm ints reads out of ! bounds -> garbage ecp_zn_num -> zeroed nuclear repulsion, nondeterm- ! inistically). No ECP means no core electrons are removed, so ecp_zn=0. if ( info % elshell % element_id . EQ . 0 ) then ecp_head % element_id = info % elshell % element_id allocate ( ecp_head % ecp_zn ( natm )) ecp_head % ecp_zn = 0 return end if call c_f_pointer ( info % elshell % ecp_zn , ecp_zn_ptr , [ natm ]) allocate ( ecp_head % ecp_zn ( natm )) ecp_head % ecp_zn = ecp_zn_ptr call c_f_pointer ( info % elshell % num_expo , n_expo_ptr , [ info % elshell % element_id ]) allocate ( ecp_head % n_exponents ( info % elshell % element_id )) ecp_head % n_exponents = n_expo_ptr f_expo_len = sum ( ecp_head % n_exponents ) call c_f_pointer ( info % elshell % expo , expo_ptr , [ f_expo_len ]) call c_f_pointer ( info % elshell % coef , coef_ptr , [ f_expo_len ]) call c_f_pointer ( info % elshell % ecp_rex , rexpo_ptr , [ f_expo_len ]) call c_f_pointer ( info % elshell % ecp_am , am_ptr , [ info % elshell % ecp_nam ]) call c_f_pointer ( info % elshell % ecp_coord , coord_ptr , [ 3 * info % elshell % element_id ]) ecp_head % element_id = info % elshell % element_id ecp_head % n_angular_m = info % elshell % ecp_nam allocate ( ecp_head % exponents ( f_expo_len )) allocate ( ecp_head % coefficient ( f_expo_len )) allocate ( ecp_head % ecp_r_expo ( f_expo_len )) allocate ( ecp_head % ecp_am ( info % elshell % ecp_nam )) allocate ( ecp_head % ecp_coord ( 3 * info % elshell % element_id )) ecp_head % exponents = expo_ptr ecp_head % coefficient = coef_ptr ecp_head % ecp_r_expo = rexpo_ptr ecp_head % ecp_am = am_ptr ecp_head % ecp_coord = coord_ptr ! UNITS_ANGSTROM end subroutine oqp_append_ecp !> @brief Internal: stage one electron shell from `information%elshell` to list. !> @param[in] info  Read-only `information` snapshot with shell fields populated. !> @note Maintains insertion order; computes n_exponents per shell. !> @date November 2025 subroutine oqp_append_shell ( info ) use types , only : information type ( information ), intent ( in ) :: info type ( electron_shell ), pointer :: new_node , temp real ( c_double ), pointer :: expo_ptr (:), coef_ptr (:) integer ( c_int ), pointer :: n_expo_ptr (:) integer :: n_expo call c_f_pointer ( info % elshell % num_expo , n_expo_ptr , [ 1 ]) n_expo = n_expo_ptr ( 1 ) call c_f_pointer ( info % elshell % expo , expo_ptr , [ n_expo ]) call c_f_pointer ( info % elshell % coef , coef_ptr , [ n_expo ]) allocate ( new_node ) new_node % id = info % elshell % id new_node % element_id = info % elshell % element_id new_node % angular_momentum = info % elshell % ang_mom new_node % harmonic = info % elshell % harmonic allocate ( new_node % exponents ( n_expo )) allocate ( new_node % coefficient ( n_expo )) allocate ( new_node % n_exponents ( 1 )) new_node % n_exponents = n_expo_ptr new_node % exponents = expo_ptr new_node % coefficient = coef_ptr new_node % next => null () if (. not . associated ( head )) then head => new_node else temp => head do while ( associated ( temp % next )) temp => temp % next end do temp % next => new_node end if end subroutine oqp_append_shell subroutine print_all_shells () bind ( C , name = \"print_all_shells\" ) type ( electron_shell ), pointer :: temp temp => head print * , \"Printing all shells:\" do while ( associated ( temp )) print * , \"Shell ID: \" , temp % id print * , \"Element ID: \" , temp % element_id print * , \"Angular Momentum: \" , temp % angular_momentum print * , \"Number of Exponents: \" , temp % n_exponents print * , \"Exponents: \" , temp % exponents print * , \"Coefficients: \" , temp % coefficient print * , \"----------------------\" temp => temp % next end do print * , \"----------------------\" end subroutine print_all_shells !> @brief Build `basis_set` from staged shells/ECP and finalize normalization. !> @detail Computes sizes (nbf, nshell, nprim), allocates arrays, copies !>         exponents/coeffs, AO offsets, origins, AM; normalizes primitives, !>         sets ECP params (if present), and clears staging lists. !> @param[inout] infos  Provides target `basis_set` (primary or alt by flag). !> @note Sets `basis%ecp_params%is_ecp` and `basis%ecp_zn_num` when ECP present. !> @throws Sets `infos%control%basis_set_issue=.false.` on entry (reserved). !> @date November 2025 subroutine map_shell2basis_set ( infos ) use basis_tools , only : basis_set use types , only : information use constants , only : NUM_CART_BF , num_ao type ( information ), target , intent ( inout ) :: infos class ( basis_set ), pointer :: basis type ( electron_shell ), pointer :: temp type ( electron_shell ), pointer :: temp1 integer :: nbf , nshell , nprim , mxcontr , mxam , ii integer :: n1 , n2 integer :: f_expo_len real ( real64 ), dimension (:), allocatable :: ex infos % control % basis_set_issue = . false . if ( infos % control % active_basis == 0 ) then basis => infos % basis else basis => infos % alt_basis end if if ( allocated ( basis % ex )) call basis % destroy () temp => head mxam = 0 mxcontr = 0 nbf = 0 nshell = 0 nprim = 0 ! Initialize nprim ii = 0 do while ( associated ( temp )) mxcontr = max ( mxcontr , temp % n_exponents ( 1 )) mxam = max ( mxam , temp % angular_momentum ) nshell = temp % id nprim = nprim + temp % n_exponents ( 1 ) nbf = nbf + num_ao ( temp % angular_momentum , temp % harmonic ) temp => temp % next ! Move to the next shell end do temp1 => head basis % mxam = mxam basis % mxcontr = mxcontr basis % nbf = nbf basis % nshell = nshell basis % nprim = nprim if (. not . allocated ( basis % ex )) allocate ( basis % ex ( nprim )) if (. not . allocated ( basis % cc )) allocate ( basis % cc ( nprim )) if (. not . allocated ( basis % bfnrm )) allocate ( basis % bfnrm ( nbf )) if (. not . allocated ( basis % g_offset )) allocate ( basis % g_offset ( nshell )) if (. not . allocated ( basis % origin )) allocate ( basis % origin ( nshell )) if (. not . allocated ( basis % am )) allocate ( basis % am ( nshell )) if (. not . allocated ( basis % harmonic )) allocate ( basis % harmonic ( nshell ), source = 0 ) if (. not . allocated ( basis % ncontr )) allocate ( basis % ncontr ( nshell )) if (. not . allocated ( basis % ao_offset )) allocate ( basis % ao_offset ( nshell )) if (. not . allocated ( basis % naos )) allocate ( basis % naos ( nshell )) if (. not . allocated ( basis % at_mx_dist2 )) allocate ( basis % at_mx_dist2 ( nbf )) if (. not . allocated ( basis % prim_mx_dist2 )) allocate ( basis % prim_mx_dist2 ( nprim )) if (. not . allocated ( basis % shell_mx_dist2 )) allocate ( basis % shell_mx_dist2 ( nshell )) if (. not . allocated ( basis % shell_centers )) allocate ( basis % shell_centers ( nshell , 3 )) if (. not . allocated ( ex )) allocate ( ex ( nprim )) do while ( associated ( temp1 )) ii = ii + 1 n2 = temp1 % n_exponents ( 1 ) basis % ncontr ( ii ) = n2 if ( ii == 1 ) then basis % g_offset ( 1 ) = 1 basis % ao_offset ( ii ) = 1 else basis % g_offset ( ii ) = basis % g_offset ( ii - 1 ) + n1 basis % ao_offset ( ii ) = basis % naos ( ii - 1 ) + basis % ao_offset ( ii - 1 ) end if basis % ex ( basis % g_offset ( ii ):( basis % g_offset ( ii ) + n2 - 1 )) = real ( temp1 % exponents , kind = real64 ) basis % cc ( basis % g_offset ( ii ):( basis % g_offset ( ii ) + n2 - 1 )) = real ( temp1 % coefficient , kind = real64 ) basis % origin ( ii ) = temp1 % element_id basis % am ( ii ) = temp1 % angular_momentum basis % harmonic ( ii ) = temp1 % harmonic basis % naos ( ii ) = num_ao ( temp1 % angular_momentum , temp1 % harmonic ) n1 = temp1 % n_exponents ( 1 ) temp1 => temp1 % next end do if (. not . allocated ( basis % ecp_zn_num )) allocate ( basis % ecp_zn_num ( maxval ( basis % origin ))) basis % ecp_zn_num = ecp_head % ecp_zn call basis % set_bfnorms () call basis % normalize_primitives () call head % clear () nullify ( head ) nullify ( temp ) nullify ( temp1 ) if ( ecp_head % element_id == 0 ) then basis % ecp_params % is_ecp = . false . return end if basis % ecp_params % is_ecp = . true . f_expo_len = sum ( ecp_head % n_exponents ) if (. not . allocated ( basis % ecp_params % ecp_ex )) allocate ( basis % ecp_params % ecp_ex ( f_expo_len )) if (. not . allocated ( basis % ecp_params % ecp_cc )) allocate ( basis % ecp_params % ecp_cc ( f_expo_len )) if (. not . allocated ( basis % ecp_params % ecp_coord )) allocate ( basis % ecp_params % ecp_coord ( size ( ecp_head % ecp_coord ))) if (. not . allocated ( basis % ecp_params % ecp_r_ex )) allocate ( basis % ecp_params % ecp_r_ex ( f_expo_len )) if (. not . allocated ( basis % ecp_params % ecp_am )) allocate ( basis % ecp_params % ecp_am ( size ( ecp_head % ecp_am ))) if (. not . allocated ( basis % ecp_params % n_expo )) allocate ( basis % ecp_params % n_expo ( size ( ecp_head % n_exponents ))) basis % ecp_params % ecp_ex = ecp_head % exponents basis % ecp_params % ecp_cc = ecp_head % coefficient basis % ecp_params % ecp_r_ex = ecp_head % ecp_r_expo basis % ecp_params % ecp_coord = ecp_head % ecp_coord basis % ecp_params % ecp_am = ecp_head % ecp_am basis % ecp_params % n_expo = ecp_head % n_exponents call ecp_head % clear () end subroutine map_shell2basis_set !> @brief Pretty-print the active basis (and ECP, if any) to the log file. !> @detail Lists element, shell AM, primitives with normalized coefficients; !>         for ECP atoms, prints removed core Z and per-term parameters. !> @param[inout] infos  Supplies basis, atom labels, and output filename. !> @date November 2025 subroutine print_basis ( infos ) use types , only : information use elements , only : ELEMENTS_SHORT_NAME use basis_tools , only : basis_set type ( information ), target , intent ( inout ) :: infos type ( basis_set ), pointer :: basis integer :: iw , i , j , atom , elem , end_i , ecp_counter character ( len = 1 ) :: orbit character ( len = 1 ), dimension ( 5 ) :: orbital_types = [ 'S' , 'P' , 'D' , 'F' , 'G' ] if ( infos % control % active_basis == 0 ) then basis => infos % basis else basis => infos % alt_basis end if open ( newunit = iw , file = infos % log_filename , position = \"append\" ) write ( iw , '(/,5X,\"====================== Basis Set Details ======================\")' ) atom = 0 ecp_counter = 0 write ( iw , '(/,17X, A,13X,A)' ) 'Exponent' , 'Normalized Coefficient' do j = 1 , basis % nshell if ( atom . NE . basis % origin ( j )) then elem = nint ( infos % atoms % zn ( infos % basis % origin ( j ))) write ( iw , '(5X, A2)' ) ELEMENTS_SHORT_NAME ( elem ) end if orbit = orbital_types ( basis % am ( j ) + 1 ) write ( iw , '(10X, A1)' ) orbit end_i = basis % g_offset ( j ) + basis % ncontr ( j ) - 1 do i = basis % g_offset ( j ), end_i write ( iw , '(15X, ES12.5, 15X, ES12.5)' ) basis % ex ( i ),& basis % cc ( i ) end do atom = basis % origin ( j ) end do if ( basis % ecp_params % is_ecp ) then do i = 1 , infos % mol_prop % natom if ( basis % ecp_zn_num ( i ) . EQ . 0 ) cycle ecp_counter = ecp_counter + 1 elem = nint ( infos % atoms % zn ( i )) write ( iw , '(5X, A2, A4)' ) ELEMENTS_SHORT_NAME ( elem ), '-ECP' write ( iw , '(5X, A, I5)' ) 'Core Electrons Removed:' , basis % ecp_zn_num ( i ) call ecp_printing ( basis , iw , ecp_counter ) end do end if write ( iw , '(/,5X,\"==================== End of Basis Set Data ====================\")' ) close ( iw ) end subroutine print_basis !> @brief Print ECP terms for atom j to the open unit `iw`. !> @param[in] basis  Basis with `ecp_params` populated. !> @param[in] iw     Fortran unit already opened for append. !> @param[in] j      Atom index (1-based). !> @date November 2025 subroutine ecp_printing ( basis , iw , j ) use basis_tools , only : basis_set class ( basis_set ) , intent ( in ) :: basis integer , intent ( in ) :: iw , j integer :: i , start_i , end_i if ( j > 1 ) then start_i = sum ( basis % ecp_params % n_expo ( 1 : j )) + 1 end_i = sum ( basis % ecp_params % n_expo ( 1 : j )) else start_i = 1 end_i = basis % ecp_params % n_expo ( j ) end if do i = start_i , end_i write ( iw , '(5X, I5, 5X, ES12.5, 5X, I5, 5X, ES12.5)' ) basis % ecp_params % ecp_am ( i ),& basis % ecp_params % ecp_cc ( i ), basis % ecp_params % ecp_r_ex ( i ),& basis % ecp_params % ecp_ex ( i ) end do end subroutine ecp_printing !> @brief Clear an electron_shell node and recursively clear its `next` chain. !> @date November 2025 subroutine electron_shell_clear ( this ) class ( electron_shell ), intent ( inout ) :: this if ( associated ( this % n_exponents )) deallocate ( this % n_exponents ) if ( associated ( this % exponents )) deallocate ( this % exponents ) if ( associated ( this % coefficient )) deallocate ( this % coefficient ) this % angular_momentum = 0 this % id = 0 this % element_id = 0 if ( associated ( this % next )) then call this % next % clear () nullify ( this % next ) end if end subroutine electron_shell_clear !> @brief Clear staged ECP buffers in `ecpdata`. !> @date November 2025 subroutine ecpdata_clear ( this ) class ( ecpdata ), intent ( inout ) :: this if ( associated ( this % n_exponents )) deallocate ( this % n_exponents ) if ( associated ( this % exponents )) deallocate ( this % exponents ) if ( associated ( this % coefficient )) deallocate ( this % coefficient ) if ( associated ( this % ecp_zn )) deallocate ( this % ecp_zn ) if ( associated ( this % ecp_r_expo )) deallocate ( this % ecp_r_expo ) if ( associated ( this % ecp_am )) deallocate ( this % ecp_am ) if ( associated ( this % ecp_coord )) deallocate ( this % ecp_coord ) this % n_angular_m = 0 this % id = 0 this % element_id = 0 end subroutine ecpdata_clear end module basis_api","tags":"","url":"sourcefile/basis_api.f90.html"},{"title":"rys.F90 – OpenQP Fortran API","text":"Source Code module rys use precision , only : dp use constants , only : pi use rys_lut , only : mxrys , maux , nauxs , maprys , xasymp , rts_hermit , wts_hermit , rtsaux , wtsaux implicit none real ( dp ), parameter :: eps_eig = 1.0e-14_dp real ( dp ), parameter :: pio4 = pi / 4.0_dp type rys_root_t integer :: nroots = - 1 real ( dp ) :: X real ( dp ) :: U ( mxrys ), W ( mxrys ) contains procedure , public :: evaluate , evaluate_testing end type rys_root_t private public rys_root_t contains subroutine evaluate ( this ) class ( rys_root_t ), intent ( inout ) :: this select case ( this % nroots ) case ( 1 ); call rys_rt1 ( this % x , this % U ( 1 ), this % W ( 1 )) case ( 2 ); call rys_rt2 ( this % x , this % U ( 1 : 2 ), this % W ( 1 : 2 )) case ( 3 ); call rys_rt3 ( this % x , this % U ( 1 : 3 ), this % W ( 1 : 3 )) case ( 4 ); call rys_rt4 ( this % x , this % U ( 1 : 4 ), this % W ( 1 : 4 )) case ( 5 ); call rys_rt5 ( this % x , this % U ( 1 : 5 ), this % W ( 1 : 5 )) case ( 6 : mxrys ); call rys_general ( this % x , this % U ( 1 : this % nroots ), this % W ( 1 : this % nroots ), this % nroots ) case default error stop \"internal error in rys\" end select end subroutine evaluate subroutine evaluate_testing ( this ) class ( rys_root_t ), intent ( inout ) :: this this % U = 0.0_dp this % W = 0.0_dp call rys_general ( this % x , this % U ( 1 : this % nroots ), this % W ( 1 : this % nroots ), this % nroots ) end subroutine evaluate_testing subroutine rys_rt1 ( x , r , w ) real ( KIND = dp ), intent ( IN ) :: & x real ( KIND = dp ), intent ( OUT ) :: & r real ( KIND = dp ), intent ( OUT ) :: & w real ( KIND = dp ) :: & f1 , y , recx , e if ( x <= 3.0e-07_dp ) then r = ( 2.5e+00_dp - x ) / ( 7.5e+00_dp - x ) w = 1.0e+00_dp - x / 3.0e+00_dp elseif ( x <= 1.0e+00_dp ) then f1 = (((((((( - 8.36313918003957e-08_dp * x + & 1.21222603512827e-06_dp ) * x - & 1.15662609053481e-05_dp ) * x + & 9.25197374512647e-05_dp ) * x - & 6.40994113129432e-04_dp ) * x + & 3.78787044215009e-03_dp ) * x - & 1.85185172458485e-02_dp ) * x + & 7.14285713298222e-02_dp ) * x - & 1.99999999997023e-01_dp ) * x + & 3.33333333333318e-01_dp w = 2 * x * f1 + exp ( - x ) r = f1 / w elseif ( x <= 3.0e+00_dp ) then y = x - 2.0e+00_dp f1 = (((((((((( - 1.61702782425558e-10_dp * y + & 1.96215250865776e-09_dp ) * y - & 2.14234468198419e-08_dp ) * y + & 2.17216556336318e-07_dp ) * y - & 1.98850171329371e-06_dp ) * y + & 1.62429321438911e-05_dp ) * y - & 1.16740298039895e-04_dp ) * y + & 7.24888732052332e-04_dp ) * y - & 3.79490003707156e-03_dp ) * y + & 1.61723488664661e-02_dp ) * y - & 5.29428148329736e-02_dp ) * y + & 1.15702180856167e-01_dp w = 2 * x * f1 + exp ( - x ) r = f1 / w elseif ( x <= 5.0e+00_dp ) then y = x - 4.0e+00_dp f1 = (((((((((( - 2.62453564772299e-11_dp * y + & 3.24031041623823e-10_dp ) * y - & 3.614965656163e-09_dp ) * y + & 3.760256799971e-08_dp ) * y - & 3.553558319675e-07_dp ) * y + & 3.022556449731e-06_dp ) * y - & 2.290098979647e-05_dp ) * y + & 1.526537461148e-04_dp ) * y - & 8.81947375894379e-04_dp ) * y + & 4.33207949514611e-03_dp ) * y - & 1.75257821619926e-02_dp ) * y + & 5.28406320615584e-02_dp w = 2 * x * f1 + exp ( - x ) r = f1 / w elseif ( x <= 1 0.0e+00_dp ) then e = exp ( - x ) recx = 1.0e+00_dp / x w = (((((( 4.6897511375022e-01_dp * recx - & 6.9955602298985e-01_dp ) * recx + & 5.3689283271887e-01_dp ) * recx - & 3.2883030418398e-01_dp ) * recx + & 2.4645596956002e-01_dp ) * recx - & 4.9984072848436e-01_dp ) * recx - & 3.1501078774085e-06_dp ) * e + sqrt ( PIo4 * recx ) f1 = recx * ( w - e ) / 2 r = f1 / w elseif ( x <= 1 5.0e+00_dp ) then e = exp ( - x ) recx = 1.0e+00_dp / x w = ((( - 1.8784686463512e-01_dp * recx + & 2.2991849164985e-01_dp ) * recx - & 4.9893752514047e-01_dp ) * recx - & 2.1916512131607e-05_dp ) * e + sqrt ( PIo4 * recx ) f1 = recx * ( w - e ) / 2 r = f1 / w elseif ( x <= 3 3.0e+00_dp ) then e = exp ( - x ) recx = 1.0e+00_dp / x w = (( 1.9623264149430e-01_dp * recx - & 4.9695241464490e-01_dp ) * recx - & 6.0156581186481e-05_dp ) * e + sqrt ( PIo4 * recx ) f1 = recx * ( w - e ) / 2 r = f1 / w else recx = 1.0e+00_dp / x w = sqrt ( PIo4 * recx ) r = 0.5e+00_dp * recx end if r = r / ( 1.0e00_dp - r ) end subroutine rys_rt1 !----------------------------------------------------------------- subroutine rys_rt2 ( x , r , w ) real ( KIND = dp ), intent ( IN ) :: & x real ( KIND = dp ), intent ( OUT ) :: & r ( 2 ), w ( 2 ) real ( KIND = dp ), parameter :: & r12 = 2.75255128608411e-01_dp , & r22 = 2.72474487139158e+00_dp , & w22 = 9.17517095361369e-02_dp real ( KIND = dp ) :: & f1 , y , recx , e , r1 , r2 , w1 , w2 if ( x <= 3.0e-07_dp ) then r1 = 1.30693606237085e-01_dp - 2.90430236082028e-02_dp * x r2 = 2.86930639376291e+00_dp - 6.37623643058102e-01_dp * x w1 = 6.52145154862545e-01_dp - 1.22713621927067e-01_dp * x w2 = 3.47854845137453e-01_dp - 2.10619711404725e-01_dp * x elseif ( x <= 1.0e+00_dp ) then f1 = (((((((( - 8.36313918003957e-08_dp * x + & 1.21222603512827e-06_dp ) * x - & 1.15662609053481e-05_dp ) * x + & 9.25197374512647e-05_dp ) * x - & 6.40994113129432e-04_dp ) * x + & 3.78787044215009e-03_dp ) * x - & 1.85185172458485e-02_dp ) * x + & 7.14285713298222e-02_dp ) * x - & 1.99999999997023e-01_dp ) * x + & 3.33333333333318e-01_dp w1 = 2 * x * f1 + exp ( - x ) r1 = ((((((( - 2.35234358048491e-09_dp * x + & 2.49173650389842e-08_dp ) * x - & 4.558315364581e-08_dp ) * x - & 2.447252174587e-06_dp ) * x + & 4.743292959463e-05_dp ) * x - & 5.33184749432408e-04_dp ) * x + & 4.44654947116579e-03_dp ) * x - & 2.90430236084697e-02_dp ) * x + & 1.30693606237085e-01_dp r2 = ((((((( - 2.47404902329170e-08_dp * x + & 2.36809910635906e-07_dp ) * x + & 1.835367736310e-06_dp ) * x - & 2.066168802076e-05_dp ) * x - & 1.345693393936e-04_dp ) * x - & 5.88154362858038e-05_dp ) * x + & 5.32735082098139e-02_dp ) * x - & 6.37623643056745e-01_dp ) * x + & 2.86930639376289e+00_dp w2 = (( f1 - w1 ) * r1 + f1 ) * ( 1.0e+00_dp + r2 ) / ( r2 - r1 ) w1 = w1 - w2 elseif ( x <= 3.0e+00_dp ) then y = x - 2.0e+00_dp f1 = (((((((((( - 1.61702782425558e-10_dp * y + & 1.96215250865776e-09_dp ) * y - & 2.14234468198419e-08_dp ) * y + & 2.17216556336318e-07_dp ) * y - & 1.98850171329371e-06_dp ) * y + & 1.62429321438911e-05_dp ) * y - & 1.16740298039895e-04_dp ) * y + & 7.24888732052332e-04_dp ) * y - & 3.79490003707156e-03_dp ) * y + & 1.61723488664661e-02_dp ) * y - & 5.29428148329736e-02_dp ) * y + & 1.15702180856167e-01_dp w1 = 2 * x * f1 + exp ( - x ) r1 = ((((((((( - 6.36859636616415e-12_dp * y + & 8.47417064776270e-11_dp ) * y - & 5.152207846962e-10_dp ) * y - & 3.846389873308e-10_dp ) * y + & 8.472253388380e-08_dp ) * y - & 1.85306035634293e-06_dp ) * y + & 2.47191693238413e-05_dp ) * y - & 2.49018321709815e-04_dp ) * y + & 2.19173220020161e-03_dp ) * y - & 1.63329339286794e-02_dp ) * y + & 8.68085688285261e-02_dp r2 = ((((((((( 1.45331350488343e-10_dp * y + & 2.07111465297976e-09_dp ) * y - & 1.878920917404e-08_dp ) * y - & 1.725838516261e-07_dp ) * y + & 2.247389642339e-06_dp ) * y + & 9.76783813082564e-06_dp ) * y - & 1.93160765581969e-04_dp ) * y - & 1.58064140671893e-03_dp ) * y + & 4.85928174507904e-02_dp ) * y - & 4.30761584997596e-01_dp ) * y + & 1.80400974537950e+00_dp w2 = (( f1 - w1 ) * r1 + f1 ) * ( 1.0e+00_dp + r2 ) / ( r2 - r1 ) w1 = w1 - w2 elseif ( x <= 5.0e+00_dp ) then y = x - 4.0e+00_dp f1 = (((((((((( - 2.62453564772299e-11_dp * y + & 3.24031041623823e-10_dp ) * y - & 3.614965656163e-09_dp ) * y + & 3.760256799971e-08_dp ) * y - & 3.553558319675e-07_dp ) * y + & 3.022556449731e-06_dp ) * y - & 2.290098979647e-05_dp ) * y + & 1.526537461148e-04_dp ) * y - & 8.81947375894379e-04_dp ) * y + & 4.33207949514611e-03_dp ) * y - & 1.75257821619926e-02_dp ) * y + & 5.28406320615584e-02_dp w1 = 2 * x * f1 + exp ( - x ) r1 = (((((((( - 4.11560117487296e-12_dp * y + & 7.10910223886747e-11_dp ) * y - & 1.73508862390291e-09_dp ) * y + & 5.93066856324744e-08_dp ) * y - & 9.76085576741771e-07_dp ) * y + & 1.08484384385679e-05_dp ) * y - & 1.12608004981982e-04_dp ) * y + & 1.16210907653515e-03_dp ) * y - & 9.89572595720351e-03_dp ) * y + & 6.12589701086408e-02_dp r2 = ((((((((( - 1.80555625241001e-10_dp * y + & 5.44072475994123e-10_dp ) * y + & 1.603498045240e-08_dp ) * y - & 1.497986283037e-07_dp ) * y - & 7.017002532106e-07_dp ) * y + & 1.85882653064034e-05_dp ) * y - & 2.04685420150802e-05_dp ) * y - & 2.49327728643089e-03_dp ) * y + & 3.56550690684281e-02_dp ) * y - & 2.60417417692375e-01_dp ) * y + & 1.12155283108289e+00_dp w2 = (( f1 - w1 ) * r1 + f1 ) * ( 1.0e+00_dp + r2 ) / ( r2 - r1 ) w1 = w1 - w2 elseif ( x <= 1 0.0e+00_dp ) then e = exp ( - x ) recx = 1.0e+00_dp / x w1 = (((((( 4.6897511375022e-01_dp * recx - & 6.9955602298985e-01_dp ) * recx + & 5.3689283271887e-01_dp ) * recx - & 3.2883030418398e-01_dp ) * recx + & 2.4645596956002e-01_dp ) * recx - & 4.9984072848436e-01_dp ) * recx - & 3.1501078774085e-06_dp ) * e + sqrt ( PIo4 * recx ) f1 = recx * ( w1 - e ) / 2 y = x - 7.5e+00_dp r1 = ((((((((((((( - 1.43632730148572e-16_dp * y + & 2.38198922570405e-16_dp ) * y + & 1.358319618800e-14_dp ) * y - & 7.064522786879e-14_dp ) * y - & 7.719300212748e-13_dp ) * y + & 7.802544789997e-12_dp ) * y + & 6.628721099436e-11_dp ) * y - & 1.775564159743e-09_dp ) * y + & 1.713828823990e-08_dp ) * y - & 1.497500187053e-07_dp ) * y + & 2.283485114279e-06_dp ) * y - & 3.76953869614706e-05_dp ) * y + & 4.74791204651451e-04_dp ) * y - & 4.60448960876139e-03_dp ) * y + & 3.72458587837249e-02_dp r2 = (((((((((((( 2.48791622798900e-14_dp * y - & 1.36113510175724e-13_dp ) * y - & 2.224334349799e-12_dp ) * y + & 4.190559455515e-11_dp ) * y - & 2.222722579924e-10_dp ) * y - & 2.624183464275e-09_dp ) * y + & 6.128153450169e-08_dp ) * y - & 4.383376014528e-07_dp ) * y - & 2.49952200232910e-06_dp ) * y + & 1.03236647888320e-04_dp ) * y - & 1.44614664924989e-03_dp ) * y + & 1.35094294917224e-02_dp ) * y - & 9.53478510453887e-02_dp ) * y + & 5.44765245686790e-01_dp w2 = (( f1 - w1 ) * r1 + f1 ) * ( 1.0e+00_dp + r2 ) / ( r2 - r1 ) w1 = w1 - w2 elseif ( x <= 1 5.0e+00_dp ) then e = exp ( - x ) recx = 1.0e+00_dp / x w1 = ((( - 1.8784686463512e-01_dp * recx + & 2.2991849164985e-01_dp ) * recx - & 4.9893752514047e-01_dp ) * recx - & 2.1916512131607e-05_dp ) * e + & sqrt ( PIo4 * recx ) f1 = recx * ( w1 - e ) / 2 r1 = (((( - 1.01041157064226e-05_dp * x + & 1.19483054115173e-03_dp ) * x - & 6.73760231824074e-02_dp ) * x + & 1.25705571069895e+00_dp ) * x + & ((( - 8.57609422987199e+03_dp * recx + & 5.91005939591842e+03_dp ) * recx - & 1.70807677109425e+03_dp ) * recx + & 2.64536689959503e+02_dp ) * recx - & 2.38570496490846e+01_dp ) * e + r12 / ( x - r12 ) r2 = ((( 3.39024225137123e-04_dp * x - & 9.34976436343509e-02_dp ) * x - & 4.22216483306320e+00_dp ) * x + & ((( - 2.08457050986847e+03_dp * recx - & 1.04999071905664e+03_dp ) * recx + & 3.39891508992661e+02_dp ) * recx - & 1.56184800325063e+02_dp ) * recx + & 8.00839033297501e+00_dp ) * e + & r22 / ( x - r22 ) w2 = (( f1 - w1 ) * r1 + f1 ) * & ( 1.0e+00_dp + r2 ) / ( r2 - r1 ) w1 = w1 - w2 elseif ( x <= 3 3.0e+00_dp ) then e = exp ( - x ) recx = 1.0e+00_dp / x w1 = (( 1.9623264149430e-01_dp * recx - & 4.9695241464490e-01_dp ) * recx - & 6.0156581186481e-05_dp ) * e + sqrt ( PIo4 * recx ) f1 = recx * ( w1 - e ) / 2 r1 = (((( - 1.14906395546354e-06_dp * x + & 1.76003409708332e-04_dp ) * x - & 1.71984023644904e-02_dp ) * x - & 1.37292644149838e-01_dp ) * x + & ( - 4.75742064274859e+01_dp * recx + & 9.21005186542857e+00_dp ) * recx - & 2.31080873898939e-02_dp ) * e + r12 / ( x - r12 ) r2 = ((( 3.64921633404158e-04_dp * x - & 9.71850973831558e-02_dp ) * x - & 4.02886174850252e+00_dp ) * x + & ( - 1.35831002139173e+02_dp * recx - & 8.66891724287962e+01_dp ) * recx + & 2.98011277766958e+00_dp ) * e + r22 / ( x - r22 ) w2 = (( f1 - w1 ) * r1 + f1 ) * & ( 1.0e+00_dp + r2 ) / ( r2 - r1 ) w1 = w1 - w2 elseif ( x <= 4 0.0e+00_dp ) then w1 = sqrt ( PIo4 / x ) e = exp ( - x ) r1 = ( - 8.78947307498880e-01_dp * x + & 1.09243702330261e+01_dp ) * e + r12 / ( x - r12 ) r2 = ( - 9.28903924275977e+00_dp * x + & 8.10642367843811e+01_dp ) * e + r22 / ( x - r22 ) w2 = ( 4.46857389308400e+00_dp * x - & 7.79250653461045e+01_dp ) * e + w22 * w1 w1 = w1 - w2 else r1 = r12 / ( x - r12 ) r2 = r22 / ( x - r22 ) w1 = sqrt ( PIo4 / x ) w2 = w22 * w1 w1 = w1 - w2 end if r = ( / r1 , r2 / ) w = ( / w1 , w2 / ) end subroutine rys_rt2 !----------------------------------------------------------------- subroutine rys_rt3 ( x , r , w ) real ( KIND = dp ), intent ( IN ) :: & x real ( KIND = dp ), intent ( OUT ) :: & r ( 3 ), w ( 3 ) real ( KIND = dp ), parameter :: & r13 = 1.90163509193487e-01_dp , & r23 = 1.78449274854325e+00_dp , & w23 = 1.77231492083829e-01_dp , & r33 = 5.52534374226326e+00_dp , & w33 = 5.11156880411248e-03_dp real ( KIND = dp ) :: & f1 , f2 , y , recx , e , & a1 , a2 , t1 , t2 , t3 , r1 , r2 , r3 , w1 , w2 , w3 if ( x <= 3.0e-07_dp ) then r1 = 6.03769246832797e-02_dp - & 9.28875764357368e-03_dp * x r2 = 7.76823355931043e-01_dp - & 1.19511285527878e-01_dp * x r3 = 6.66279971938567e+00_dp - & 1.02504611068957e+00_dp * x w1 = 4.67913934572691e-01_dp - & 5.64876917232519e-02_dp * x w2 = 3.60761573048137e-01_dp - & 1.49077186455208e-01_dp * x w3 = 1.71324492379169e-01_dp - & 1.27768455150979e-01_dp * x elseif ( x <= 1.0e+00_dp ) then r1 = (((((( - 5.10186691538870e-10_dp * x + & 2.40134415703450e-08_dp ) * x - & 5.01081057744427e-07_dp ) * x + & 7.58291285499256e-06_dp ) * x - & 9.55085533670919e-05_dp ) * x + & 1.02893039315878e-03_dp ) * x - & 9.28875764374337e-03_dp ) * x + & 6.03769246832810e-02_dp r2 = (((((( - 1.29646524960555e-08_dp * x + & 7.74602292865683e-08_dp ) * x + & 1.56022811158727e-06_dp ) * x - & 1.58051990661661e-05_dp ) * x - & 3.30447806384059e-04_dp ) * x + & 9.74266885190267e-03_dp ) * x - & 1.19511285526388e-01_dp ) * x + & 7.76823355931033e-01_dp r3 = (((((( - 9.28536484109606e-09_dp * x - & 3.02786290067014e-07_dp ) * x - & 2.50734477064200e-06_dp ) * x - & 7.32728109752881e-06_dp ) * x + & 2.44217481700129e-04_dp ) * x + & 4.94758452357327e-02_dp ) * x - & 1.02504611065774e+00_dp ) * x + & 6.66279971938553e+00_dp f2 = (((((((( - 7.60911486098850e-08_dp * x + & 1.09552870123182e-06_dp ) * x - & 1.03463270693454e-05_dp ) * x + & 8.16324851790106e-05_dp ) * x - & 5.55526624875562e-04_dp ) * x + & 3.20512054753924e-03_dp ) * x - & 1.51515139838540e-02_dp ) * x + & 5.55555554649585e-02_dp ) * x - & 1.42857142854412e-01_dp ) * x + & 1.99999999999986e-01_dp e = exp ( - x ) f1 = ( 2 * x * f2 + e ) / 3.0e+00_dp w1 = 2 * x * f1 + e t1 = r1 / ( r1 + 1.0e+00_dp ) t2 = r2 / ( r2 + 1.0e+00_dp ) t3 = r3 / ( r3 + 1.0e+00_dp ) a2 = f2 - t1 * f1 a1 = f1 - t1 * w1 w3 = ( a2 - t2 * a1 ) / (( t3 - t2 ) * ( t3 - t1 )) w2 = ( t3 * a1 - a2 ) / (( t3 - t2 ) * ( t2 - t1 )) w1 = w1 - w2 - w3 elseif ( x <= 3.0e+00_dp ) then y = x - 2.0e+00_dp r1 = (((((((( 1.44687969563318e-12_dp * y + & 4.85300143926755e-12_dp ) * y - & 6.55098264095516e-10_dp ) * y + & 1.56592951656828e-08_dp ) * y - & 2.60122498274734e-07_dp ) * y + & 3.86118485517386e-06_dp ) * y - & 5.13430986707889e-05_dp ) * y + & 6.03194524398109e-04_dp ) * y - & 6.11219349825090e-03_dp ) * y + & 4.52578254679079e-02_dp r2 = ((((((( 6.95964248788138e-10_dp * y - & 5.35281831445517e-09_dp ) * y - & 6.745205954533e-08_dp ) * y + & 1.502366784525e-06_dp ) * y + & 9.923326947376e-07_dp ) * y - & 3.89147469249594e-04_dp ) * y + & 7.51549330892401e-03_dp ) * y - & 8.48778120363400e-02_dp ) * y + & 5.73928229597613e-01_dp r3 = (((((((( - 2.81496588401439e-10_dp * y + & 3.61058041895031e-09_dp ) * y + & 4.53631789436255e-08_dp ) * y - & 1.40971837780847e-07_dp ) * y - & 6.05865557561067e-06_dp ) * y - & 5.15964042227127e-05_dp ) * y + & 3.34761560498171e-05_dp ) * y + & 5.04871005319119e-02_dp ) * y - & 8.24708946991557e-01_dp ) * y + & 4.81234667357205e+00_dp f2 = (((((((((( - 1.48044231072140e-10_dp * y + & 1.78157031325097e-09_dp ) * y - & 1.92514145088973e-08_dp ) * y + & 1.92804632038796e-07_dp ) * y - & 1.73806555021045e-06_dp ) * y + & 1.39195169625425e-05_dp ) * y - & 9.74574633246452e-05_dp ) * y + & 5.83701488646511e-04_dp ) * y - & 2.89955494844975e-03_dp ) * y + & 1.13847001113810e-02_dp ) * y - & 3.23446977320647e-02_dp ) * y + & 5.29428148329709e-02_dp e = exp ( - x ) f1 = ( 2 * x * f2 + e ) / 3.0e+00_dp w1 = 2 * x * f1 + e t1 = r1 / ( r1 + 1.0e+00_dp ) t2 = r2 / ( r2 + 1.0e+00_dp ) t3 = r3 / ( r3 + 1.0e+00_dp ) a2 = f2 - t1 * f1 a1 = f1 - t1 * w1 w3 = ( a2 - t2 * a1 ) / (( t3 - t2 ) * ( t3 - t1 )) w2 = ( t3 * a1 - a2 ) / (( t3 - t2 ) * ( t2 - t1 )) w1 = w1 - w2 - w3 elseif ( x <= 5.0e+00_dp ) then y = x - 4.0e+00_dp r1 = ((((((( 1.44265709189601e-11_dp * y - & 4.66622033006074e-10_dp ) * y + & 7.649155832025e-09_dp ) * y - & 1.229940017368e-07_dp ) * y + & 2.026002142457e-06_dp ) * y - & 2.87048671521677e-05_dp ) * y + & 3.70326938096287e-04_dp ) * y - & 4.21006346373634e-03_dp ) * y + & 3.50898470729044e-02_dp r2 = (((((((( - 2.65526039155651e-11_dp * y + & 1.97549041402552e-10_dp ) * y + & 2.15971131403034e-09_dp ) * y - & 7.95045680685193e-08_dp ) * y + & 5.15021914287057e-07_dp ) * y + & 1.11788717230514e-05_dp ) * y - & 3.33739312603632e-04_dp ) * y + & 5.30601428208358e-03_dp ) * y - & 5.93483267268959e-02_dp ) * y + & 4.31180523260239e-01_dp r3 = (((((((( - 3.92833750584041e-10_dp * y - & 4.16423229782280e-09_dp ) * y + & 4.42413039572867e-08_dp ) * y + & 6.40574545989551e-07_dp ) * y - & 3.05512456576552e-06_dp ) * y - & 1.05296443527943e-04_dp ) * y - & 6.14120969315617e-04_dp ) * y + & 4.89665802767005e-02_dp ) * y - & 6.24498381002855e-01_dp ) * y + & 3.36412312243724e+00_dp f2 = (((((((((( - 2.36788772599074e-11_dp * y + & 2.89147476459092e-10_dp ) * y - & 3.18111322308846e-09_dp ) * y + & 3.25336816562485e-08_dp ) * y - & 3.00873821471489e-07_dp ) * y + & 2.48749160874431e-06_dp ) * y - & 1.81353179793672e-05_dp ) * y + & 1.14504948737066e-04_dp ) * y - & 6.10614987696677e-04_dp ) * y + & 2.64584212770942e-03_dp ) * y - & 8.66415899015349e-03_dp ) * y + & 1.75257821619922e-02_dp e = exp ( - x ) f1 = (( x + x ) * f2 + e ) / 3.0e+00_dp w1 = ( x + x ) * f1 + e t1 = r1 / ( r1 + 1.0e+00_dp ) t2 = r2 / ( r2 + 1.0e+00_dp ) t3 = r3 / ( r3 + 1.0e+00_dp ) a2 = f2 - t1 * f1 a1 = f1 - t1 * w1 w3 = ( a2 - t2 * a1 ) / (( t3 - t2 ) * ( t3 - t1 )) w2 = ( t3 * a1 - a2 ) / (( t3 - t2 ) * ( t2 - t1 )) w1 = w1 - w2 - w3 elseif ( x <= 1 0.0e+00_dp ) then e = exp ( - x ) recx = 1.0e+00_dp / x w1 = (((((( 4.6897511375022e-01_dp * recx - & 6.9955602298985e-01_dp ) * recx + & 5.3689283271887e-01_dp ) * recx - & 3.2883030418398e-01_dp ) * recx + & 2.4645596956002e-01_dp ) * recx - & 4.9984072848436e-01_dp ) * recx - & 3.1501078774085e-06_dp ) * e + sqrt ( PIo4 * recx ) f1 = recx * ( w1 - e ) / 2 f2 = recx * ( f1 + f1 + f1 - e ) / 2 y = x - 7.5e+00_dp r1 = ((((((((((( 5.74429401360115e-16_dp * y + & 7.11884203790984e-16_dp ) * y - & 6.736701449826e-14_dp ) * y - & 6.264613873998e-13_dp ) * y + & 1.315418927040e-11_dp ) * y - & 4.23879635610964e-11_dp ) * y + & 1.39032379769474e-09_dp ) * y - & 4.65449552856856e-08_dp ) * y + & 7.34609900170759e-07_dp ) * y - & 1.08656008854077e-05_dp ) * y + & 1.77930381549953e-04_dp ) * y - & 2.39864911618015e-03_dp ) * y + & 2.39112249488821e-02_dp r2 = ((((((((((( 1.13464096209120e-14_dp * y + & 6.99375313934242e-15_dp ) * y - & 8.595618132088e-13_dp ) * y - & 5.293620408757e-12_dp ) * y - & 2.492175211635e-11_dp ) * y + & 2.73681574882729e-09_dp ) * y - & 1.06656985608482e-08_dp ) * y - & 4.40252529648056e-07_dp ) * y + & 9.68100917793911e-06_dp ) * y - & 1.68211091755327e-04_dp ) * y + & 2.69443611274173e-03_dp ) * y - & 3.23845035189063e-02_dp ) * y + & 2.75969447451882e-01_dp r3 = (((((((((((( 6.66339416996191e-15_dp * y + & 1.84955640200794e-13_dp ) * y - & 1.985141104444e-12_dp ) * y - & 2.309293727603e-11_dp ) * y + & 3.917984522103e-10_dp ) * y + & 1.663165279876e-09_dp ) * y - & 6.205591993923e-08_dp ) * y + & 8.769581622041e-09_dp ) * y + & 8.97224398620038e-06_dp ) * y - & 3.14232666170796e-05_dp ) * y - & 1.83917335649633e-03_dp ) * y + & 3.51246831672571e-02_dp ) * y - & 3.22335051270860e-01_dp ) * y + & 1.73582831755430e+00_dp t1 = r1 / ( r1 + 1.0e+00_dp ) t2 = r2 / ( r2 + 1.0e+00_dp ) t3 = r3 / ( r3 + 1.0e+00_dp ) a2 = f2 - t1 * f1 a1 = f1 - t1 * w1 w3 = ( a2 - t2 * a1 ) / (( t3 - t2 ) * ( t3 - t1 )) w2 = ( t3 * a1 - a2 ) / (( t3 - t2 ) * ( t2 - t1 )) w1 = w1 - w2 - w3 elseif ( x <= 1 5.0e+00_dp ) then e = exp ( - x ) recx = 1.0e+00_dp / x w1 = ((( - 1.8784686463512e-01_dp * recx + & 2.2991849164985e-01_dp ) * recx - & 4.9893752514047e-01_dp ) * recx - & 2.1916512131607e-05_dp ) * e + sqrt ( PIo4 * recx ) f1 = recx * ( w1 - e ) / 2 f2 = recx * ( f1 + f1 + f1 - e ) / 2 y = x - 1 2.5e+00_dp r1 = ((((((((((( 4.42133001283090e-16_dp * y - & 2.77189767070441e-15_dp ) * y - & 4.084026087887e-14_dp ) * y + & 5.379885121517e-13_dp ) * y + & 1.882093066702e-12_dp ) * y - & 8.67286219861085e-11_dp ) * y + & 7.11372337079797e-10_dp ) * y - & 3.55578027040563e-09_dp ) * y + & 1.29454702851936e-07_dp ) * y - & 4.14222202791434e-06_dp ) * y + & 8.04427643593792e-05_dp ) * y - & 1.18587782909876e-03_dp ) * y + & 1.53435577063174e-02_dp r2 = ((((((((((( 6.85146742119357e-15_dp * y - & 1.08257654410279e-14_dp ) * y - & 8.579165965128e-13_dp ) * y + & 6.642452485783e-12_dp ) * y + & 4.798806828724e-11_dp ) * y - & 1.13413908163831e-09_dp ) * y + & 7.08558457182751e-09_dp ) * y - & 5.59678576054633e-08_dp ) * y + & 2.51020389884249e-06_dp ) * y - & 6.63678914608681e-05_dp ) * y + & 1.11888323089714e-03_dp ) * y - & 1.45361636398178e-02_dp ) * y + & 1.65077877454402e-01_dp r3 = (((((((((((( 3.20622388697743e-15_dp * y - & 2.73458804864628e-14_dp ) * y - & 3.157134329361e-13_dp ) * y + & 8.654129268056e-12_dp ) * y - & 5.625235879301e-11_dp ) * y - & 7.718080513708e-10_dp ) * y + & 2.064664199164e-08_dp ) * y - & 1.567725007761e-07_dp ) * y - & 1.57938204115055e-06_dp ) * y + & 6.27436306915967e-05_dp ) * y - & 1.01308723606946e-03_dp ) * y + & 1.13901881430697e-02_dp ) * y - & 1.01449652899450e-01_dp ) * y + & 7.77203937334739e-01_dp t1 = r1 / ( r1 + 1.0e+00_dp ) t2 = r2 / ( r2 + 1.0e+00_dp ) t3 = r3 / ( r3 + 1.0e+00_dp ) a2 = f2 - t1 * f1 a1 = f1 - t1 * w1 w3 = ( a2 - t2 * a1 ) / (( t3 - t2 ) * ( t3 - t1 )) w2 = ( t3 * a1 - a2 ) / (( t3 - t2 ) * ( t2 - t1 )) w1 = w1 - w2 - w3 elseif ( x <= 2 0.0e+00_dp ) then e = exp ( - x ) recx = 1.0e+00_dp / x w1 = (( 1.9623264149430e-01_dp * recx - & 4.9695241464490e-01_dp ) * recx - & 6.0156581186481e-05_dp ) * e + sqrt ( PIo4 * recx ) f1 = recx * ( w1 - e ) / 2 f2 = recx * ( f1 + f1 + f1 - e ) / 2 r1 = (((((( - 2.43270989903742e-06_dp * x + & 3.57901398988359e-04_dp ) * x - & 2.34112415981143e-02_dp ) * x + & 7.81425144913975e-01_dp ) * x - & 1.73209218219175e+01_dp ) * x + & 2.43517435690398e+02_dp ) * x + & ( - 1.97611541576986e+04_dp * recx + & 9.82441363463929e+03_dp ) * recx - & 2.07970687843258e+03_dp ) * e + r13 / ( x - r13 ) r2 = ((((( - 2.62627010965435e-04_dp * x + & 3.49187925428138e-02_dp ) * x - & 3.09337618731880e+00_dp ) * x + & 1.07037141010778e+02_dp ) * x - & 2.36659637247087e+03_dp ) * x + & (( - 2.91669113681020e+06_dp * recx + & 1.41129505262758e+06_dp ) * recx - & 2.91532335433779e+05_dp ) * recx + & 3.35202872835409e+04_dp ) * e + r23 / ( x - r23 ) r3 = ((((( 9.31856404738601e-05_dp * x - & 2.87029400759565e-02_dp ) * x - & 7.83503697918455e-01_dp ) * x - & 1.84338896480695e+01_dp ) * x + & 4.04996712650414e+02_dp ) * x + & ( - 1.89829509315154e+05_dp * recx + & 5.11498390849158e+04_dp ) * recx - & 6.88145821789955e+03_dp ) * e + r33 / ( x - r33 ) t1 = r1 / ( r1 + 1.0e+00_dp ) t2 = r2 / ( r2 + 1.0e+00_dp ) t3 = r3 / ( r3 + 1.0e+00_dp ) a2 = f2 - t1 * f1 a1 = f1 - t1 * w1 w3 = ( a2 - t2 * a1 ) / (( t3 - t2 ) * ( t3 - t1 )) w2 = ( t3 * a1 - a2 ) / (( t3 - t2 ) * ( t2 - t1 )) w1 = w1 - w2 - w3 elseif ( x <= 3 3.0e+00_dp ) then e = exp ( - x ) recx = 1.0e+00_dp / x w1 = (( 1.9623264149430e-01_dp * recx - & 4.9695241464490e-01_dp ) * recx - & 6.0156581186481e-05_dp ) * e + sqrt ( PIo4 * recx ) f1 = recx * ( w1 - e ) / 2 f2 = recx * ( f1 + f1 + f1 - e ) / 2 r1 = (((( - 4.97561537069643e-04_dp * x - & 5.00929599665316e-02_dp ) * x + & 1.31099142238996e+00_dp ) * x - & 1.88336409225481e+01_dp ) * x - & 6.60344754467191e+02_dp * recx + & 1.64931462413877e+02_dp ) * e + r13 / ( x - r13 ) r2 = (((( - 4.48218898474906e-03_dp * x - & 5.17373211334924e-01_dp ) * x + & 1.13691058739678e+01_dp ) * x - & 1.65426392885291e+02_dp ) * x - & 6.30909125686731e+03_dp * recx + & 1.52231757709236e+03_dp ) * e + r23 / ( x - r23 ) r3 = (((( - 1.38368602394293e-02_dp * x - & 1.77293428863008e+00_dp ) * x + & 1.73639054044562e+01_dp ) * x - & 3.57615122086961e+02_dp ) * x - & 1.45734701095912e+04_dp * recx + & 2.69831813951849e+03_dp ) * e + r33 / ( x - r33 ) t1 = r1 / ( r1 + 1.0e+00_dp ) t2 = r2 / ( r2 + 1.0e+00_dp ) t3 = r3 / ( r3 + 1.0e+00_dp ) a2 = f2 - t1 * f1 a1 = f1 - t1 * w1 w3 = ( a2 - t2 * a1 ) / (( t3 - t2 ) * ( t3 - t1 )) w2 = ( t3 * a1 - a2 ) / (( t3 - t2 ) * ( t2 - t1 )) w1 = w1 - w2 - w3 elseif ( x <= 4 7.0e+00_dp ) then w1 = sqrt ( PIo4 / x ) e = exp ( - x ) r1 = (( - 7.39058467995275e+00_dp * x + & 3.21318352526305e+02_dp ) * x - & 3.99433696473658e+03_dp ) * e + r13 / ( x - r13 ) r2 = (( - 7.38726243906513e+01_dp * x + & 3.13569966333873e+03_dp ) * x - & 3.86862867311321e+04_dp ) * e + r23 / ( x - r23 ) r3 = (( - 2.63750565461336e+02_dp * x + & 1.04412168692352e+04_dp ) * x - & 1.28094577915394e+05_dp ) * e + r33 / ( x - r33 ) w3 = ((( 1.52258947224714e-01_dp * x - & 8.30661900042651e+00_dp ) * x + & 1.92977367967984e+02_dp ) * x - & 1.67787926005344e+03_dp ) * e + w33 * w1 w2 = (( 6.15072615497811e+01_dp * x - & 2.91980647450269e+03_dp ) * x + & 3.80794303087338e+04_dp ) * e + w23 * w1 w1 = w1 - w2 - w3 else r1 = r13 / ( x - r13 ) r2 = r23 / ( x - r23 ) r3 = r33 / ( x - r33 ) w1 = sqrt ( PIo4 / x ) w2 = w23 * w1 w3 = w33 * w1 w1 = w1 - w2 - w3 end if r = ( / r1 , r2 , r3 / ) w = ( / w1 , w2 , w3 / ) end subroutine rys_rt3 !----------------------------------------------------------------- subroutine rys_rt4 ( x , r , w ) real ( KIND = dp ), intent ( IN ) :: & x real ( KIND = dp ), intent ( OUT ) :: & r ( 4 ), w ( 4 ) real ( KIND = dp ), parameter :: & r14 = 1.45303521503316e-01_dp , & r24 = 1.33909728812636e+00_dp , & w24 = 2.34479815323517e-01_dp , & r34 = 3.92696350135829e+00_dp , & w34 = 1.92704402415764e-02_dp , & r44 = 8.58863568901199e+00_dp , & w44 = 2.25229076750736e-04_dp real ( KIND = dp ) :: & y , recx , e , r1 , r2 , r3 , r4 , w1 , w2 , w3 , w4 if ( x <= 3.0e-07_dp ) then r1 = 3.48198973061471e-02_dp - 4.09645850660395e-03_dp * x r2 = 3.81567185080042e-01_dp - 4.48902570656719e-02_dp * x r3 = 1.73730726945891e+00_dp - 2.04389090547327e-01_dp * x r4 = 1.18463056481549e+01_dp - 1.39368301742312e+00_dp * x w1 = 3.62683783378362e-01_dp - 3.13844305713928e-02_dp * x w2 = 3.13706645877886e-01_dp - 8.98046242557724e-02_dp * x w3 = 2.22381034453372e-01_dp - 1.29314370958973e-01_dp * x w4 = 1.01228536290376e-01_dp - 8.28299075414321e-02_dp * x elseif ( x <= 1.0e+00_dp ) then r1 = (((((( - 1.95309614628539e-10_dp * x + & 5.19765728707592e-09_dp ) * x - & 1.01756452250573e-07_dp ) * x + & 1.72365935872131e-06_dp ) * x - & 2.61203523522184e-05_dp ) * x + & 3.52921308769880e-04_dp ) * x - & 4.09645850658433e-03_dp ) * x + & 3.48198973061469e-02_dp r2 = ((((( - 1.89554881382342e-08_dp * x + & 3.07583114342365e-07_dp ) * x + & 1.270981734393e-06_dp ) * x - & 1.417298563884e-04_dp ) * x + & 3.226979163176e-03_dp ) * x - & 4.48902570678178e-02_dp ) * x + & 3.81567185080039e-01_dp r3 = (((((( 1.77280535300416e-09_dp * x + & 3.36524958870615e-08_dp ) * x - & 2.58341529013893e-07_dp ) * x - & 1.13644895662320e-05_dp ) * x - & 7.91549618884063e-05_dp ) * x + & 1.03825827346828e-02_dp ) * x - & 2.04389090525137e-01_dp ) * x + & 1.73730726945889e+00_dp r4 = ((((( - 5.61188882415248e-08_dp * x - & 2.49480733072460e-07_dp ) * x + & 3.428685057114e-06_dp ) * x + & 1.679007454539e-04_dp ) * x + & 4.722855585715e-02_dp ) * x - & 1.39368301737828e+00_dp ) * x + & 1.18463056481543e+01_dp w1 = (((((( - 1.14649303201279e-08_dp * x + & 1.88015570196787e-07_dp ) * x - & 2.33305875372323e-06_dp ) * x + & 2.68880044371597e-05_dp ) * x - & 2.94268428977387e-04_dp ) * x + & 3.06548909776613e-03_dp ) * x - & 3.13844305680096e-02_dp ) * x + & 3.62683783378335e-01_dp w2 = (((((((( - 4.11720483772634e-09_dp * x + & 6.54963481852134e-08_dp ) * x - & 7.20045285129626e-07_dp ) * x + & 6.93779646721723e-06_dp ) * x - & 6.05367572016373e-05_dp ) * x + & 4.74241566251899e-04_dp ) * x - & 3.26956188125316e-03_dp ) * x + & 1.91883866626681e-02_dp ) * x - & 8.98046242565811e-02_dp ) * x + & 3.13706645877886e-01_dp w3 = (((((((( - 3.41688436990215e-08_dp * x + & 5.07238960340773e-07_dp ) * x - & 5.01675628408220e-06_dp ) * x + & 4.20363420922845e-05_dp ) * x - & 3.08040221166823e-04_dp ) * x + & 1.94431864731239e-03_dp ) * x - & 1.02477820460278e-02_dp ) * x + & 4.28670143840073e-02_dp ) * x - & 1.29314370962569e-01_dp ) * x + & 2.22381034453369e-01_dp w4 = ((((((((( 4.99660550769508e-09_dp * x - & 7.94585963310120e-08_dp ) * x + & 8.359072409485e-07_dp ) * x - & 7.422369210610e-06_dp ) * x + & 5.763374308160e-05_dp ) * x - & 3.86645606718233e-04_dp ) * x + & 2.18417516259781e-03_dp ) * x - & 9.99791027771119e-03_dp ) * x + & 3.48791097377370e-02_dp ) * x - & 8.28299075413889e-02_dp ) * x + & 1.01228536290376e-01_dp elseif ( x <= 5.0e+00_dp ) then y = x - 3.0e+00_dp r1 = ((((((((( - 1.48570633747284e-15_dp * y - & 1.33273068108777e-13_dp ) * y + & 4.068543696670e-12_dp ) * y - & 9.163164161821e-11_dp ) * y + & 2.046819017845e-09_dp ) * y - & 4.03076426299031e-08_dp ) * y + & 7.29407420660149e-07_dp ) * y - & 1.23118059980833e-05_dp ) * y + & 1.88796581246938e-04_dp ) * y - & 2.53262912046853e-03_dp ) * y + & 2.51198234505021e-02_dp r2 = ((((((((( 1.35830583483312e-13_dp * y - & 2.29772605964836e-12_dp ) * y - & 3.821500128045e-12_dp ) * y + & 6.844424214735e-10_dp ) * y - & 1.048063352259e-08_dp ) * y + & 1.50083186233363e-08_dp ) * y + & 3.48848942324454e-06_dp ) * y - & 1.08694174399193e-04_dp ) * y + & 2.08048885251999e-03_dp ) * y - & 2.91205805373793e-02_dp ) * y + & 2.72276489515713e-01_dp r3 = ((((((((( 5.02799392850289e-13_dp * y + & 1.07461812944084e-11_dp ) * y - & 1.482277886411e-10_dp ) * y - & 2.153585661215e-09_dp ) * y + & 3.654087802817e-08_dp ) * y + & 5.15929575830120e-07_dp ) * y - & 9.52388379435709e-06_dp ) * y - & 2.16552440036426e-04_dp ) * y + & 9.03551469568320e-03_dp ) * y - & 1.45505469175613e-01_dp ) * y + & 1.21449092319186e+00_dp r4 = ((((((((( - 1.08510370291979e-12_dp * y + & 6.41492397277798e-11_dp ) * y + & 7.542387436125e-10_dp ) * y - & 2.213111836647e-09_dp ) * y - & 1.448228963549e-07_dp ) * y - & 1.95670833237101e-06_dp ) * y - & 1.07481314670844e-05_dp ) * y + & 1.49335941252765e-04_dp ) * y + & 4.87791531990593e-02_dp ) * y - & 1.10559909038653e+00_dp ) * y + & 8.09502028611780e+00_dp w1 = (((((((((( - 4.65801912689961e-14_dp * y + & 7.58669507106800e-13_dp ) * y - & 1.186387548048e-11_dp ) * y + & 1.862334710665e-10_dp ) * y - & 2.799399389539e-09_dp ) * y + & 4.148972684255e-08_dp ) * y - & 5.933568079600e-07_dp ) * y + & 8.168349266115e-06_dp ) * y - & 1.08989176177409e-04_dp ) * y + & 1.41357961729531e-03_dp ) * y - & 1.87588361833659e-02_dp ) * y + & 2.89898651436026e-01_dp w2 = (((((((((((( - 1.46345073267549e-14_dp * y + & 2.25644205432182e-13_dp ) * y - & 3.116258693847e-12_dp ) * y + & 4.321908756610e-11_dp ) * y - & 5.673270062669e-10_dp ) * y + & 7.006295962960e-09_dp ) * y - & 8.120186517000e-08_dp ) * y + & 8.775294645770e-07_dp ) * y - & 8.77829235749024e-06_dp ) * y + & 8.04372147732379e-05_dp ) * y - & 6.64149238804153e-04_dp ) * y + & 4.81181506827225e-03_dp ) * y - & 2.88982669486183e-02_dp ) * y + & 1.56247249979288e-01_dp w3 = ((((((((((((( 9.06812118895365e-15_dp * y - & 1.40541322766087e-13_dp ) * y + & 1.919270015269e-12_dp ) * y - & 2.605135739010e-11_dp ) * y + & 3.299685839012e-10_dp ) * y - & 3.86354139348735e-09_dp ) * y + & 4.16265847927498e-08_dp ) * y - & 4.09462835471470e-07_dp ) * y + & 3.64018881086111e-06_dp ) * y - & 2.88665153269386e-05_dp ) * y + & 2.00515819789028e-04_dp ) * y - & 1.18791896897934e-03_dp ) * y + & 5.75223633388589e-03_dp ) * y - & 2.09400418772687e-02_dp ) * y + & 4.85368861938873e-02_dp w4 = (((((((((((((( - 9.74835552342257e-16_dp * y + & 1.57857099317175e-14_dp ) * y - & 2.249993780112e-13_dp ) * y + & 3.173422008953e-12_dp ) * y - & 4.161159459680e-11_dp ) * y + & 5.021343560166e-10_dp ) * y - & 5.545047534808e-09_dp ) * y + & 5.554146993491e-08_dp ) * y - & 4.99048696190133e-07_dp ) * y + & 3.96650392371311e-06_dp ) * y - & 2.73816413291214e-05_dp ) * y + & 1.60106988333186e-04_dp ) * y - & 7.64560567879592e-04_dp ) * y + & 2.81330044426892e-03_dp ) * y - & 7.16227030134947e-03_dp ) * y + & 9.66077262223353e-03_dp elseif ( x <= 1 0.0e+00_dp ) then y = x - 7.5e+00_dp r1 = ((((((((( 4.64217329776215e-15_dp * y - & 6.27892383644164e-15_dp ) * y + & 3.462236347446e-13_dp ) * y - & 2.927229355350e-11_dp ) * y + & 5.090355371676e-10_dp ) * y - & 9.97272656345253e-09_dp ) * y + & 2.37835295639281e-07_dp ) * y - & 4.60301761310921e-06_dp ) * y + & 8.42824204233222e-05_dp ) * y - & 1.37983082233081e-03_dp ) * y + & 1.66630865869375e-02_dp r2 = ((((((((( 2.93981127919047e-14_dp * y + & 8.47635639065744e-13_dp ) * y - & 1.446314544774e-11_dp ) * y - & 6.149155555753e-12_dp ) * y + & 8.484275604612e-10_dp ) * y - & 6.10898827887652e-08_dp ) * y + & 2.39156093611106e-06_dp ) * y - & 5.35837089462592e-05_dp ) * y + & 1.00967602595557e-03_dp ) * y - & 1.57769317127372e-02_dp ) * y + & 1.74853819464285e-01_dp r3 = (((((((((( 2.93523563363000e-14_dp * y - & 6.40041776667020e-14_dp ) * y - & 2.695740446312e-12_dp ) * y + & 1.027082960169e-10_dp ) * y - & 5.822038656780e-10_dp ) * y - & 3.159991002539e-08_dp ) * y + & 4.327249251331e-07_dp ) * y + & 4.856768455119e-06_dp ) * y - & 2.54617989427762e-04_dp ) * y + & 5.54843378106589e-03_dp ) * y - & 7.95013029486684e-02_dp ) * y + & 7.20206142703162e-01_dp r4 = ((((((((((( - 1.62212382394553e-14_dp * y + & 7.68943641360593e-13_dp ) * y + & 5.764015756615e-12_dp ) * y - & 1.380635298784e-10_dp ) * y - & 1.476849808675e-09_dp ) * y + & 1.84347052385605e-08_dp ) * y + & 3.34382940759405e-07_dp ) * y - & 1.39428366421645e-06_dp ) * y - & 7.50249313713996e-05_dp ) * y - & 6.26495899187507e-04_dp ) * y + & 4.69716410901162e-02_dp ) * y - & 6.66871297428209e-01_dp ) * y + & 4.11207530217806e+00_dp w1 = (((((((((( - 1.65995045235997e-15_dp * y + & 6.91838935879598e-14_dp ) * y - & 9.131223418888e-13_dp ) * y + & 1.403341829454e-11_dp ) * y - & 3.672235069444e-10_dp ) * y + & 6.366962546990e-09_dp ) * y - & 1.039220021671e-07_dp ) * y + & 1.959098751715e-06_dp ) * y - & 3.33474893152939e-05_dp ) * y + & 5.72164211151013e-04_dp ) * y - & 1.05583210553392e-02_dp ) * y + & 2.26696066029591e-01_dp w2 = (((((((((((( - 3.57248951192047e-16_dp * y + & 6.25708409149331e-15_dp ) * y - & 9.657033089714e-14_dp ) * y + & 1.507864898748e-12_dp ) * y - & 2.332522256110e-11_dp ) * y + & 3.428545616603e-10_dp ) * y - & 4.698730937661e-09_dp ) * y + & 6.219977635130e-08_dp ) * y - & 7.83008889613661e-07_dp ) * y + & 9.08621687041567e-06_dp ) * y - & 9.86368311253873e-05_dp ) * y + & 9.69632496710088e-04_dp ) * y - & 8.14594214284187e-03_dp ) * y + & 8.50218447733457e-02_dp w3 = ((((((((((((( 1.64742458534277e-16_dp * y - & 2.68512265928410e-15_dp ) * y + & 3.788890667676e-14_dp ) * y - & 5.508918529823e-13_dp ) * y + & 7.555896810069e-12_dp ) * y - & 9.69039768312637e-11_dp ) * y + & 1.16034263529672e-09_dp ) * y - & 1.28771698573873e-08_dp ) * y + & 1.31949431805798e-07_dp ) * y - & 1.23673915616005e-06_dp ) * y + & 1.04189803544936e-05_dp ) * y - & 7.79566003744742e-05_dp ) * y + & 5.03162624754434e-04_dp ) * y - & 2.55138844587555e-03_dp ) * y + & 1.13250730954014e-02_dp w4 = (((((((((((((( - 1.55714130075679e-17_dp * y + & 2.57193722698891e-16_dp ) * y - & 3.626606654097e-15_dp ) * y + & 5.234734676175e-14_dp ) * y - & 7.067105402134e-13_dp ) * y + & 8.793512664890e-12_dp ) * y - & 1.006088923498e-10_dp ) * y + & 1.050565098393e-09_dp ) * y - & 9.91517881772662e-09_dp ) * y + & 8.35835975882941e-08_dp ) * y - & 6.19785782240693e-07_dp ) * y + & 3.95841149373135e-06_dp ) * y - & 2.11366761402403e-05_dp ) * y + & 9.00474771229507e-05_dp ) * y - & 2.78777909813289e-04_dp ) * y + & 5.26543779837487e-04_dp elseif ( x <= 1 5.0e+00_dp ) then y = x - 1 2.5e+00_dp r1 = ((((((((((( 4.94869622744119e-17_dp * y + & 8.03568805739160e-16_dp ) * y - & 5.599125915431e-15_dp ) * y - & 1.378685560217e-13_dp ) * y + & 7.006511663249e-13_dp ) * y + & 1.30391406991118e-11_dp ) * y + & 8.06987313467541e-11_dp ) * y - & 5.20644072732933e-09_dp ) * y + & 7.72794187755457e-08_dp ) * y - & 1.61512612564194e-06_dp ) * y + & 4.15083811185831e-05_dp ) * y - & 7.87855975560199e-04_dp ) * y + & 1.14189319050009e-02_dp r2 = ((((((((((( 4.89224285522336e-16_dp * y + & 1.06390248099712e-14_dp ) * y - & 5.446260182933e-14_dp ) * y - & 1.613630106295e-12_dp ) * y + & 3.910179118937e-12_dp ) * y + & 1.90712434258806e-10_dp ) * y + & 8.78470199094761e-10_dp ) * y - & 5.97332993206797e-08_dp ) * y + & 9.25750831481589e-07_dp ) * y - & 2.02362185197088e-05_dp ) * y + & 4.92341968336776e-04_dp ) * y - & 8.68438439874703e-03_dp ) * y + & 1.15825965127958e-01_dp r3 = (((((((((( 6.12419396208408e-14_dp * y + & 1.12328861406073e-13_dp ) * y - & 9.051094103059e-12_dp ) * y - & 4.781797525341e-11_dp ) * y + & 1.660828868694e-09_dp ) * y + & 4.499058798868e-10_dp ) * y - & 2.519549641933e-07_dp ) * y + & 4.977444040180e-06_dp ) * y - & 1.25858350034589e-04_dp ) * y + & 2.70279176970044e-03_dp ) * y - & 3.99327850801083e-02_dp ) * y + & 4.33467200855434e-01_dp r4 = ((((((((((( 4.63414725924048e-14_dp * y - & 4.72757262693062e-14_dp ) * y - & 1.001926833832e-11_dp ) * y + & 6.074107718414e-11_dp ) * y + & 1.576976911942e-09_dp ) * y - & 2.01186401974027e-08_dp ) * y - & 1.84530195217118e-07_dp ) * y + & 5.02333087806827e-06_dp ) * y + & 9.66961790843006e-06_dp ) * y - & 1.58522208889528e-03_dp ) * y + & 2.80539673938339e-02_dp ) * y - & 2.78953904330072e-01_dp ) * y + & 1.82835655238235e+00_dp w4 = ((((((((((((( 2.90401781000996e-18_dp * y - & 4.63389683098251e-17_dp ) * y + & 6.274018198326e-16_dp ) * y - & 8.936002188168e-15_dp ) * y + & 1.194719074934e-13_dp ) * y - & 1.45501321259466e-12_dp ) * y + & 1.64090830181013e-11_dp ) * y - & 1.71987745310181e-10_dp ) * y + & 1.63738403295718e-09_dp ) * y - & 1.39237504892842e-08_dp ) * y + & 1.06527318142151e-07_dp ) * y - & 7.27634957230524e-07_dp ) * y + & 4.12159381310339e-06_dp ) * y - & 1.74648169719173e-05_dp ) * y + & 8.50290130067818e-05_dp w3 = (((((((((((( - 4.19569145459480e-17_dp * y + & 5.94344180261644e-16_dp ) * y - & 1.148797566469e-14_dp ) * y + & 1.881303962576e-13_dp ) * y - & 2.413554618391e-12_dp ) * y + & 3.372127423047e-11_dp ) * y - & 4.933988617784e-10_dp ) * y + & 6.116545396281e-09_dp ) * y - & 6.69965691739299e-08_dp ) * y + & 7.52380085447161e-07_dp ) * y - & 8.08708393262321e-06_dp ) * y + & 6.88603417296672e-05_dp ) * y - & 4.67067112993427e-04_dp ) * y + & 5.42313365864597e-03_dp w2 = (((((((((( - 6.22272689880615e-15_dp * y + & 1.04126809657554e-13_dp ) * y - & 6.842418230913e-13_dp ) * y + & 1.576841731919e-11_dp ) * y - & 4.203948834175e-10_dp ) * y + & 6.287255934781e-09_dp ) * y - & 8.307159819228e-08_dp ) * y + & 1.356478091922e-06_dp ) * y - & 2.08065576105639e-05_dp ) * y + & 2.52396730332340e-04_dp ) * y - & 2.94484050194539e-03_dp ) * y + & 6.01396183129168e-02_dp recx = 1.0e+00_dp / x w1 = ((( - 1.8784686463512e-01_dp * recx + & 2.2991849164985e-01_dp ) * recx - & 4.9893752514047e-01_dp ) * recx - & 2.1916512131607e-05_dp ) * exp ( - x ) + & sqrt ( PIo4 * recx ) - w4 - w3 - w2 elseif ( x <= 2 0.0e+00_dp ) then w1 = sqrt ( PIo4 / x ) y = x - 1 7.5e+00_dp r1 = ((((((((((( 4.36701759531398e-17_dp * y - & 1.12860600219889e-16_dp ) * y - & 6.149849164164e-15_dp ) * y + & 5.820231579541e-14_dp ) * y + & 4.396602872143e-13_dp ) * y - & 1.24330365320172e-11_dp ) * y + & 6.71083474044549e-11_dp ) * y + & 2.43865205376067e-10_dp ) * y + & 1.67559587099969e-08_dp ) * y - & 9.32738632357572e-07_dp ) * y + & 2.39030487004977e-05_dp ) * y - & 4.68648206591515e-04_dp ) * y + & 8.34977776583956e-03_dp r2 = ((((((((((( 4.98913142288158e-16_dp * y - & 2.60732537093612e-16_dp ) * y - & 7.775156445127e-14_dp ) * y + & 5.766105220086e-13_dp ) * y + & 6.432696729600e-12_dp ) * y - & 1.39571683725792e-10_dp ) * y + & 5.95451479522191e-10_dp ) * y + & 2.42471442836205e-09_dp ) * y + & 2.47485710143120e-07_dp ) * y - & 1.14710398652091e-05_dp ) * y + & 2.71252453754519e-04_dp ) * y - & 4.96812745851408e-03_dp ) * y + & 8.26020602026780e-02_dp r3 = ((((((((((( 1.91498302509009e-15_dp * y + & 1.48840394311115e-14_dp ) * y - & 4.316925145767e-13_dp ) * y + & 1.186495793471e-12_dp ) * y + & 4.615806713055e-11_dp ) * y - & 5.54336148667141e-10_dp ) * y + & 3.48789978951367e-10_dp ) * y - & 2.79188977451042e-09_dp ) * y + & 2.09563208958551e-06_dp ) * y - & 6.76512715080324e-05_dp ) * y + & 1.32129867629062e-03_dp ) * y - & 2.05062147771513e-02_dp ) * y + & 2.88068671894324e-01_dp r4 = ((((((((((( - 5.43697691672942e-15_dp * y - & 1.12483395714468e-13_dp ) * y + & 2.826607936174e-12_dp ) * y - & 1.266734493280e-11_dp ) * y - & 4.258722866437e-10_dp ) * y + & 9.45486578503261e-09_dp ) * y - & 5.86635622821309e-08_dp ) * y - & 1.28835028104639e-06_dp ) * y + & 4.41413815691885e-05_dp ) * y - & 7.61738385590776e-04_dp ) * y + & 9.66090902985550e-03_dp ) * y - & 1.01410568057649e-01_dp ) * y + & 9.54714798156712e-01_dp w4 = (((((((((((( - 7.56882223582704e-19_dp * y + & 7.53541779268175e-18_dp ) * y - & 1.157318032236e-16_dp ) * y + & 2.411195002314e-15_dp ) * y - & 3.601794386996e-14_dp ) * y + & 4.082150659615e-13_dp ) * y - & 4.289542980767e-12_dp ) * y + & 5.086829642731e-11_dp ) * y - & 6.35435561050807e-10_dp ) * y + & 6.82309323251123e-09_dp ) * y - & 5.63374555753167e-08_dp ) * y + & 3.57005361100431e-07_dp ) * y - & 2.40050045173721e-06_dp ) * y + & 4.94171300536397e-05_dp w3 = ((((((((((( - 5.54451040921657e-17_dp * y + & 2.68748367250999e-16_dp ) * y + & 1.349020069254e-14_dp ) * y - & 2.507452792892e-13_dp ) * y + & 1.944339743818e-12_dp ) * y - & 1.29816917658823e-11_dp ) * y + & 3.49977768819641e-10_dp ) * y - & 8.67270669346398e-09_dp ) * y + & 1.31381116840118e-07_dp ) * y - & 1.36790720600822e-06_dp ) * y + & 1.19210697673160e-05_dp ) * y - & 1.42181943986587e-04_dp ) * y + & 4.12615396191829e-03_dp w2 = ((((((((((( - 1.86506057729700e-16_dp * y + & 1.16661114435809e-15_dp ) * y + & 2.563712856363e-14_dp ) * y - & 4.498350984631e-13_dp ) * y + & 1.765194089338e-12_dp ) * y + & 9.04483676345625e-12_dp ) * y + & 4.98930345609785e-10_dp ) * y - & 2.11964170928181e-08_dp ) * y + & 3.98295476005614e-07_dp ) * y - & 5.49390160829409e-06_dp ) * y + & 7.74065155353262e-05_dp ) * y - & 1.48201933009105e-03_dp ) * y + & 4.97836392625268e-02_dp w1 = (( 1.9623264149430e-01_dp / x - & 4.9695241464490e-01_dp ) / x - & 6.0156581186481e-05_dp ) * exp ( - x ) + & w1 - w2 - w3 - w4 elseif ( x <= 2 5.0e+00_dp ) then w1 = sqrt ( PIo4 / x ) e = exp ( - x ) recx = 1.0e+00_dp / x r1 = (((((( - 4.45711399441838e-05_dp * x + & 1.27267770241379e-03_dp ) * x - & 2.36954961381262e-01_dp ) * x + & 1.54330657903756e+01_dp ) * x - & 5.22799159267808e+02_dp ) * x + & 1.05951216669313e+04_dp ) * x + & ( - 2.51177235556236e+06_dp * recx + & 8.72975373557709e+05_dp ) * recx - & 1.29194382386499e+05_dp ) * e + r14 / ( x - r14 ) r2 = ((((( - 7.85617372254488e-02_dp * x + & 6.35653573484868e+00_dp ) * x - & 3.38296938763990e+02_dp ) * x + & 1.25120495802096e+04_dp ) * x - & 3.16847570511637e+05_dp ) * x + & (( - 1.02427466127427e+09_dp * recx + & 3.70104713293016e+08_dp ) * recx - & 5.87119005093822e+07_dp ) * recx + & 5.38614211391604e+06_dp ) * e + r24 / ( x - r24 ) r3 = ((((( - 2.37900485051067e-01_dp * x + & 1.84122184400896e+01_dp ) * x - & 1.00200731304146e+03_dp ) * x + & 3.75151841595736e+04_dp ) * x - & 9.50626663390130e+05_dp ) * x + & (( - 2.88139014651985e+09_dp * recx + & 1.06625915044526e+09_dp ) * recx - & 1.72465289687396e+08_dp ) * recx + & 1.60419390230055e+07_dp ) * e + r34 / ( x - r34 ) r4 = (((((( - 6.00691586407385e-04_dp * x - & 3.64479545338439e-01_dp ) * x + & 1.57496131755179e+01_dp ) * x - & 6.54944248734901e+02_dp ) * x + & 1.70830039597097e+04_dp ) * x - & 2.90517939780207e+05_dp ) * x + & ( + 3.49059698304732e+07_dp * recx - & 1.64944522586065e+07_dp ) * recx + & 2.96817940164703e+06_dp ) * e + r44 / ( x - r44 ) w4 = ((((((( 2.33766206773151e-07_dp * x - & 3.81542906607063e-05_dp ) * x + & 3.51416601267000e-03_dp ) * x - & 1.66538571864728e-01_dp ) * x + & 4.80006136831847e+00_dp ) * x - & 8.73165934223603e+01_dp ) * x + & 9.77683627474638e+02_dp ) * x + & 1.66000945117640e+04_dp * recx - & 6.14479071209961e+03_dp ) * e + w44 * w1 w3 = (((((( 2.36392855180768e-04_dp * x - & 9.16785337967013e-03_dp ) * x + & 4.62186525041313e-01_dp ) * x - & 1.96943786006540e+01_dp ) * x + & 4.99169195295559e+02_dp ) * x - & 6.21419845845090e+03_dp ) * x + & (( + 5.21445053212414e+07_dp * recx - & 1.34113464389309e+07_dp ) * recx + & 1.13673298305631e+06_dp ) * recx - & 2.81501182042707e+03_dp ) * e + w34 * w1 w2 = (((((( 7.29841848989391e-04_dp * x - & 3.53899555749875e-02_dp ) * x + & 2.07797425718513e+00_dp ) * x - & 1.00464709786287e+02_dp ) * x + & 3.15206108877819e+03_dp ) * x - & 6.27054715090012e+04_dp ) * x + & ( + 1.54721246264919e+07_dp * recx - & 5.26074391316381e+06_dp ) * recx + & 7.67135400969617e+05_dp ) * e + w24 * w1 w1 = (( 1.9623264149430e-01_dp * recx - & 4.9695241464490e-01_dp ) * recx - & 6.0156581186481e-05_dp ) * e + & w1 - w2 - w3 - w4 elseif ( x <= 3 5.0e+00_dp ) then w1 = sqrt ( PIo4 / x ) e = exp ( - x ) recx = 1.0e+00_dp / x r1 = (((((( - 4.45711399441838e-05_dp * x + & 1.27267770241379e-03_dp ) * x - & 2.36954961381262e-01_dp ) * x + & 1.54330657903756e+01_dp ) * x - & 5.22799159267808e+02_dp ) * x + & 1.05951216669313e+04_dp ) * x + & ( - 2.51177235556236e+06_dp * recx + & 8.72975373557709e+05_dp ) * recx - & 1.29194382386499e+05_dp ) * e + r14 / ( x - r14 ) r2 = ((((( - 7.85617372254488e-02_dp * x + & 6.35653573484868e+00_dp ) * x - & 3.38296938763990e+02_dp ) * x + & 1.25120495802096e+04_dp ) * x - & 3.16847570511637e+05_dp ) * x + & (( - 1.02427466127427e+09_dp * recx + & 3.70104713293016e+08_dp ) * recx - & 5.87119005093822e+07_dp ) * recx + & 5.38614211391604e+06_dp ) * e + r24 / ( x - r24 ) r3 = ((((( - 2.37900485051067e-01_dp * x + & 1.84122184400896e+01_dp ) * x - & 1.00200731304146e+03_dp ) * x + & 3.75151841595736e+04_dp ) * x - & 9.50626663390130e+05_dp ) * x + & (( - 2.88139014651985e+09_dp * recx + & 1.06625915044526e+09_dp ) * recx - & 1.72465289687396e+08_dp ) * recx + & 1.60419390230055e+07_dp ) * e + r34 / ( x - r34 ) r4 = (((((( - 6.00691586407385e-04_dp * x - & 3.64479545338439e-01_dp ) * x + & 1.57496131755179e+01_dp ) * x - & 6.54944248734901e+02_dp ) * x + & 1.70830039597097e+04_dp ) * x - & 2.90517939780207e+05_dp ) * x + & ( + 3.49059698304732e+07_dp * recx - & 1.64944522586065e+07_dp ) * recx + & 2.96817940164703e+06_dp ) * e + r44 / ( x - r44 ) w4 = (((((( 5.74245945342286e-06_dp * x - & 7.58735928102351e-05_dp ) * x + & 2.35072857922892e-04_dp ) * x - & 3.78812134013125e-03_dp ) * x + & 3.09871652785805e-01_dp ) * x - & 7.11108633061306e+00_dp ) * x + & 5.55297573149528e+01_dp ) * e + w44 * w1 w3 = (((((( 2.36392855180768e-04_dp * x - & 9.16785337967013e-03_dp ) * x + & 4.62186525041313e-01_dp ) * x - & 1.96943786006540e+01_dp ) * x + & 4.99169195295559e+02_dp ) * x - & 6.21419845845090e+03_dp ) * x + & (( + 5.21445053212414e+07_dp * recx - & 1.34113464389309e+07_dp ) * recx + & 1.13673298305631e+06_dp ) * recx - & 2.81501182042707e+03_dp ) * e + w34 * w1 w2 = (((((( 7.29841848989391e-04_dp * x - & 3.53899555749875e-02_dp ) * x + & 2.07797425718513e+00_dp ) * x - & 1.00464709786287e+02_dp ) * x + & 3.15206108877819e+03_dp ) * x - & 6.27054715090012e+04_dp ) * x + & ( + 1.54721246264919e+07_dp * recx - & 5.26074391316381e+06_dp ) * recx + & 7.67135400969617e+05_dp ) * e + w24 * w1 w1 = (( 1.9623264149430e-01_dp * recx - & 4.9695241464490e-01_dp ) * recx - & 6.0156581186481e-05_dp ) * e + & w1 - w2 - w3 - w4 elseif ( x <= 5 3.0e+00_dp ) then w1 = sqrt ( PIo4 / x ) e = exp ( - x ) * ( x * x ) ** 2 r4 = (( - 2.19135070169653e-03_dp * x - & 1.19108256987623e-01_dp ) * x - & 7.50238795695573e-01_dp ) * e + r44 / ( x - r44 ) r3 = (( - 9.65842534508637e-04_dp * x - & 4.49822013469279e-02_dp ) * x + & 6.08784033347757e-01_dp ) * e + r34 / ( x - r34 ) r2 = (( - 3.62569791162153e-04_dp * x - & 9.09231717268466e-03_dp ) * x + & 1.84336760556262e-01_dp ) * e + r24 / ( x - r24 ) r1 = (( - 4.07557525914600e-05_dp * x - & 6.88846864931685e-04_dp ) * x + & 1.74725309199384e-02_dp ) * e + r14 / ( x - r14 ) w4 = (( 5.76631982000990e-06_dp * x - & 7.89187283804890e-05_dp ) * x + & 3.28297971853126e-04_dp ) * e + w44 * w1 w3 = (( 2.08294969857230e-04_dp * x - & 3.77489954837361e-03_dp ) * x + & 2.09857151617436e-02_dp ) * e + w34 * w1 w2 = (( 6.16374517326469e-04_dp * x - & 1.26711744680092e-02_dp ) * x + & 8.14504890732155e-02_dp ) * e + w24 * w1 w1 = w1 - w2 - w3 - w4 else r1 = r14 / ( x - r14 ) r2 = r24 / ( x - r24 ) r3 = r34 / ( x - r34 ) r4 = r44 / ( x - r44 ) w1 = sqrt ( PIo4 / x ) w2 = w24 * w1 w3 = w34 * w1 w4 = w44 * w1 w1 = w1 - w2 - w3 - w4 end if r = ( / r1 , r2 , r3 , r4 / ) w = ( / w1 , w2 , w3 , w4 / ) end subroutine rys_rt4 !----------------------------------------------------------------- subroutine rys_rt5 ( x , r , w ) real ( KIND = dp ), intent ( IN ) :: & x real ( KIND = dp ), intent ( OUT ) :: & r ( 5 ), w ( 5 ) real ( KIND = dp ), parameter :: & r15 = 1.17581320211778e-01_dp , & r25 = 1.07456201243690e+00_dp , & w25 = 2.70967405960535e-01_dp , & r35 = 3.08593744371754e+00_dp , & w35 = 3.82231610015404e-02_dp , & r45 = 6.41472973366203e+00_dp , & w45 = 1.51614186862443e-03_dp , & r55 = 1.18071894899717e+01_dp , & w55 = 8.62130526143657e-06_dp real ( KIND = dp ) :: y , e , r1 , r2 , r3 , r4 , r5 , w1 , w2 , w3 , w4 , w5 if ( x <= 3.0e-07_dp ) then r1 = 2.26659266316985e-02_dp - 2.15865967920897e-03_dp * x r2 = 2.31271692140903e-01_dp - 2.20258754389745e-02_dp * x r3 = 8.57346024118836e-01_dp - 8.16520023025515e-02_dp * x r4 = 2.97353038120346e+00_dp - 2.83193369647137e-01_dp * x r5 = 1.84151859759051e+01_dp - 1.75382723579439e+00_dp * x w1 = 2.95524224714752e-01_dp - 1.96867576909777e-02_dp * x w2 = 2.69266719309995e-01_dp - 5.61737590184721e-02_dp * x w3 = 2.19086362515981e-01_dp - 9.71152726793658e-02_dp * x w4 = 1.49451349150580e-01_dp - 1.02979262193565e-01_dp * x w5 = 6.66713443086877e-02_dp - 5.73782817488315e-02_dp * x elseif ( x <= 1.0e+00_dp ) then r1 = (((((( - 4.46679165328413e-11_dp * x + & 1.21879111988031e-09_dp ) * x - & 2.62975022612104e-08_dp ) * x + & 5.15106194905897e-07_dp ) * x - & 9.27933625824749e-06_dp ) * x + & 1.51794097682482e-04_dp ) * x - & 2.15865967920301e-03_dp ) * x + & 2.26659266316985e-02_dp r2 = (((((( 1.93117331714174e-10_dp * x - & 4.57267589660699e-09_dp ) * x + & 2.48339908218932e-08_dp ) * x + & 1.50716729438474e-06_dp ) * x - & 6.07268757707381e-05_dp ) * x + & 1.37506939145643e-03_dp ) * x - & 2.20258754419939e-02_dp ) * x + & 2.31271692140905e-01_dp r3 = ((((( 4.84989776180094e-09_dp * x + & 1.31538893944284e-07_dp ) * x - & 2.766753852879e-06_dp ) * x - & 7.651163510626e-05_dp ) * x + & 4.033058545972e-03_dp ) * x - & 8.16520022916145e-02_dp ) * x + & 8.57346024118779e-01_dp r4 = (((( - 2.48581772214623e-07_dp * x - & 4.34482635782585e-06_dp ) * x - & 7.46018257987630e-07_dp ) * x + & 1.01210776517279e-02_dp ) * x - & 2.83193369640005e-01_dp ) * x + & 2.97353038120345e+00_dp r5 = ((((( - 8.92432153868554e-09_dp * x + & 1.77288899268988e-08_dp ) * x + & 3.040754680666e-06_dp ) * x + & 1.058229325071e-04_dp ) * x + & 4.596379534985e-02_dp ) * x - & 1.75382723579114e+00_dp ) * x + & 1.84151859759049e+01_dp w1 = (((((( - 2.03822632771791e-09_dp * x + & 3.89110229133810e-08_dp ) * x - & 5.84914787904823e-07_dp ) * x + & 8.30316168666696e-06_dp ) * x - & 1.13218402310546e-04_dp ) * x + & 1.49128888586790e-03_dp ) * x - & 1.96867576904816e-02_dp ) * x + & 2.95524224714749e-01_dp w2 = ((((((( 8.62848118397570e-09_dp * x - & 1.38975551148989e-07_dp ) * x + & 1.602894068228e-06_dp ) * x - & 1.646364300836e-05_dp ) * x + & 1.538445806778e-04_dp ) * x - & 1.28848868034502e-03_dp ) * x + & 9.38866933338584e-03_dp ) * x - & 5.61737590178812e-02_dp ) * x + & 2.69266719309991e-01_dp w3 = (((((((( - 9.41953204205665e-09_dp * x + & 1.47452251067755e-07_dp ) * x - & 1.57456991199322e-06_dp ) * x + & 1.45098401798393e-05_dp ) * x - & 1.18858834181513e-04_dp ) * x + & 8.53697675984210e-04_dp ) * x - & 5.22877807397165e-03_dp ) * x + & 2.60854524809786e-02_dp ) * x - & 9.71152726809059e-02_dp ) * x + & 2.19086362515979e-01_dp w4 = (((((((( - 3.84961617022042e-08_dp * x + & 5.66595396544470e-07_dp ) * x - & 5.52351805403748e-06_dp ) * x + & 4.53160377546073e-05_dp ) * x - & 3.22542784865557e-04_dp ) * x + & 1.95682017370967e-03_dp ) * x - & 9.77232537679229e-03_dp ) * x + & 3.79455945268632e-02_dp ) * x - & 1.02979262192227e-01_dp ) * x + & 1.49451349150573e-01_dp w5 = ((((((((( 4.09594812521430e-09_dp * x - & 6.47097874264417e-08_dp ) * x + & 6.743541482689e-07_dp ) * x - & 5.917993920224e-06_dp ) * x + & 4.531969237381e-05_dp ) * x - & 2.99102856679638e-04_dp ) * x + & 1.65695765202643e-03_dp ) * x - & 7.40671222520653e-03_dp ) * x + & 2.50889946832192e-02_dp ) * x - & 5.73782817487958e-02_dp ) * x + & 6.66713443086877e-02_dp elseif ( x <= 5.0e+00_dp ) then y = x - 3.0e+00_dp r1 = (((((((( - 2.58163897135138e-14_dp * y + & 8.14127461488273e-13_dp ) * y - & 2.11414838976129e-11_dp ) * y + & 5.09822003260014e-10_dp ) * y - & 1.16002134438663e-08_dp ) * y + & 2.46810694414540e-07_dp ) * y - & 4.92556826124502e-06_dp ) * y + & 9.02580687971053e-05_dp ) * y - & 1.45190025120726e-03_dp ) * y + & 1.73416786387475e-02_dp r2 = ((((((((( 1.04525287289788e-14_dp * y + & 5.44611782010773e-14_dp ) * y - & 4.831059411392e-12_dp ) * y + & 1.136643908832e-10_dp ) * y - & 1.104373076913e-09_dp ) * y - & 2.35346740649916e-08_dp ) * y + & 1.43772622028764e-06_dp ) * y - & 4.23405023015273e-05_dp ) * y + & 9.12034574793379e-04_dp ) * y - & 1.52479441718739e-02_dp ) * y + & 1.76055265928744e-01_dp r3 = ((((((((( - 6.89693150857911e-14_dp * y + & 5.92064260918861e-13_dp ) * y + & 1.847170956043e-11_dp ) * y - & 3.390752744265e-10_dp ) * y - & 2.995532064116e-09_dp ) * y + & 1.57456141058535e-07_dp ) * y - & 3.95859409711346e-07_dp ) * y - & 9.58924580919747e-05_dp ) * y + & 3.23551502557785e-03_dp ) * y - & 5.97587007636479e-02_dp ) * y + & 6.46432853383057e-01_dp r4 = (((((((( - 3.61293809667763e-12_dp * y - & 2.70803518291085e-11_dp ) * y + & 8.83758848468769e-10_dp ) * y + & 1.59166632851267e-08_dp ) * y - & 1.32581997983422e-07_dp ) * y - & 7.60223407443995e-06_dp ) * y - & 7.41019244900952e-05_dp ) * y + & 9.81432631743423e-03_dp ) * y - & 2.23055570487771e-01_dp ) * y + & 2.21460798080643e+00_dp r5 = ((((((((( 7.12332088345321e-13_dp * y + & 3.16578501501894e-12_dp ) * y - & 8.776668218053e-11_dp ) * y - & 2.342817613343e-09_dp ) * y - & 3.496962018025e-08_dp ) * y - & 3.03172870136802e-07_dp ) * y + & 1.50511293969805e-06_dp ) * y + & 1.37704919387696e-04_dp ) * y + & 4.70723869619745e-02_dp ) * y - & 1.47486623003693e+00_dp ) * y + & 1.35704792175847e+01_dp w1 = ((((((((( 1.04348658616398e-13_dp * y - & 1.94147461891055e-12_dp ) * y + & 3.485512360993e-11_dp ) * y - & 6.277497362235e-10_dp ) * y + & 1.100758247388e-08_dp ) * y - & 1.88329804969573e-07_dp ) * y + & 3.12338120839468e-06_dp ) * y - & 5.04404167403568e-05_dp ) * y + & 8.00338056610995e-04_dp ) * y - & 1.30892406559521e-02_dp ) * y + & 2.47383140241103e-01_dp w2 = ((((((((((( 3.23496149760478e-14_dp * y - & 5.24314473469311e-13_dp ) * y + & 7.743219385056e-12_dp ) * y - & 1.146022750992e-10_dp ) * y + & 1.615238462197e-09_dp ) * y - & 2.15479017572233e-08_dp ) * y + & 2.70933462557631e-07_dp ) * y - & 3.18750295288531e-06_dp ) * y + & 3.47425221210099e-05_dp ) * y - & 3.45558237388223e-04_dp ) * y + & 3.05779768191621e-03_dp ) * y - & 2.29118251223003e-02_dp ) * y + & 1.59834227924213e-01_dp w3 = (((((((((((( - 3.42790561802876e-14_dp * y + & 5.26475736681542e-13_dp ) * y - & 7.184330797139e-12_dp ) * y + & 9.763932908544e-11_dp ) * y - & 1.244014559219e-09_dp ) * y + & 1.472744068942e-08_dp ) * y - & 1.611749975234e-07_dp ) * y + & 1.616487851917e-06_dp ) * y - & 1.46852359124154e-05_dp ) * y + & 1.18900349101069e-04_dp ) * y - & 8.37562373221756e-04_dp ) * y + & 4.93752683045845e-03_dp ) * y - & 2.25514728915673e-02_dp ) * y + & 6.95211812453929e-02_dp w4 = ((((((((((((( 1.04072340345039e-14_dp * y - & 1.60808044529211e-13_dp ) * y + & 2.183534866798e-12_dp ) * y - & 2.939403008391e-11_dp ) * y + & 3.679254029085e-10_dp ) * y - & 4.23775673047899e-09_dp ) * y + & 4.46559231067006e-08_dp ) * y - & 4.26488836563267e-07_dp ) * y + & 3.64721335274973e-06_dp ) * y - & 2.74868382777722e-05_dp ) * y + & 1.78586118867488e-04_dp ) * y - & 9.68428981886534e-04_dp ) * y + & 4.16002324339929e-03_dp ) * y - & 1.28290192663141e-02_dp ) * y + & 2.22353727685016e-02_dp w5 = (((((((((((((( - 8.16770412525963e-16_dp * y + & 1.31376515047977e-14_dp ) * y - & 1.856950818865e-13_dp ) * y + & 2.596836515749e-12_dp ) * y - & 3.372639523006e-11_dp ) * y + & 4.025371849467e-10_dp ) * y - & 4.389453269417e-09_dp ) * y + & 4.332753856271e-08_dp ) * y - & 3.82673275931962e-07_dp ) * y + & 2.98006900751543e-06_dp ) * y - & 2.00718990300052e-05_dp ) * y + & 1.13876001386361e-04_dp ) * y - & 5.23627942443563e-04_dp ) * y + & 1.83524565118203e-03_dp ) * y - & 4.37785737450783e-03_dp ) * y + & 5.36963805223095e-03_dp elseif ( x <= 1 0.0e+00_dp ) then y = x - 7.5e+00_dp r1 = (((((((( - 1.13825201010775e-14_dp * y + & 1.89737681670375e-13_dp ) * y - & 4.81561201185876e-12_dp ) * y + & 1.56666512163407e-10_dp ) * y - & 3.73782213255083e-09_dp ) * y + & 9.15858355075147e-08_dp ) * y - & 2.13775073585629e-06_dp ) * y + & 4.56547356365536e-05_dp ) * y - & 8.68003909323740e-04_dp ) * y + & 1.22703754069176e-02_dp r2 = ((((((((( - 3.67160504428358e-15_dp * y + & 1.27876280158297e-14_dp ) * y - & 1.296476623788e-12_dp ) * y + & 1.477175434354e-11_dp ) * y + & 5.464102147892e-10_dp ) * y - & 2.42538340602723e-08_dp ) * y + & 8.20460740637617e-07_dp ) * y - & 2.20379304598661e-05_dp ) * y + & 4.90295372978785e-04_dp ) * y - & 9.14294111576119e-03_dp ) * y + & 1.22590403403690e-01_dp r3 = ((((((((( 1.39017367502123e-14_dp * y - & 6.96391385426890e-13_dp ) * y + & 1.176946020731e-12_dp ) * y + & 1.725627235645e-10_dp ) * y - & 3.686383856300e-09_dp ) * y + & 2.87495324207095e-08_dp ) * y + & 1.71307311000282e-06_dp ) * y - & 7.94273603184629e-05_dp ) * y + & 2.00938064965897e-03_dp ) * y - & 3.63329491677178e-02_dp ) * y + & 4.34393683888443e-01_dp r4 = (((((((((( - 1.27815158195209e-14_dp * y + & 1.99910415869821e-14_dp ) * y + & 3.753542914426e-12_dp ) * y - & 2.708018219579e-11_dp ) * y - & 1.190574776587e-09_dp ) * y + & 1.106696436509e-08_dp ) * y + & 3.954955671326e-07_dp ) * y - & 4.398596059588e-06_dp ) * y - & 2.01087998907735e-04_dp ) * y + & 7.89092425542937e-03_dp ) * y - & 1.42056749162695e-01_dp ) * y + & 1.39964149420683e+00_dp r5 = (((((((((( - 1.19442341030461e-13_dp * y - & 2.34074833275956e-12_dp ) * y + & 6.861649627426e-12_dp ) * y + & 6.082671496226e-10_dp ) * y + & 5.381160105420e-09_dp ) * y - & 6.253297138700e-08_dp ) * y - & 2.135966835050e-06_dp ) * y - & 2.373394341886e-05_dp ) * y + & 2.88711171412814e-06_dp ) * y + & 4.85221195290753e-02_dp ) * y - & 1.04346091985269e+00_dp ) * y + & 7.89901551676692e+00_dp w1 = ((((((((( 7.95526040108997e-15_dp * y - & 2.48593096128045e-13_dp ) * y + & 4.761246208720e-12_dp ) * y - & 9.535763686605e-11_dp ) * y + & 2.225273630974e-09_dp ) * y - & 4.49796778054865e-08_dp ) * y + & 9.17812870287386e-07_dp ) * y - & 1.86764236490502e-05_dp ) * y + & 3.76807779068053e-04_dp ) * y - & 8.10456360143408e-03_dp ) * y + & 2.01097936411496e-01_dp w2 = ((((((((((( 1.25678686624734e-15_dp * y - & 2.34266248891173e-14_dp ) * y + & 3.973252415832e-13_dp ) * y - & 6.830539401049e-12_dp ) * y + & 1.140771033372e-10_dp ) * y - & 1.82546185762009e-09_dp ) * y + & 2.77209637550134e-08_dp ) * y - & 4.01726946190383e-07_dp ) * y + & 5.48227244014763e-06_dp ) * y - & 6.95676245982121e-05_dp ) * y + & 8.05193921815776e-04_dp ) * y - & 8.15528438784469e-03_dp ) * y + & 9.71769901268114e-02_dp w3 = (((((((((((( - 8.20929494859896e-16_dp * y + & 1.37356038393016e-14_dp ) * y - & 2.022863065220e-13_dp ) * y + & 3.058055403795e-12_dp ) * y - & 4.387890955243e-11_dp ) * y + & 5.923946274445e-10_dp ) * y - & 7.503659964159e-09_dp ) * y + & 8.851599803902e-08_dp ) * y - & 9.65561998415038e-07_dp ) * y + & 9.60884622778092e-06_dp ) * y - & 8.56551787594404e-05_dp ) * y + & 6.66057194311179e-04_dp ) * y - & 4.17753183902198e-03_dp ) * y + & 2.25443826852447e-02_dp w4 = (((((((((((((( - 1.08764612488790e-17_dp * y + & 1.85299909689937e-16_dp ) * y - & 2.730195628655e-15_dp ) * y + & 4.127368817265e-14_dp ) * y - & 5.881379088074e-13_dp ) * y + & 7.805245193391e-12_dp ) * y - & 9.632707991704e-11_dp ) * y + & 1.099047050624e-09_dp ) * y - & 1.15042731790748e-08_dp ) * y + & 1.09415155268932e-07_dp ) * y - & 9.33687124875935e-07_dp ) * y + & 7.02338477986218e-06_dp ) * y - & 4.53759748787756e-05_dp ) * y + & 2.41722511389146e-04_dp ) * y - & 9.75935943447037e-04_dp ) * y + & 2.57520532789644e-03_dp w5 = ((((((((((((((( 7.28996979748849e-19_dp * y - & 1.26518146195173e-17_dp ) * y + & 1.886145834486e-16_dp ) * y - & 2.876728287383e-15_dp ) * y + & 4.114588668138e-14_dp ) * y - & 5.44436631413933e-13_dp ) * y + & 6.64976446790959e-12_dp ) * y - & 7.44560069974940e-11_dp ) * y + & 7.57553198166848e-10_dp ) * y - & 6.92956101109829e-09_dp ) * y + & 5.62222859033624e-08_dp ) * y - & 3.97500114084351e-07_dp ) * y + & 2.39039126138140e-06_dp ) * y - & 1.18023950002105e-05_dp ) * y + & 4.52254031046244e-05_dp ) * y - & 1.21113782150370e-04_dp ) * y + & 1.75013126731224e-04_dp elseif ( x <= 1 5.0e+00_dp ) then y = x - 1 2.5e+00_dp r1 = (((((((((( - 4.16387977337393e-17_dp * y + & 7.20872997373860e-16_dp ) * y + & 1.395993802064e-14_dp ) * y + & 3.660484641252e-14_dp ) * y - & 4.154857548139e-12_dp ) * y + & 2.301379846544e-11_dp ) * y - & 1.033307012866e-09_dp ) * y + & 3.997777641049e-08_dp ) * y - & 9.35118186333939e-07_dp ) * y + & 2.38589932752937e-05_dp ) * y - & 5.35185183652937e-04_dp ) * y + & 8.85218988709735e-03_dp r2 = (((((((((( - 4.56279214732217e-16_dp * y + & 6.24941647247927e-15_dp ) * y + & 1.737896339191e-13_dp ) * y + & 8.964205979517e-14_dp ) * y - & 3.538906780633e-11_dp ) * y + & 9.561341254948e-11_dp ) * y - & 9.772831891310e-09_dp ) * y + & 4.240340194620e-07_dp ) * y - & 1.02384302866534e-05_dp ) * y + & 2.57987709704822e-04_dp ) * y - & 5.54735977651677e-03_dp ) * y + & 8.68245143991948e-02_dp r3 = (((((((((( - 2.52879337929239e-15_dp * y + & 2.13925810087833e-14_dp ) * y + & 7.884307667104e-13_dp ) * y - & 9.023398159510e-13_dp ) * y - & 5.814101544957e-11_dp ) * y - & 1.333480437968e-09_dp ) * y - & 2.217064940373e-08_dp ) * y + & 1.643290788086e-06_dp ) * y - & 4.39602147345028e-05_dp ) * y + & 1.08648982748911e-03_dp ) * y - & 2.13014521653498e-02_dp ) * y + & 2.94150684465425e-01_dp r4 = (((((((((( - 6.42391438038888e-15_dp * y + & 5.37848223438815e-15_dp ) * y + & 8.960828117859e-13_dp ) * y + & 5.214153461337e-11_dp ) * y - & 1.106601744067e-10_dp ) * y - & 2.007890743962e-08_dp ) * y + & 1.543764346501e-07_dp ) * y + & 4.520749076914e-06_dp ) * y - & 1.88893338587047e-04_dp ) * y + & 4.73264487389288e-03_dp ) * y - & 7.91197893350253e-02_dp ) * y + & 8.60057928514554e-01_dp r5 = ((((((((((( - 2.24366166957225e-14_dp * y + & 4.87224967526081e-14_dp ) * y + & 5.587369053655e-12_dp ) * y - & 3.045253104617e-12_dp ) * y - & 1.223983883080e-09_dp ) * y - & 2.05603889396319e-09_dp ) * y + & 2.58604071603561e-07_dp ) * y + & 1.34240904266268e-06_dp ) * y - & 5.72877569731162e-05_dp ) * y - & 9.56275105032191e-04_dp ) * y + & 4.23367010370921e-02_dp ) * y - & 5.76800927133412e-01_dp ) * y + & 3.87328263873381e+00_dp w1 = ((((((((( 8.98007931950169e-15_dp * y + & 7.25673623859497e-14_dp ) * y + & 5.851494250405e-14_dp ) * y - & 4.234204823846e-11_dp ) * y + & 3.911507312679e-10_dp ) * y - & 9.65094802088511e-09_dp ) * y + & 3.42197444235714e-07_dp ) * y - & 7.51821178144509e-06_dp ) * y + & 1.94218051498662e-04_dp ) * y - & 5.38533819142287e-03_dp ) * y + & 1.68122596736809e-01_dp w2 = (((((((((( - 1.05490525395105e-15_dp * y + & 1.96855386549388e-14_dp ) * y - & 5.500330153548e-13_dp ) * y + & 1.003849567976e-11_dp ) * y - & 1.720997242621e-10_dp ) * y + & 3.533277061402e-09_dp ) * y - & 6.389171736029e-08_dp ) * y + & 1.046236652393e-06_dp ) * y - & 1.73148206795827e-05_dp ) * y + & 2.57820531617185e-04_dp ) * y - & 3.46188265338350e-03_dp ) * y + & 7.03302497508176e-02_dp w3 = ((((((((((( 3.60020423754545e-16_dp * y - & 6.24245825017148e-15_dp ) * y + & 9.945311467434e-14_dp ) * y - & 1.749051512721e-12_dp ) * y + & 2.768503957853e-11_dp ) * y - & 4.08688551136506e-10_dp ) * y + & 6.04189063303610e-09_dp ) * y - & 8.23540111024147e-08_dp ) * y + & 1.01503783870262e-06_dp ) * y - & 1.20490761741576e-05_dp ) * y + & 1.26928442448148e-04_dp ) * y - & 1.05539461930597e-03_dp ) * y + & 1.15543698537013e-02_dp w4 = ((((((((((((( 2.51163533058925e-18_dp * y - & 4.31723745510697e-17_dp ) * y + & 6.557620865832e-16_dp ) * y - & 1.016528519495e-14_dp ) * y + & 1.491302084832e-13_dp ) * y - & 2.06638666222265e-12_dp ) * y + & 2.67958697789258e-11_dp ) * y - & 3.23322654638336e-10_dp ) * y + & 3.63722952167779e-09_dp ) * y - & 3.75484943783021e-08_dp ) * y + & 3.49164261987184e-07_dp ) * y - & 2.92658670674908e-06_dp ) * y + & 2.12937256719543e-05_dp ) * y - & 1.19434130620929e-04_dp ) * y + & 6.45524336158384e-04_dp w5 = (((((((((((((( - 1.29043630202811e-19_dp * y + & 2.16234952241296e-18_dp ) * y - & 3.107631557965e-17_dp ) * y + & 4.570804313173e-16_dp ) * y - & 6.301348858104e-15_dp ) * y + & 8.031304476153e-14_dp ) * y - & 9.446196472547e-13_dp ) * y + & 1.018245804339e-11_dp ) * y - & 9.96995451348129e-11_dp ) * y + & 8.77489010276305e-10_dp ) * y - & 6.84655877575364e-09_dp ) * y + & 4.64460857084983e-08_dp ) * y - & 2.66924538268397e-07_dp ) * y + & 1.24621276265907e-06_dp ) * y - & 4.30868944351523e-06_dp ) * y + & 9.94307982432868e-06_dp elseif ( x <= 2 0.0e+00_dp ) then y = x - 1 7.5e+00_dp r1 = (((((((((( 1.91875764545740e-16_dp * y + & 7.8357401095707e-16_dp ) * y - & 3.260875931644e-14_dp ) * y - & 1.186752035569e-13_dp ) * y + & 4.275180095653e-12_dp ) * y + & 3.357056136731e-11_dp ) * y - & 1.123776903884e-09_dp ) * y + & 1.231203269887e-08_dp ) * y - & 3.99851421361031e-07_dp ) * y + & 1.45418822817771e-05_dp ) * y - & 3.49912254976317e-04_dp ) * y + & 6.67768703938812e-03_dp r2 = (((((((((( 2.02778478673555e-15_dp * y + & 1.01640716785099e-14_dp ) * y - & 3.385363492036e-13_dp ) * y - & 1.615655871159e-12_dp ) * y + & 4.527419140333e-11_dp ) * y + & 3.853670706486e-10_dp ) * y - & 1.184607130107e-08_dp ) * y + & 1.347873288827e-07_dp ) * y - & 4.47788241748377e-06_dp ) * y + & 1.54942754358273e-04_dp ) * y - & 3.55524254280266e-03_dp ) * y + & 6.44912219301603e-02_dp r3 = (((((((((( 7.79850771456444e-15_dp * y + & 6.00464406395001e-14_dp ) * y - & 1.249779730869e-12_dp ) * y - & 1.020720636353e-11_dp ) * y + & 1.814709816693e-10_dp ) * y + & 1.766397336977e-09_dp ) * y - & 4.603559449010e-08_dp ) * y + & 5.863956443581e-07_dp ) * y - & 2.03797212506691e-05_dp ) * y + & 6.31405161185185e-04_dp ) * y - & 1.30102750145071e-02_dp ) * y + & 2.10244289044705e-01_dp r4 = ((((((((((( - 2.92397030777912e-15_dp * y + & 1.94152129078465e-14_dp ) * y + & 4.859447665850e-13_dp ) * y - & 3.217227223463e-12_dp ) * y - & 7.484522135512e-11_dp ) * y + & 7.19101516047753e-10_dp ) * y + & 6.88409355245582e-09_dp ) * y - & 1.44374545515769e-07_dp ) * y + & 2.74941013315834e-06_dp ) * y - & 1.02790452049013e-04_dp ) * y + & 2.59924221372643e-03_dp ) * y - & 4.35712368303551e-02_dp ) * y + & 5.62170709585029e-01_dp r5 = ((((((((((( 1.17976126840060e-14_dp * y + & 1.24156229350669e-13_dp ) * y - & 3.892741622280e-12_dp ) * y - & 7.755793199043e-12_dp ) * y + & 9.492190032313e-10_dp ) * y - & 4.98680128123353e-09_dp ) * y - & 1.81502268782664e-07_dp ) * y + & 2.69463269394888e-06_dp ) * y + & 2.50032154421640e-05_dp ) * y - & 1.33684303917681e-03_dp ) * y + & 2.29121951862538e-02_dp ) * y - & 2.45653725061323e-01_dp ) * y + & 1.89999883453047e+00_dp w1 = (((((((((( 1.74841995087592e-15_dp * y - & 6.95671892641256e-16_dp ) * y - & 3.000659497257e-13_dp ) * y + & 2.021279817961e-13_dp ) * y + & 3.853596935400e-11_dp ) * y + & 1.461418533652e-10_dp ) * y - & 1.014517563435e-08_dp ) * y + & 1.132736008979e-07_dp ) * y - & 2.86605475073259e-06_dp ) * y + & 1.21958354908768e-04_dp ) * y - & 3.86293751153466e-03_dp ) * y + & 1.45298342081522e-01_dp w2 = (((((((((( - 1.11199320525573e-15_dp * y + & 1.85007587796671e-15_dp ) * y + & 1.220613939709e-13_dp ) * y + & 1.275068098526e-12_dp ) * y - & 5.341838883262e-11_dp ) * y + & 6.161037256669e-10_dp ) * y - & 1.009147879750e-08_dp ) * y + & 2.907862965346e-07_dp ) * y - & 6.12300038720919e-06_dp ) * y + & 1.00104454489518e-04_dp ) * y - & 1.80677298502757e-03_dp ) * y + & 5.78009914536630e-02_dp w3 = (((((((((( - 9.49816486853687e-16_dp * y + & 6.67922080354234e-15_dp ) * y + & 2.606163540537e-15_dp ) * y + & 1.983799950150e-12_dp ) * y - & 5.400548574357e-11_dp ) * y + & 6.638043374114e-10_dp ) * y - & 8.799518866802e-09_dp ) * y + & 1.791418482685e-07_dp ) * y - & 2.96075397351101e-06_dp ) * y + & 3.38028206156144e-05_dp ) * y - & 3.58426847857878e-04_dp ) * y + & 8.39213709428516e-03_dp w4 = ((((((((((( 1.33829971060180e-17_dp * y - & 3.44841877844140e-16_dp ) * y + & 4.745009557656e-15_dp ) * y - & 6.033814209875e-14_dp ) * y + & 1.049256040808e-12_dp ) * y - & 1.70859789556117e-11_dp ) * y + & 2.15219425727959e-10_dp ) * y - & 2.52746574206884e-09_dp ) * y + & 3.27761714422960e-08_dp ) * y - & 3.90387662925193e-07_dp ) * y + & 3.46340204593870e-06_dp ) * y - & 2.43236345136782e-05_dp ) * y + & 3.54846978585226e-04_dp w5 = ((((((((((((( 2.69412277020887e-20_dp * y - & 4.24837886165685e-19_dp ) * y + & 6.030500065438e-18_dp ) * y - & 9.069722758289e-17_dp ) * y + & 1.246599177672e-15_dp ) * y - & 1.56872999797549e-14_dp ) * y + & 1.87305099552692e-13_dp ) * y - & 2.09498886675861e-12_dp ) * y + & 2.11630022068394e-11_dp ) * y - & 1.92566242323525e-10_dp ) * y + & 1.62012436344069e-09_dp ) * y - & 1.23621614171556e-08_dp ) * y + & 7.72165684563049e-08_dp ) * y - & 3.59858901591047e-07_dp ) * y + & 2.43682618601000e-06_dp elseif ( x <= 2 5.0e+00_dp ) then y = x - 2 2.5e+00_dp r1 = ((((((((( - 1.13927848238726e-15_dp * y + & 7.39404133595713e-15_dp ) * y + & 1.445982921243e-13_dp ) * y - & 2.676703245252e-12_dp ) * y + & 5.823521627177e-12_dp ) * y + & 2.17264723874381e-10_dp ) * y + & 3.56242145897468e-09_dp ) * y - & 3.03763737404491e-07_dp ) * y + & 9.46859114120901e-06_dp ) * y - & 2.30896753853196e-04_dp ) * y + & 5.24663913001114e-03_dp r2 = (((((((((( 2.89872355524581e-16_dp * y - & 1.22296292045864e-14_dp ) * y + & 6.184065097200e-14_dp ) * y + & 1.649846591230e-12_dp ) * y - & 2.729713905266e-11_dp ) * y + & 3.709913790650e-11_dp ) * y + & 2.216486288382e-09_dp ) * y + & 4.616160236414e-08_dp ) * y - & 3.32380270861364e-06_dp ) * y + & 9.84635072633776e-05_dp ) * y - & 2.30092118015697e-03_dp ) * y + & 5.00845183695073e-02_dp r3 = (((((((((( 1.97068646590923e-15_dp * y - & 4.89419270626800e-14_dp ) * y + & 1.136466605916e-13_dp ) * y + & 7.546203883874e-12_dp ) * y - & 9.635646767455e-11_dp ) * y - & 8.295965491209e-11_dp ) * y + & 7.534109114453e-09_dp ) * y + & 2.699970652707e-07_dp ) * y - & 1.42982334217081e-05_dp ) * y + & 3.78290946669264e-04_dp ) * y - & 8.03133015084373e-03_dp ) * y + & 1.58689469640791e-01_dp r4 = (((((((((( 1.33642069941389e-14_dp * y - & 1.55850612605745e-13_dp ) * y - & 7.522712577474e-13_dp ) * y + & 3.209520801187e-11_dp ) * y - & 2.075594313618e-10_dp ) * y - & 2.070575894402e-09_dp ) * y + & 7.323046997451e-09_dp ) * y + & 1.851491550417e-06_dp ) * y - & 6.37524802411383e-05_dp ) * y + & 1.36795464918785e-03_dp ) * y - & 2.42051126993146e-02_dp ) * y + & 3.97847167557815e-01_dp r5 = (((((((((( - 6.07053986130526e-14_dp * y + & 1.04447493138843e-12_dp ) * y - & 4.286617818951e-13_dp ) * y - & 2.632066100073e-10_dp ) * y + & 4.804518986559e-09_dp ) * y - & 1.835675889421e-08_dp ) * y - & 1.068175391334e-06_dp ) * y + & 3.292234974141e-05_dp ) * y - & 5.94805357558251e-04_dp ) * y + & 8.29382168612791e-03_dp ) * y - & 9.93122509049447e-02_dp ) * y + & 1.09857804755042e+00_dp w1 = ((((((((( - 9.10338640266542e-15_dp * y + & 1.00438927627833e-13_dp ) * y + & 7.817349237071e-13_dp ) * y - & 2.547619474232e-11_dp ) * y + & 1.479321506529e-10_dp ) * y + & 1.52314028857627e-09_dp ) * y + & 9.20072040917242e-09_dp ) * y - & 2.19427111221848e-06_dp ) * y + & 8.65797782880311e-05_dp ) * y - & 2.82718629312875e-03_dp ) * y + & 1.28718310443295e-01_dp w2 = ((((((((( 5.52380927618760e-15_dp * y - & 6.43424400204124e-14_dp ) * y - & 2.358734508092e-13_dp ) * y + & 8.261326648131e-12_dp ) * y + & 9.229645304956e-11_dp ) * y - & 5.68108973828949e-09_dp ) * y + & 1.22477891136278e-07_dp ) * y - & 2.11919643127927e-06_dp ) * y + & 4.23605032368922e-05_dp ) * y - & 1.14423444576221e-03_dp ) * y + & 5.06607252890186e-02_dp w3 = ((((((((( 3.99457454087556e-15_dp * y - & 5.11826702824182e-14_dp ) * y - & 4.157593182747e-14_dp ) * y + & 4.214670817758e-12_dp ) * y + & 6.705582751532e-11_dp ) * y - & 3.36086411698418e-09_dp ) * y + & 6.07453633298986e-08_dp ) * y - & 7.40736211041247e-07_dp ) * y + & 8.84176371665149e-06_dp ) * y - & 1.72559275066834e-04_dp ) * y + & 7.16639814253567e-03_dp w4 = ((((((((((( - 2.14649508112234e-18_dp * y - & 2.45525846412281e-18_dp ) * y + & 6.126212599772e-16_dp ) * y - & 8.526651626939e-15_dp ) * y + & 4.826636065733e-14_dp ) * y - & 3.39554163649740e-13_dp ) * y + & 1.67070784862985e-11_dp ) * y - & 4.42671979311163e-10_dp ) * y + & 6.77368055908400e-09_dp ) * y - & 7.03520999708859e-08_dp ) * y + & 6.04993294708874e-07_dp ) * y - & 7.80555094280483e-06_dp ) * y + & 2.85954806605017e-04_dp w5 = (((((((((((( - 5.63938733073804e-21_dp * y + & 6.92182516324628e-20_dp ) * y - & 1.586937691507e-18_dp ) * y + & 3.357639744582e-17_dp ) * y - & 4.810285046442e-16_dp ) * y + & 5.386312669975e-15_dp ) * y - & 6.117895297439e-14_dp ) * y + & 8.441808227634e-13_dp ) * y - & 1.18527596836592e-11_dp ) * y + & 1.36296870441445e-10_dp ) * y - & 1.17842611094141e-09_dp ) * y + & 7.80430641995926e-09_dp ) * y - & 5.97767417400540e-08_dp ) * y + & 1.65186146094969e-06_dp elseif ( x <= 4 0.0e+00_dp ) then w1 = sqrt ( PIo4 / x ) e = exp ( - x ) r1 = (((((((( - 1.73363958895356e-06_dp * x + & 1.19921331441483e-04_dp ) * x - & 1.59437614121125e-02_dp ) * x + & 1.13467897349442e+00_dp ) * x - & 4.47216460864586e+01_dp ) * x + & 1.06251216612604e+03_dp ) * x - & 1.52073917378512e+04_dp ) * x + & 1.20662887111273e+05_dp ) * x - & 4.07186366852475e+05_dp ) * e + r15 / ( x - r15 ) r2 = (((((((( - 1.60102542621710e-05_dp * x + & 1.10331262112395e-03_dp ) * x - & 1.50043662589017e-01_dp ) * x + & 1.05563640866077e+01_dp ) * x - & 4.10468817024806e+02_dp ) * x + & 9.62604416506819e+03_dp ) * x - & 1.35888069838270e+05_dp ) * x + & 1.06107577038340e+06_dp ) * x - & 3.51190792816119e+06_dp ) * e + r25 / ( x - r25 ) r3 = (((((((( - 4.48880032128422e-05_dp * x + & 2.69025112122177e-03_dp ) * x - & 4.01048115525954e-01_dp ) * x + & 2.78360021977405e+01_dp ) * x - & 1.04891729356965e+03_dp ) * x + & 2.36985942687423e+04_dp ) * x - & 3.19504627257548e+05_dp ) * x + & 2.34879693563358e+06_dp ) * x - & 7.16341568174085e+06_dp ) * e + r35 / ( x - r35 ) r4 = (((((((( - 6.38526371092582e-05_dp * x - & 2.29263585792626e-03_dp ) * x - & 7.65735935499627e-02_dp ) * x + & 9.12692349152792e+00_dp ) * x - & 2.32077034386717e+02_dp ) * x + & 2.81839578728845e+02_dp ) * x + & 9.59529683876419e+04_dp ) * x - & 1.77638956809518e+06_dp ) * x + & 1.02489759645410e+07_dp ) * e + r45 / ( x - r45 ) r5 = (((((((( - 3.59049364231569e-05_dp * x - & 2.25963977930044e-02_dp ) * x + & 1.12594870794668e+00_dp ) * x - & 4.56752462103909e+01_dp ) * x + & 1.05804526830637e+03_dp ) * x - & 1.16003199605875e+04_dp ) * x - & 4.07297627297272e+04_dp ) * x + & 2.22215528319857e+06_dp ) * x - & 1.61196455032613e+07_dp ) * e + r55 / ( x - r55 ) w5 = ((((((((( - 4.61100906133970e-10_dp * x + & 1.43069932644286e-07_dp ) * x - & 1.63960915431080e-05_dp ) * x + & 1.15791154612838e-03_dp ) * x - & 5.30573476742071e-02_dp ) * x + & 1.61156533367153e+00_dp ) * x - & 3.23248143316007e+01_dp ) * x + & 4.12007318109157e+02_dp ) * x - & 3.02260070158372e+03_dp ) * x + & 9.71575094154768e+03_dp ) * e + w55 * w1 w4 = ((((((((( - 2.40799435809950e-08_dp * x + & 8.12621667601546e-06_dp ) * x - & 9.04491430884113e-04_dp ) * x + & 6.37686375770059e-02_dp ) * x - & 2.96135703135647e+00_dp ) * x + & 9.15142356996330e+01_dp ) * x - & 1.86971865249111e+03_dp ) * x + & 2.42945528916947e+04_dp ) * x - & 1.81852473229081e+05_dp ) * x + & 5.96854758661427e+05_dp ) * e + w45 * w1 w3 = (((((((( 1.83574464457207e-05_dp * x - & 1.54837969489927e-03_dp ) * x + & 1.18520453711586e-01_dp ) * x - & 6.69649981309161e+00_dp ) * x + & 2.44789386487321e+02_dp ) * x - & 5.68832664556359e+03_dp ) * x + & 8.14507604229357e+04_dp ) * x - & 6.55181056671474e+05_dp ) * x + & 2.26410896607237e+06_dp ) * e + w35 * w1 w2 = (((((((( 2.77778345870650e-05_dp * x - & 2.22835017655890e-03_dp ) * x + & 1.61077633475573e-01_dp ) * x - & 8.96743743396132e+00_dp ) * x + & 3.28062687293374e+02_dp ) * x - & 7.65722701219557e+03_dp ) * x + & 1.10255055017664e+05_dp ) * x - & 8.92528122219324e+05_dp ) * x + & 3.10638627744347e+06_dp ) * e + w25 * w1 w1 = w1 - 0.01962e+00_dp * e - w2 - w3 - w4 - w5 elseif ( x <= 5 9.0e+00_dp ) then w1 = sqrt ( PIo4 / x ) y = x ** 3 e = y * exp ( - x ) r1 = ((( - 2.43758528330205e-02_dp * x + & 2.07301567989771e+00_dp ) * x - & 6.45964225381113e+01_dp ) * x + & 7.14160088655470e+02_dp ) * e + r15 / ( x - r15 ) r2 = ((( - 2.28861955413636e-01_dp * x + & 1.93190784733691e+01_dp ) * x - & 5.99774730340912e+02_dp ) * x + & 6.61844165304871e+03_dp ) * e + r25 / ( x - r25 ) r3 = ((( - 6.95053039285586e-01_dp * x + & 5.76874090316016e+01_dp ) * x - & 1.77704143225520e+03_dp ) * x + & 1.95366082947811e+04_dp ) * e + r35 / ( x - r35 ) r4 = ((( - 1.58072809087018e+00_dp * x + & 1.27050801091948e+02_dp ) * x - & 3.86687350914280e+03_dp ) * x + & 4.23024828121420e+04_dp ) * e + r45 / ( x - r45 ) r5 = ((( - 3.33963830405396e+00_dp * x + & 2.51830424600204e+02_dp ) * x - & 7.57728527654961e+03_dp ) * x + & 8.21966816595690e+04_dp ) * e + r55 / ( x - r55 ) e = y * e w5 = (( 1.35482430510942e-08_dp * x - & 3.27722199212781e-07_dp ) * x + & 2.41522703684296e-06_dp ) * e + w55 * w1 w4 = (( 1.23464092261605e-06_dp * x - & 3.55224564275590e-05_dp ) * x + & 3.03274662192286e-04_dp ) * e + w45 * w1 w3 = (( 1.34547929260279e-05_dp * x - & 4.19389884772726e-04_dp ) * x + & 3.87706687610809e-03_dp ) * e + w35 * w1 w2 = (( 2.09539509123135e-05_dp * x - & 6.87646614786982e-04_dp ) * x + & 6.68743788585688e-03_dp ) * e + w25 * w1 w1 = w1 - w2 - w3 - w4 - w5 else w1 = sqrt ( PIo4 / x ) r1 = r15 / ( x - r15 ) r2 = r25 / ( x - r25 ) r3 = r35 / ( x - r35 ) r4 = r45 / ( x - r45 ) r5 = r55 / ( x - r55 ) w2 = w25 * w1 w3 = w35 * w1 w4 = w45 * w1 w5 = w55 * w1 w1 = w1 - w2 - w3 - w4 - w5 end if r = ( / r1 , r2 , r3 , r4 , r5 / ) w = ( / w1 , w2 , w3 , w4 , w5 / ) end subroutine rys_rt5 !----------------------------------------------------------------- subroutine rys_general ( x , r , w , nroots ) real ( KIND = dp ), intent ( IN ) :: x real ( KIND = dp ), intent ( OUT ) :: r (:), w (:) integer , intent ( IN ) :: nroots real ( KIND = dp ) :: beta ( 0 : mxrys ) real ( KIND = dp ) :: rgrid ( maux ), wgrid ( maux ) real ( KIND = dp ) :: scr1 ( maux ), scr2 ( maux ) integer :: naux , rmap naux = nauxs ( nroots ) rmap = maprys ( nroots ) if ( x >= xasymp ( nroots )) then r (: nroots ) = rts_hermit (: nroots , nroots ) / x w (: nroots ) = wts_hermit (: nroots , nroots ) / sqrt ( x ) else rgrid (: naux ) = rtsaux (: naux , rmap ) wgrid (: naux ) = wtsaux (: naux , rmap ) * exp ( - x * rtsaux (: naux , rmap )) call discretized_stieltjes ( nroots , naux , rgrid , wgrid , & r , beta , scr1 , scr2 ) call golub_welsch ( nroots , r , beta , eps_eig , w ( 1 : nroots )) end if r ( 1 : nroots ) = r ( 1 : nroots ) / ( 1 - r ( 1 : nroots )) end subroutine rys_general !----------------------------------------------------------------- subroutine discretized_stieltjes ( n , naux , r , w , alpha , beta , & p_old , p ) integer , intent ( IN ) :: n , naux real ( KIND = dp ), intent ( IN ) :: r ( * ), w ( * ) real ( KIND = dp ), intent ( OUT ) :: alpha ( * ), beta ( * ) real ( KIND = dp ), intent ( INOUT ) :: p_old ( * ), p ( * ) #ifdef DEBUG real ( KIND = dp ), parameter :: & sqrt_tiny = sqrt ( tiny ( 0.0e+00_dp )), & sqrt_huge = sqrt ( huge ( 0.0e+00_dp )) #endif real ( KIND = dp ) :: tmp , pp_old , pp , xpp integer :: i , k #ifdef DEBUG if ( n <= 0 . or . n > naux ) then error stop \"Inconsistent n or naux in discretized_stieltjes\" end if #endif pp_old = sum ( w (: naux )) pp = dot_product ( w (: naux ), r (: naux )) alpha ( 1 ) = pp / pp_old beta ( 1 ) = pp_old if ( n == 1 ) return p_old ( 1 : naux ) = 0.0e+00_dp p ( 1 : naux ) = 1.0e+00_dp do k = 1 , n - 1 pp = 0 xpp = 0 do i = 1 , naux tmp = p ( i ) p ( i ) = ( r ( i ) - alpha ( k )) * p ( i ) - beta ( k ) * p_old ( i ) p_old ( i ) = tmp pp = pp + w ( i ) * p ( i ) * p ( i ) xpp = xpp + r ( i ) * w ( i ) * p ( i ) * p ( i ) end do #ifdef DEBUG if ( abs ( xpp ) > sqrt_huge . or . abs ( pp ) < sqrt_tiny ) then error stop \"Numerical issues in discretized_stieltjes\" end if #endif alpha ( k + 1 ) = xpp / pp beta ( k + 1 ) = pp / pp_old pp_old = pp end do end subroutine discretized_stieltjes !----------------------------------------------------------------- subroutine golub_welsch ( n , alpha , beta , eps , weight ) integer , parameter :: GW_MAXIT = 30 integer , intent ( IN ) :: n real ( KIND = dp ), intent ( INOUT ) :: alpha ( * ) real ( KIND = dp ), intent ( INOUT ) :: beta ( 0 : * ) real ( KIND = dp ), intent ( OUT ) :: weight ( * ) real ( KIND = dp ), intent ( IN ) :: eps integer :: i , j , l , m real ( KIND = dp ) :: b , c , f , g , p , r , s , mu0 #ifdef DEBUG if ( any ( beta (: n ) < 0.0e+00_dp )) then error stop \"Negative beta coef. in golub_welsch\" end if #endif if ( n == 1 ) then weight ( 1 ) = beta ( 0 ) return end if mu0 = beta ( 0 ) beta ( 1 : n - 1 ) = sqrt ( beta ( 1 : n - 1 )) beta ( n ) = 0 weight ( 1 ) = 1.0e+00_dp weight ( 2 : n ) = 0.0e+00_dp large : do l = 1 , n j = 0 iter : do do m = l , n - 1 if ( abs ( beta ( m )) <= & eps * ( abs ( alpha ( m )) + abs ( alpha ( m + 1 )))) exit end do if ( m == l ) exit iter if ( j == GW_MAXIT ) then #ifdef DEBUG error stop \"Golub-Welsch procedure can't converge\" #endif return end if j = j + 1 g = ( alpha ( l + 1 ) - alpha ( l )) / ( 2.0e+00_dp * beta ( l )) r = sqrt ( g * g + 1.0e+00_dp ) g = alpha ( m ) - alpha ( l ) + beta ( l ) / ( g + sign ( r , g )) s = 1.0e+00_dp c = 1.0e+00_dp p = 0.0e+00_dp do i = m - 1 , l , - 1 f = s * beta ( i ) b = c * beta ( i ) if ( abs ( f ) < abs ( g )) then s = f / g r = sqrt ( s * s + 1.0e+00_dp ) beta ( i + 1 ) = g * r c = 1.0e+00_dp / r s = s * c else c = g / f r = sqrt ( c * c + 1.0e+00_dp ) beta ( i + 1 ) = f * r s = 1.0e+00_dp / r c = c * s end if g = alpha ( i + 1 ) - p r = ( alpha ( i ) - g ) * s + 2.0e+00_dp * c * b p = s * r alpha ( i + 1 ) = g + p g = c * r - b f = weight ( i + 1 ) weight ( i + 1 ) = s * weight ( i ) + c * f weight ( i ) = c * weight ( i ) - s * f end do alpha ( l ) = alpha ( l ) - p beta ( l ) = g beta ( m ) = 0.0e+00_dp end do iter end do large weight ( 1 : n ) = mu0 * weight ( 1 : n ) * weight ( 1 : n ) end subroutine golub_welsch end module rys","tags":"","url":"sourcefile/rys.f90.html"},{"title":"sap_lut.F90 – OpenQP Fortran API","text":"Source Code !> @brief Radial superposition-of-atomic-potentials (SAP) lookup table. !> !> Loads Susi Lehtola's tabulated effective atomic charges Z_eff(r) from the !> OpenQP data file (basis_sets/sap_grasp.dat, generated offline by !> tools/sap/generate_sap_data.py from pyscf.dft.sap_data) and evaluates the !> SAP potential of a neutral atom, !>     V_A(r) = -Z_eff(r) / r, !> by linear interpolation, matching the reference implementation !> (S. Lehtola, J. Chem. Theory Comput. 15, 1593 (2019)). module sap_lut use precision , only : dp implicit none private public :: sap_table_t type :: sap_table_t integer :: nr = 0 !< number of radial points integer :: zmax = 0 !< highest supported atomic number real ( kind = dp ), allocatable :: r (:) !< radial grid (nr), bohr real ( kind = dp ), allocatable :: zeff (:,:) !< Z_eff(r) (nr, zmax) real ( kind = dp ) :: rmax = 0.0_dp !< largest tabulated r contains procedure :: load => sap_load procedure :: potential => sap_potential procedure :: clean => sap_clean end type contains !> @brief Load the radial SAP table from a data file. subroutine sap_load ( self , filename , err ) use io_constants , only : IW class ( sap_table_t ), intent ( inout ) :: self character ( len =* ), intent ( in ) :: filename logical , intent ( out ) :: err integer :: u , ios , z character ( len = 256 ) :: line err = . false . call self % clean () open ( newunit = u , file = trim ( filename ), status = 'old' , action = 'read' , iostat = ios ) if ( ios /= 0 ) then err = . true . return end if ! Skip comment lines beginning with '#' do read ( u , '(A)' , iostat = ios ) line if ( ios /= 0 ) then err = . true . close ( u ) return end if if ( len_trim ( line ) == 0 ) cycle if ( line ( 1 : 1 ) == '#' ) cycle exit end do ! 'line' now holds the header: zmax nr read ( line , * , iostat = ios ) self % zmax , self % nr if ( ios /= 0 . or . self % zmax <= 0 . or . self % nr <= 0 ) then err = . true . close ( u ) return end if allocate ( self % r ( self % nr ), self % zeff ( self % nr , self % zmax )) read ( u , * , iostat = ios ) self % r if ( ios /= 0 ) then err = . true . close ( u ) return end if do z = 1 , self % zmax read ( u , * , iostat = ios ) self % zeff (:, z ) if ( ios /= 0 ) then err = . true . close ( u ) return end if end do close ( u ) self % rmax = self % r ( self % nr ) end subroutine sap_load !> @brief SAP potential V(r) = -Z_eff(r)/r for an atom of nuclear charge z. !> !> Uses linear interpolation on the tabulated grid. Returns 0 beyond the !> tabulated range (Z_eff has decayed to 0 there) and the bare nuclear !> limit -z/r is approached as r -> 0 because Z_eff(0) = z. pure function sap_potential ( self , z , dist ) result ( v ) class ( sap_table_t ), intent ( in ) :: self integer , intent ( in ) :: z real ( kind = dp ), intent ( in ) :: dist real ( kind = dp ) :: v real ( kind = dp ) :: zeff_r integer :: lo , hi , mid real ( kind = dp ) :: t v = 0.0_dp if ( z < 1 . or . z > self % zmax ) return if ( dist <= 0.0_dp ) return if ( dist >= self % rmax ) return ! Binary search for the bracketing interval [r(lo), r(lo+1)] lo = 1 hi = self % nr do while ( hi - lo > 1 ) mid = ( lo + hi ) / 2 if ( self % r ( mid ) <= dist ) then lo = mid else hi = mid end if end do t = ( dist - self % r ( lo )) / ( self % r ( lo + 1 ) - self % r ( lo )) zeff_r = self % zeff ( lo , z ) + t * ( self % zeff ( lo + 1 , z ) - self % zeff ( lo , z )) v = - zeff_r / dist end function sap_potential subroutine sap_clean ( self ) class ( sap_table_t ), intent ( inout ) :: self if ( allocated ( self % r )) deallocate ( self % r ) if ( allocated ( self % zeff )) deallocate ( self % zeff ) self % nr = 0 self % zmax = 0 self % rmax = 0.0_dp end subroutine sap_clean end module sap_lut","tags":"","url":"sourcefile/sap_lut.f90.html"},{"title":"lapack_wrap.F90 – OpenQP Fortran API","text":"Source Code module lapack_wrap use precision , only : dp use mathlib_types , only : BLAS_INT , HUGE_BLAS_INT use messages , only : show_message , WITH_ABORT implicit none public private dp , blas_int , huge_blas_int , show_message , with_abort logical , parameter , private :: ARG_CHECK = . false . character ( len =* ), parameter , private :: BITNESS ( 2 ) = [ \"32\" , \"64\" ] character ( len =* ), parameter , private :: ERRMSG = & \"Integer is too big for \" // BITNESS ( BLAS_INT / 4 ) // \"bit BLAS/LAPACK\" contains !---------------------------------------------------------------------- subroutine oqp_dgeqrf_i64 ( m , n , a , lda , tau , work , lwork , info ) integer :: info , lda , lwork , m , n real ( dp ) :: a ( lda , * ), tau ( * ), work ( * ) integer ( blas_int ) :: info_ , lda_ , lwork_ , m_ , n_ logical :: ok if ( ARG_CHECK ) then ok = . true . ok = ok . and . ( lda <= HUGE_BLAS_INT ) ok = ok . and . ( lwork <= HUGE_BLAS_INT ) ok = ok . and . ( m <= HUGE_BLAS_INT ) ok = ok . and . ( n <= HUGE_BLAS_INT ) if (. not . ok ) call show_message ( ERRMSG , WITH_ABORT ) end if lda_ = int ( lda , blas_int ) lwork_ = int ( lwork , blas_int ) m_ = int ( m , blas_int ) n_ = int ( n , blas_int ) call dgeqrf ( m_ , n_ , a , lda_ , tau , work , lwork_ , info_ ) info = info_ end subroutine !---------------------------------------------------------------------- subroutine oqp_dgels_i64 ( trans , m , n , nrhs , a , lda , b , ldb , work , lwork , info ) character :: trans integer :: info , lda , ldb , lwork , m , n , nrhs real ( dp ) :: a ( lda , * ), b ( ldb , * ), work ( * ) integer ( blas_int ) :: info_ , lda_ , ldb_ , lwork_ , m_ , n_ , nrhs_ logical :: ok if ( ARG_CHECK ) then ok = . true . ok = ok . and . ( lda <= HUGE_BLAS_INT ) ok = ok . and . ( ldb <= HUGE_BLAS_INT ) ok = ok . and . ( lwork <= HUGE_BLAS_INT ) ok = ok . and . ( m <= HUGE_BLAS_INT ) ok = ok . and . ( n <= HUGE_BLAS_INT ) ok = ok . and . ( nrhs <= HUGE_BLAS_INT ) if (. not . ok ) call show_message ( ERRMSG , WITH_ABORT ) end if lda_ = int ( lda , blas_int ) ldb_ = int ( ldb , blas_int ) lwork_ = int ( lwork , blas_int ) m_ = int ( m , blas_int ) n_ = int ( n , blas_int ) nrhs_ = int ( nrhs , blas_int ) call dgels ( trans , m_ , n_ , nrhs_ , a , lda_ , b , ldb_ , work , lwork_ , info_ ) info = info_ end subroutine !---------------------------------------------------------------------- subroutine oqp_dgesv_i64 ( n , nrhs , a , lda , ipiv , b , ldb , info ) integer :: info , lda , ldb , n , nrhs integer :: ipiv ( * ) real ( dp ) :: a ( lda , * ), b ( ldb , * ) integer ( blas_int ) :: info_ , lda_ , ldb_ , n_ , nrhs_ integer ( blas_int ), allocatable :: ipiv_ (:) logical :: ok if ( ARG_CHECK ) then ok = . true . ok = ok . and . ( lda <= HUGE_BLAS_INT ) ok = ok . and . ( ldb <= HUGE_BLAS_INT ) ok = ok . and . ( n <= HUGE_BLAS_INT ) ok = ok . and . ( nrhs <= HUGE_BLAS_INT ) if (. not . ok ) call show_message ( ERRMSG , WITH_ABORT ) end if lda_ = int ( lda , blas_int ) ldb_ = int ( ldb , blas_int ) n_ = int ( n , blas_int ) nrhs_ = int ( nrhs , blas_int ) allocate ( ipiv_ ( n )) call dgesv ( n_ , nrhs_ , a , lda_ , ipiv , b , ldb_ , info_ ) info = info_ ipiv (: n ) = ipiv_ end subroutine !MHR START !---------------------------------------------------------------------- !> Compute the inverse of a real matrix using LAPACK routine dgetri. !! @param n       Size of the matrix. !! @param a       On entry, the matrix to be inverted. On exit, the inverted !matrix. !! @param lda     Leading dimension of the array `a`. !! @param ipiv    Integer array of size `n` containing pivot indices computed by !dgetrf. !! @param work    Workspace array of size `lwork`. !! @param lwork   Size of the workspace array. !! @param info    On exit, info = 0 for successful exit. If info = -i, the i-th !argument had an illegal value. subroutine oqp_dgetri_i64 ( n , a , lda , ipiv , work , lwork , info ) integer :: n , lda , ipiv (:), lwork , info real ( dp ) :: a ( lda , * ), work ( lwork ) integer ( blas_int ) :: n_ , lda_ , lwork_ , info_ logical :: ok ! Check arguments if ( ARG_CHECK ) then ok = . true . ! Check if the size of n, lda, and lwork is within acceptable bounds ok = ok . and . ( n <= HUGE_BLAS_INT ) ok = ok . and . ( lda <= HUGE_BLAS_INT ) ok = ok . and . ( lwork <= HUGE_BLAS_INT ) ! If any of the arguments are invalid, display error message and abort if (. not . ok ) call show_message ( ERRMSG , WITH_ABORT ) end if ! Convert integer arguments to blas_int type n_ = int ( n , blas_int ) lda_ = int ( lda , blas_int ) lwork_ = int ( lwork , blas_int ) ! Call LAPACK routine dgetri to compute the inverse of the matrix call dgetri ( n_ , a , lda_ , ipiv , work , lwork_ , info_ ) ! Assign the output info_ to the info argument info = info_ end subroutine !> LU factorization of a general matrix using LAPACK routine dgetrf. !! This subroutine computes the 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 subroutine overwrites the input matrix A with its factors L and U. !! @param m       Number of rows in the matrix A. !! @param n       Number of columns in the matrix A. !! @param a       On entry, the matrix to be factorized. On exit, the factors L !and U. !! @param lda     Leading dimension of the array `a`, must be at least max(1,m). !! @param ipiv    Integer array of dimension at least min(m,n) containing the !pivot indices. !! @param info    On exit, info = 0 for successful exit. If info = -i, the i-th !argument had an illegal value. subroutine oqp_dgetrf_i64 ( m , n , a , lda , ipiv , info ) integer :: m , n , lda , ipiv ( min ( m , n )), info real ( dp ) :: a ( lda , * ) integer ( blas_int ) :: m_ , n_ , lda_ , info_ integer ( blas_int ), allocatable :: ipiv_ (:) logical :: ok ! Check arguments if ( ARG_CHECK ) then ok = . true . ! Check if the size of m, n, and lda is within acceptable bounds ok = ok . and . ( m <= HUGE_BLAS_INT ) ok = ok . and . ( n <= HUGE_BLAS_INT ) ok = ok . and . ( lda <= HUGE_BLAS_INT ) ! If any of the arguments are invalid, display error message and abort if (. not . ok ) call show_message ( ERRMSG , WITH_ABORT ) end if ! Convert integer arguments to blas_int type m_ = int ( m , blas_int ) n_ = int ( n , blas_int ) lda_ = int ( lda , blas_int ) ! Allocate memory for 'ipiv_' and copy 'ipiv' to it allocate ( ipiv_ ( min ( m_ , n_ ))) ipiv_ = int ( ipiv , blas_int ) ! Call LAPACK routine dgetrf to perform LU factorization call dgetrf ( m_ , n_ , a , lda_ , ipiv_ , info_ ) ! Assign the output info_ to the info argument info = info_ ! Free allocated memory end subroutine oqp_dgetrf_i64 !MHR END !---------------------------------------------------------------------- subroutine oqp_dsysv_i64 ( uplo , n , nrhs , a , lda , ipiv , b , ldb , work , lwork , info ) character ( * ) :: uplo integer :: info , lda , ldb , lwork , n , nrhs integer :: ipiv ( * ) real ( dp ) :: a ( * ), b ( * ), work ( * ) integer ( blas_int ) :: info_ , lda_ , ldb_ , lwork_ , n_ , nrhs_ integer ( blas_int ), allocatable :: ipiv_ (:) logical :: ok if ( ARG_CHECK ) then ok = . true . ok = ok . and . ( lda <= HUGE_BLAS_INT ) ok = ok . and . ( ldb <= HUGE_BLAS_INT ) ok = ok . and . ( lwork <= HUGE_BLAS_INT ) ok = ok . and . ( n <= HUGE_BLAS_INT ) ok = ok . and . ( nrhs <= HUGE_BLAS_INT ) if (. not . ok ) call show_message ( ERRMSG , WITH_ABORT ) end if lda_ = int ( lda , blas_int ) ldb_ = int ( ldb , blas_int ) lwork_ = int ( lwork , blas_int ) n_ = int ( n , blas_int ) nrhs_ = int ( nrhs , blas_int ) if ( lwork_ /= - 1 ) allocate ( ipiv_ ( n_ )) call dsysv ( uplo , n_ , nrhs_ , a , lda_ , ipiv_ , b , ldb_ , work , lwork_ , info_ ) info = info_ if ( lwork_ /= - 1 ) ipiv (: n_ ) = ipiv_ (: n_ ) end subroutine !---------------------------------------------------------------------- subroutine oqp_dgglse_i64 ( m , n , p , a , lda , b , ldb , c , d , x , work , lwork , info ) integer :: info , lda , ldb , lwork , m , n , p real ( dp ) :: a ( lda , * ), b ( ldb , * ), c ( * ), d ( * ), work ( * ), x ( * ) integer ( blas_int ) :: info_ , lda_ , ldb_ , lwork_ , m_ , n_ , p_ logical :: ok if ( ARG_CHECK ) then ok = . true . ok = ok . and . ( info <= HUGE_BLAS_INT ) ok = ok . and . ( lda <= HUGE_BLAS_INT ) ok = ok . and . ( ldb <= HUGE_BLAS_INT ) ok = ok . and . ( lwork <= HUGE_BLAS_INT ) ok = ok . and . ( m <= HUGE_BLAS_INT ) ok = ok . and . ( n <= HUGE_BLAS_INT ) ok = ok . and . ( p <= HUGE_BLAS_INT ) if (. not . ok ) call show_message ( ERRMSG , WITH_ABORT ) end if lda_ = int ( lda , blas_int ) ldb_ = int ( ldb , blas_int ) lwork_ = int ( lwork , blas_int ) m_ = int ( m , blas_int ) n_ = int ( n , blas_int ) p_ = int ( p , blas_int ) call dgglse ( m_ , n_ , p_ , a , lda_ , b , ldb_ , c , d , x , work , lwork_ , info_ ) info = info_ end subroutine !---------------------------------------------------------------------- subroutine oqp_dorgqr_i64 ( m , n , k , a , lda , tau , work , lwork , info ) integer :: info , k , lda , lwork , m , n real ( dp ) :: a ( lda , * ), tau ( * ), work ( * ) integer ( blas_int ) :: info_ , k_ , lda_ , lwork_ , m_ , n_ logical :: ok if ( ARG_CHECK ) then ok = . true . ok = ok . and . ( lda <= HUGE_BLAS_INT ) ok = ok . and . ( lwork <= HUGE_BLAS_INT ) ok = ok . and . ( m <= HUGE_BLAS_INT ) ok = ok . and . ( n <= HUGE_BLAS_INT ) ok = ok . and . ( k <= HUGE_BLAS_INT ) if (. not . ok ) call show_message ( ERRMSG , WITH_ABORT ) end if lda_ = int ( lda , blas_int ) lwork_ = int ( lwork , blas_int ) m_ = int ( m , blas_int ) n_ = int ( n , blas_int ) k_ = int ( k , blas_int ) call dorgqr ( m_ , n_ , k_ , a , lda_ , tau , work , lwork_ , info_ ) info = info_ end subroutine !---------------------------------------------------------------------- subroutine oqp_dormqr_i64 ( side , trans , m , n , k , a , lda , tau , c , ldc , work , lwork , info ) character ( * ) :: side , trans integer :: info , k , lda , ldc , lwork , m , n real ( dp ) :: a ( lda , * ), c ( ldc , * ), tau ( * ), work ( * ) integer ( blas_int ) :: info_ , k_ , lda_ , ldc_ , lwork_ , m_ , n_ logical :: ok if ( ARG_CHECK ) then ok = . true . ok = ok . and . ( lda <= HUGE_BLAS_INT ) ok = ok . and . ( ldc <= HUGE_BLAS_INT ) ok = ok . and . ( lwork <= HUGE_BLAS_INT ) ok = ok . and . ( m <= HUGE_BLAS_INT ) ok = ok . and . ( n <= HUGE_BLAS_INT ) ok = ok . and . ( k <= HUGE_BLAS_INT ) if (. not . ok ) call show_message ( ERRMSG , WITH_ABORT ) end if lda_ = int ( lda , blas_int ) ldc_ = int ( ldc , blas_int ) lwork_ = int ( lwork , blas_int ) m_ = int ( m , blas_int ) n_ = int ( n , blas_int ) k_ = int ( k , blas_int ) call dormqr ( side , trans , m_ , n_ , k_ , a , lda_ , tau , c , ldc_ , work , lwork_ , info_ ) info = info_ end subroutine !---------------------------------------------------------------------- subroutine oqp_dtpttr_i64 ( uplo , n , ap , a , lda , info ) character ( len =* ) :: uplo integer :: info , n , lda real ( dp ) :: a ( lda , * ), ap ( * ) integer ( blas_int ) :: info_ , n_ , lda_ logical :: ok if ( ARG_CHECK ) then ok = . true . ok = ok . and . ( n <= HUGE_BLAS_INT ) ok = ok . and . ( lda <= HUGE_BLAS_INT ) if (. not . ok ) call show_message ( ERRMSG , WITH_ABORT ) end if n_ = int ( n , blas_int ) lda_ = int ( lda , blas_int ) call dtpttr ( uplo , n_ , ap , a , lda_ , info_ ) info = info_ end subroutine !---------------------------------------------------------------------- subroutine oqp_dtrttp_i64 ( uplo , n , a , lda , ap , info ) character ( len =* ) :: uplo integer :: info , n , lda real ( dp ) :: a ( lda , * ), ap ( * ) integer ( blas_int ) :: info_ , n_ , lda_ logical :: ok if ( ARG_CHECK ) then ok = . true . ok = ok . and . ( n <= HUGE_BLAS_INT ) ok = ok . and . ( lda <= HUGE_BLAS_INT ) if (. not . ok ) call show_message ( ERRMSG , WITH_ABORT ) end if n_ = int ( n , blas_int ) lda_ = int ( lda , blas_int ) call dtrttp ( uplo , n_ , a , lda_ , ap , info_ ) info = info_ end subroutine !---------------------------------------------------------------------- end module","tags":"","url":"sourcefile/lapack_wrap.f90.html"},{"title":"int_rotaxis_pure.F90 – OpenQP Fortran API","text":"Source Code !> @brief Direct pure-spherical output for the Ishimura rotated-axis ERI engine. !> !> @details The Cartesian path (genr22) rotates the rotated-frame block to !>   the lab frame index-by-index (r30s1d) and, for harmonic-flagged shells, !>   projects 6d Cartesian components to 5d pure components in a second pass !>   (genr22_reduce_pure). Both steps are linear maps acting on one shell !>   index at a time, so they are fused here: each index is transformed once !>   by T = C * R&#94;T, where R is the per-shell rotated->lab rotation in the !>   engine's component convention and C the Cartesian->pure projection. !>   Pure 5d blocks are written directly; the 6d lab-frame Cartesian block !>   is never materialized, and s-shell (identity) indices are skipped. !> !>   Component conventions (must match r30s1d_NN and the projection tables): !>   d order xx,yy,zz,xy,xz,yz; rotated-frame cross components carry no !>   sqrt(3) normalization while lab cross components do - the sqrt(3) is !>   folded into the rotation, exactly as in r30s1d_07. submodule ( int2e_rotaxis ) int2e_rotaxis_pure ! Sparse pure-d projection C(out, cart) for unit-normalized Cartesians, ! cart order xx,yy,zz,xy,xz,yz, pure order m = -2..+2. The values must ! stay identical to int2_pure_generated::load_l2 (asserted by ! tests/test_ispher_rotaxis_direct_pure.py). integer , parameter :: CD_NTERM ( 6 ) = [ 2 , 2 , 1 , 1 , 1 , 1 ] integer , parameter :: CD_OUT ( 2 , 6 ) = reshape ([ 3 , 5 , 3 , 5 , 3 , 0 , 1 , 0 , 4 , 0 , 2 , 0 ], [ 2 , 6 ]) real ( dp ), parameter :: CD_COEF ( 2 , 6 ) = reshape ([ & - 4.999999999999999e-01_dp , 8.660254037844386e-01_dp , & - 4.999999999999999e-01_dp , - 8.660254037844386e-01_dp , & 9.999999999999999e-01_dp , 0.0_dp , & 1.000000000000000e+00_dp , 0.0_dp , & 1.000000000000000e+00_dp , 0.0_dp , & 1.000000000000000e+00_dp , 0.0_dp ], [ 2 , 6 ]) contains module subroutine genr22_pure ( basis , ppairs , grotspd , shell_ids , flips , cutoffs , nbf , emu2 ) use constants , only : NUM_CART_BF implicit none type ( basis_set ), intent ( in ) :: basis type ( int2_pair_storage ), intent ( in ) :: ppairs real ( kind = dp ), intent ( inout ) :: grotspd ( * ) integer , intent ( in ) :: shell_ids ( 4 ) integer , intent ( out ) :: flips ( 4 ) type ( int2_cutoffs_t ), intent ( in ) :: cutoffs integer , intent ( out ) :: nbf ( 4 ) real ( kind = dp ), optional :: emu2 real ( kind = dp ) :: prot ( 3 , 3 ) real ( kind = dp ) :: t ( 6 , 6 , 4 ) integer :: jtype integer :: ids ( 4 ), am ( 4 ), nin ( 4 ) integer :: s call genr22_core ( basis , ppairs , grotspd , shell_ids , flips , cutoffs , prot , jtype , emu2 ) ids = shell_ids ( flips ) am = basis % am ( ids ) do s = 1 , 4 nin ( s ) = NUM_CART_BF ( am ( s )) call build_pure_rotation ( am ( s ), basis % harmonic ( ids ( s )), prot , t (:,:, s ), nbf ( s )) end do call apply_index_transforms ( grotspd , am , nin , nbf , t ) end subroutine genr22_pure !> Build the fused rotated->lab(->pure) transform for one shell index. !> tmat(o,nu): coefficient of rotated-frame component nu in output !> component o. For l=1 this is the plain rotation (r30s1d_02); for l=2 !> it is the d rotation of r30s1d_07 composed with the constant pure !> projection (or the rotation alone for Cartesian-flagged shells). !> l=0 indices are identity and skipped by the caller. subroutine build_pure_rotation ( l , pure , prot , tmat , nout ) implicit none integer , intent ( in ) :: l , pure real ( kind = dp ), intent ( in ) :: prot ( 3 , 3 ) real ( kind = dp ), intent ( out ) :: tmat ( 6 , 6 ) integer , intent ( out ) :: nout real ( kind = dp ) :: q ( 6 , 6 ) integer :: c , k , nu select case ( l ) case ( 0 ) nout = 1 case ( 1 ) ! f_lab(i) = sum_nu f_rot(nu) * prot(nu,i), as in r30s1d_02 nout = 3 do nu = 1 , 3 tmat ( 1 : 3 , nu ) = prot ( nu , 1 : 3 ) end do case ( 2 ) ! q(nu,i): rotated d component nu -> lab d component i (r30s1d_07) q ( 1 , 1 : 3 ) = prot ( 1 , 1 : 3 ) * prot ( 1 , 1 : 3 ) q ( 2 , 1 : 3 ) = prot ( 2 , 1 : 3 ) * prot ( 2 , 1 : 3 ) q ( 3 , 1 : 3 ) = prot ( 3 , 1 : 3 ) * prot ( 3 , 1 : 3 ) q ( 4 , 1 : 3 ) = prot ( 1 , 1 : 3 ) * prot ( 2 , 1 : 3 ) * 2.0_dp q ( 5 , 1 : 3 ) = prot ( 1 , 1 : 3 ) * prot ( 3 , 1 : 3 ) * 2.0_dp q ( 6 , 1 : 3 ) = prot ( 2 , 1 : 3 ) * prot ( 3 , 1 : 3 ) * 2.0_dp q ( 1 , 4 : 5 ) = sqrt3 * ( prot ( 1 , 1 ) * prot ( 1 , 2 : 3 )) q ( 2 , 4 : 5 ) = sqrt3 * ( prot ( 2 , 1 ) * prot ( 2 , 2 : 3 )) q ( 3 , 4 : 5 ) = sqrt3 * ( prot ( 3 , 1 ) * prot ( 3 , 2 : 3 )) q ( 4 , 4 : 5 ) = sqrt3 * ( prot ( 1 , 1 ) * prot ( 2 , 2 : 3 ) + prot ( 2 , 1 ) * prot ( 1 , 2 : 3 )) q ( 5 , 4 : 5 ) = sqrt3 * ( prot ( 1 , 1 ) * prot ( 3 , 2 : 3 ) + prot ( 3 , 1 ) * prot ( 1 , 2 : 3 )) q ( 6 , 4 : 5 ) = sqrt3 * ( prot ( 2 , 1 ) * prot ( 3 , 2 : 3 ) + prot ( 3 , 1 ) * prot ( 2 , 2 : 3 )) q ( 1 , 6 ) = sqrt3 * ( prot ( 1 , 2 ) * prot ( 1 , 3 )) q ( 2 , 6 ) = sqrt3 * ( prot ( 2 , 2 ) * prot ( 2 , 3 )) q ( 3 , 6 ) = sqrt3 * ( prot ( 3 , 2 ) * prot ( 3 , 3 )) q ( 4 , 6 ) = sqrt3 * ( prot ( 1 , 2 ) * prot ( 2 , 3 ) + prot ( 2 , 2 ) * prot ( 1 , 3 )) q ( 5 , 6 ) = sqrt3 * ( prot ( 1 , 2 ) * prot ( 3 , 3 ) + prot ( 3 , 2 ) * prot ( 1 , 3 )) q ( 6 , 6 ) = sqrt3 * ( prot ( 2 , 2 ) * prot ( 3 , 3 ) + prot ( 3 , 2 ) * prot ( 2 , 3 )) if ( pure == 1 ) then ! tmat = C * Q&#94;T from the constant sparse d projection nout = 5 tmat ( 1 : 5 , 1 : 6 ) = 0.0_dp do c = 1 , 6 do k = 1 , CD_NTERM ( c ) tmat ( CD_OUT ( k , c ), 1 : 6 ) = tmat ( CD_OUT ( k , c ), 1 : 6 ) + CD_COEF ( k , c ) * q ( 1 : 6 , c ) end do end do else nout = 6 do c = 1 , 6 tmat ( c , 1 : 6 ) = q ( 1 : 6 , c ) end do end if case default error stop 'genr22_pure: rotated-axis engine supports l <= 2 only' end select end subroutine build_pure_rotation !> Apply the per-index transforms to the quartet block. Storage order is !> B(n4,n3,n2,n1): storage dimension k holds canonical shell slot 5-k. !> Sequential one-index contractions; l=0 (identity) indices are skipped, !> the first active stage reads from f and the last writes back to f, so !> no boundary copies are made unless only one index is active. subroutine apply_index_transforms ( f , am , nin , nout , t ) implicit none real ( kind = dp ), intent ( inout ) :: f ( * ) integer , intent ( in ) :: am ( 4 ), nin ( 4 ), nout ( 4 ) real ( kind = dp ), intent ( in ) :: t ( 6 , 6 , 4 ) real ( kind = dp ) :: work ( 1296 , 2 ) integer :: dims ( 4 ) integer :: k , pos , j , ntot integer :: nleft , nright integer :: src_id , dst_id , last_k dims = nin ([ 4 , 3 , 2 , 1 ]) last_k = 0 do k = 1 , 4 if ( am ( 5 - k ) > 0 ) last_k = k end do if ( last_k == 0 ) return src_id = 0 ! 0 = f, 1/2 = work columns do k = 1 , 4 pos = 5 - k if ( am ( pos ) == 0 ) cycle ! identity index nleft = 1 do j = 1 , k - 1 nleft = nleft * dims ( j ) end do nright = 1 do j = k + 1 , 4 nright = nright * dims ( j ) end do if ( k == last_k . and . src_id /= 0 ) then dst_id = 0 else dst_id = merge ( 2 , 1 , src_id == 1 ) end if if ( src_id == 0 ) then call transform_one_dim ( f , work (:, dst_id ), nleft , nin ( pos ), nout ( pos ), nright , t (:,:, pos )) else if ( dst_id == 0 ) then call transform_one_dim ( work (:, src_id ), f , nleft , nin ( pos ), nout ( pos ), nright , t (:,:, pos )) else call transform_one_dim ( work (:, src_id ), work (:, dst_id ), nleft , nin ( pos ), nout ( pos ), nright , t (:,:, pos )) end if dims ( k ) = nout ( pos ) src_id = dst_id end do if ( src_id /= 0 ) then ! single active index: copy back ntot = product ( dims ) f ( 1 : ntot ) = work ( 1 : ntot , src_id ) end if end subroutine apply_index_transforms !> dst(:,o,b) = sum_i tmat(o,i) * src(:,i,b) subroutine transform_one_dim ( src , dst , nleft , ni , no , nright , tmat ) implicit none integer , intent ( in ) :: nleft , ni , no , nright real ( kind = dp ), intent ( in ) :: src ( nleft , ni , nright ) real ( kind = dp ), intent ( out ) :: dst ( nleft , no , nright ) real ( kind = dp ), intent ( in ) :: tmat ( 6 , 6 ) integer :: b , o , i do b = 1 , nright do o = 1 , no dst (:, o , b ) = tmat ( o , 1 ) * src (:, 1 , b ) do i = 2 , ni dst (:, o , b ) = dst (:, o , b ) + tmat ( o , i ) * src (:, i , b ) end do end do end do end subroutine transform_one_dim end submodule int2e_rotaxis_pure","tags":"","url":"sourcefile/int_rotaxis_pure.f90.html"},{"title":"dft.F90 – OpenQP Fortran API","text":"Source Code module dft ! A Module for grid based DFT use messages , only : show_message , WITH_ABORT use precision , only : dp use io_constants , only : iw use basis_tools , only : basis_set use mod_dft_molgrid , only : dft_grid_t implicit none character ( len =* ), parameter :: module_name = \"dft\" private public dft_initialize public dft_build_grid_sized public dft_setup_descent_grid public xc_is_grid_sensitive public dftclean public dftexcor public dftder !> @brief Pruned-grid specification !> @details A pruned grid is defined per atom type by up to `ngrids` !>   radial regions: region i of type t covers radii (in units of the !>   atomic radius) up to `radii(i,t)` and uses a `nang(i,t)`-point !>   Lebedev sphere.  `rad_id` maps each atom to its type. !>   Alternatively (SG-2/SG-3), regions are given as counts of !>   consecutive radial shells: when `nradPerRegion(i,t) > 0`, region i !>   of type t spans the next `nradPerRegion(i,t)` shells of the radial !>   grid and `radii` is ignored for that type (regions with a zero !>   count are unused). !>   Several radial grids may coexist: `radial_id` maps each atom to !>   one of `nrad_types` radial grids.  Radial type 1 is always the !>   standard unit-radius grid (scaled by the Bragg-Slater radius); !>   types >= 2 are element-specific grids in absolute bohr: DE2 !>   (`de2_alpha`/`de2_rmax` give alpha and the outermost node) or, !>   when `me_rscale` is allocated and positive, MultiExp with !>   `rad_npts` nodes and scaling radius `me_rscale` (SG-0). !>   If `nang_override` is allocated and non-zero for an atom type, !>   that type is unpruned: a single `nang_override(t)`-point Lebedev !>   sphere is used at ALL radii (heavy-atom fallback). type dft_grid_pruned_t integer :: nrad = 0 integer :: ngrids = 1 integer , allocatable :: nang (:,:) !< (region, atom type) real ( kind = dp ), allocatable :: radii (:,:) !< (region, atom type) integer , allocatable :: rad_id (:) !< atom -> atom type integer , allocatable :: nradPerRegion (:,:) !< (region, atom type); 0 = unused !> Per-atom-type angular override: if non-zero, the atom type is !> unpruned and uses this single Lebedev sphere at ALL radii !> (0 = no override, use the regular pruning regions) integer , allocatable :: nang_override (:) !< per atom type; 0 = no override integer :: nrad_types = 1 !< number of radial grids integer , allocatable :: radial_id (:) !< atom -> radial grid type real ( kind = dp ), allocatable :: de2_alpha (:) !< DE2 alpha of radial type real ( kind = dp ), allocatable :: de2_rmax (:) !< DE2 outermost node, bohr integer , allocatable :: rad_npts (:) !< nodes of radial type (0: global nrad) real ( kind = dp ), allocatable :: me_rscale (:) !< MultiExp R of radial type (0: DE2) end type !  SG1 region boundaries (in units of the atomic radius) and Lebedev !  orders, from P.M.W. Gill, B.G. Johnson, J.A. Pople, !  Chem. Phys. Lett. 209 (1993) 506: rows are H-He, Li-Ne, Na-Ar. !  SG1 is only defined up to Ar; heavier atoms (row 4) fall back to !  the unpruned 194-point grid at all radii.  Row 4 is fully !  overridden via nang_override (set in dft_set_options), so its !  boundaries are never used. real ( kind = dp ), parameter :: sg1rads ( 5 , 4 ) = reshape (& [ 0.2500d0 , 0.500d0 , 1.0d00 , 4.50d0 , 999999 9.9d0 , & 0.1667d0 , 0.500d0 , 0.90d0 , 3.50d0 , 999999 9.9d0 , & 0.1000d0 , 0.400d0 , 0.80d0 , 2.5d0 , 999999 9.9d0 , & 999999 9.9d0 , 999999 9.9d0 , 999999 9.9d0 , 999999 9.9d0 , 999999 9.9d0 ], & shape ( sg1rads )) integer , parameter :: sg1atoms ( 4 ) = [ 2 , 10 , 18 , 137 ] integer , parameter :: sg1grids ( 5 ) = [ 6 , 38 , 86 , 194 , 86 ] !  SG-2 / SG-3 pruned grids: S. Dasgupta, J.M. Herbert, !  J. Comput. Chem. 38, 869 (2017).  Radial grid: Mitani !  double-exponential (DE2), M. Mitani, Theor. Chem. Acc. 130, !  645 (2011), with element-specific alpha and Nr = 75 (SG-2) or !  Nr = 99 (SG-3).  The first/last radial nodes are pinned to !  r = 1e-7 bohr and the element-specific R_max below (values from !  NVIDIA cuEST's SG-2/SG-3 implementation, CUDALibrarySamples, !  cuest_molecular_grid.py; R_max is 10x the EML scaling radius). !  The pruning sectors are counts of consecutive radial shells !  (ascending radius), each integrated on the given Lebedev sphere. !  Defined for Z in {1, 3-9, 11-17}; other elements fall back to the !  unpruned 302/590-point grid on the standard radial grid. integer , parameter :: SG_NELEM = 15 integer , parameter :: sg_elem_z ( SG_NELEM ) = & [ 1 , 3 , 4 , 5 , 6 , 7 , 8 , 9 , 11 , 12 , 13 , 14 , 15 , 16 , 17 ] real ( kind = dp ), parameter :: SG_DE2_RMIN = 1.0d-7 real ( kind = dp ), parameter :: sg_de2_rmax ( SG_NELEM ) = & [ 1 5.0d0 , 3 8.7d0 , 2 6.5d0 , 2 2.0d0 , 1 7.1d0 , 1 4.1d0 , 1 2.3d0 , & 1 0.8d0 , 4 2.1d0 , 3 2.5d0 , 3 4.3d0 , 2 7.5d0 , 2 3.2d0 , 2 0.6d0 , & 1 8.4d0 ] integer , parameter :: SG2_NRAD = 75 integer , parameter :: SG2_MAXSEC = 5 real ( kind = dp ), parameter :: sg2_alpha ( SG_NELEM ) = & [ 2.6d0 , 3.2d0 , 2.4d0 , 2.4d0 , 2.2d0 , 2.2d0 , 2.2d0 , 2.2d0 , & 3.2d0 , 2.4d0 , 2.5d0 , 2.3d0 , 2.5d0 , 2.5d0 , 2.5d0 ] !  number of radial shells per sector integer , parameter :: sg2_cnt ( SG2_MAXSEC , SG_NELEM ) = reshape ([ & 35 , 12 , 16 , 7 , 5 , & ! H 35 , 12 , 17 , 7 , 4 , & ! Li 35 , 12 , 17 , 7 , 4 , & ! Be 35 , 12 , 17 , 7 , 4 , & ! B 35 , 12 , 17 , 7 , 4 , & ! C 35 , 12 , 17 , 7 , 4 , & ! N 30 , 14 , 18 , 8 , 5 , & ! O 26 , 16 , 19 , 8 , 6 , & ! F 35 , 12 , 17 , 7 , 4 , & ! Na 35 , 12 , 17 , 7 , 4 , & ! Mg 32 , 15 , 17 , 7 , 4 , & ! Al 32 , 15 , 17 , 7 , 4 , & ! Si 30 , 14 , 17 , 7 , 7 , & ! P 30 , 14 , 17 , 7 , 7 , & ! S 26 , 16 , 19 , 8 , 6 ], & ! Cl shape ( sg2_cnt )) !  Lebedev order of each sector integer , parameter :: sg2_leb ( SG2_MAXSEC , SG_NELEM ) = reshape ([ & 6 , 110 , 302 , 86 , 26 , & ! H 6 , 110 , 302 , 86 , 50 , & ! Li 6 , 110 , 302 , 86 , 50 , & ! Be 6 , 110 , 302 , 146 , 26 , & ! B 6 , 110 , 302 , 146 , 26 , & ! C 6 , 110 , 302 , 86 , 26 , & ! N 6 , 110 , 302 , 146 , 50 , & ! O 6 , 110 , 302 , 110 , 50 , & ! F 6 , 110 , 302 , 86 , 50 , & ! Na 6 , 110 , 302 , 86 , 50 , & ! Mg 6 , 110 , 302 , 146 , 86 , & ! Al 6 , 110 , 302 , 146 , 50 , & ! Si 6 , 110 , 302 , 146 , 38 , & ! P 6 , 110 , 302 , 146 , 38 , & ! S 6 , 110 , 302 , 110 , 50 ], & ! Cl shape ( sg2_leb )) integer , parameter :: SG3_NRAD = 99 integer , parameter :: SG3_MAXSEC = 9 real ( kind = dp ), parameter :: sg3_alpha ( SG_NELEM ) = & [ 2.7d0 , 3.0d0 , 2.4d0 , 2.4d0 , 2.4d0 , 2.4d0 , 2.6d0 , 2.1d0 , & 3.2d0 , 2.6d0 , 2.6d0 , 2.8d0 , 2.4d0 , 2.4d0 , 2.6d0 ] integer , parameter :: sg3_nsec ( SG_NELEM ) = & [ 5 , 5 , 7 , 6 , 7 , 5 , 9 , 7 , 5 , 5 , 7 , 6 , 8 , 8 , 7 ] integer , parameter :: sg3_cnt ( SG3_MAXSEC , SG_NELEM ) = reshape ([ & 45 , 16 , 21 , 10 , 7 , 0 , 0 , 0 , 0 , & ! H 46 , 16 , 22 , 9 , 6 , 0 , 0 , 0 , 0 , & ! Li 42 , 6 , 14 , 22 , 3 , 6 , 6 , 0 , 0 , & ! Be 42 , 6 , 14 , 22 , 9 , 6 , 0 , 0 , 0 , & ! B 46 , 16 , 22 , 1 , 2 , 6 , 6 , 0 , 0 , & ! C 40 , 18 , 24 , 11 , 6 , 0 , 0 , 0 , 0 , & ! N 40 , 14 , 2 , 2 , 24 , 1 , 1 , 8 , 7 , & ! O 35 , 17 , 4 , 25 , 2 , 8 , 8 , 0 , 0 , & ! F 46 , 16 , 22 , 9 , 6 , 0 , 0 , 0 , 0 , & ! Na 48 , 15 , 20 , 7 , 9 , 0 , 0 , 0 , 0 , & ! Mg 42 , 6 , 14 , 22 , 3 , 6 , 6 , 0 , 0 , & ! Al 42 , 6 , 14 , 22 , 9 , 6 , 0 , 0 , 0 , & ! Si 35 , 1 , 18 , 4 , 25 , 2 , 8 , 6 , 0 , & ! P 35 , 1 , 18 , 4 , 25 , 2 , 8 , 6 , 0 , & ! S 35 , 17 , 4 , 25 , 2 , 8 , 8 , 0 , 0 ], & ! Cl shape ( sg3_cnt )) integer , parameter :: sg3_leb ( SG3_MAXSEC , SG_NELEM ) = reshape ([ & 6 , 110 , 590 , 194 , 50 , 0 , 0 , 0 , 0 , & ! H 6 , 110 , 590 , 146 , 50 , 0 , 0 , 0 , 0 , & ! Li 6 , 86 , 110 , 590 , 194 , 146 , 50 , 0 , 0 , & ! Be 6 , 86 , 110 , 590 , 194 , 50 , 0 , 0 , 0 , & ! B 6 , 146 , 590 , 302 , 194 , 146 , 86 , 0 , 0 , & ! C 6 , 110 , 590 , 146 , 50 , 0 , 0 , 0 , 0 , & ! N 6 , 110 , 194 , 302 , 590 , 302 , 194 , 146 , 50 , & ! O 6 , 110 , 194 , 590 , 194 , 110 , 50 , 0 , 0 , & ! F 6 , 110 , 590 , 146 , 50 , 0 , 0 , 0 , 0 , & ! Na 6 , 110 , 590 , 146 , 50 , 0 , 0 , 0 , 0 , & ! Mg 6 , 86 , 110 , 590 , 194 , 146 , 50 , 0 , 0 , & ! Al 6 , 86 , 110 , 590 , 194 , 50 , 0 , 0 , 0 , & ! Si 6 , 86 , 110 , 194 , 590 , 194 , 146 , 50 , 0 , & ! P 6 , 86 , 110 , 194 , 590 , 194 , 146 , 50 , 0 , & ! S 6 , 110 , 194 , 590 , 194 , 110 , 50 , 0 , 0 ], & ! Cl shape ( sg3_leb )) !  SG-0 pruned grid: S.-H. Chien, P.M.W. Gill, J. Comput. Chem. 27, !  730 (2006), Table 1 (counts/orders as listed in Psi4's !  cubature.cc), applied in ASCENDING radial order like the !  SG-2/SG-3 sectors (validated here: H2O/NH3/CH4/thymine BHHLYP !  energies agree with dense grids to ~1e-4, while the reversed !  order fails by up to 1e-2).  Radial grid: MultiExp (Gauss !  quadrature on (0,1) for the weight ln&#94;2 x; P.M.W. Gill, S.-H. !  Chien, J. Comput. Chem. 24, 732 (2003)) with Nr = 23 (Z = 1, !  3-9) or 26 (Z = 11-17) and an element-specific scaling radius R: !  r_i = -R ln(x_i), w_i = R&#94;3 omega_i / x_i (incl. r&#94;2 Jacobian). !  Two spherical-rule substitutions are applied: the original !  18-point rule (Abramowitz & Stegun, not a Lebedev grid) is not !  available here and the 74-point Lebedev rule carries a negative !  weight, which the weight-screening machinery here (positive !  cutoffs in getSliceNonZero etc.) cannot represent; both are !  replaced by the next safe Lebedev order, 26 and 86 respectively. !  Defined for Z in {1, 3-9, 11-17}; other elements (He, Ne, !  Z >= 18) fall back to the SG1 scheme on the standard radial grid. integer , parameter :: SG0_MAXSEC = 15 integer , parameter :: sg0_nrad ( SG_NELEM ) = & [ 23 , 23 , 23 , 23 , 23 , 23 , 23 , 23 , 26 , 26 , 26 , 26 , 26 , 26 , 26 ] real ( kind = dp ), parameter :: sg0_rscale ( SG_NELEM ) = & [ 1.30d0 , 1.95d0 , 2.20d0 , 1.45d0 , 1.20d0 , 1.10d0 , 1.10d0 , & 1.20d0 , 2.30d0 , 2.20d0 , 2.10d0 , 1.30d0 , 1.30d0 , 1.10d0 , & 1.45d0 ] integer , parameter :: sg0_nsec ( SG_NELEM ) = & [ 11 , 11 , 12 , 7 , 13 , 10 , 11 , 10 , 8 , 13 , 15 , 11 , 11 , 12 , 12 ] integer , parameter :: sg0_cnt ( SG0_MAXSEC , SG_NELEM ) = reshape ([ & 6 , 3 , 1 , 1 , 1 , 1 , 6 , 1 , 1 , 1 , 1 , 0 , 0 , 0 , 0 , & ! H 6 , 3 , 1 , 1 , 1 , 1 , 6 , 1 , 1 , 1 , 1 , 0 , 0 , 0 , 0 , & ! Li 4 , 2 , 1 , 2 , 1 , 1 , 2 , 5 , 1 , 1 , 1 , 2 , 0 , 0 , 0 , & ! Be 4 , 4 , 3 , 3 , 6 , 1 , 2 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , & ! B 6 , 2 , 1 , 2 , 2 , 1 , 1 , 1 , 2 , 2 , 1 , 1 , 1 , 0 , 0 , & ! C 6 , 3 , 1 , 2 , 2 , 1 , 2 , 3 , 1 , 2 , 0 , 0 , 0 , 0 , 0 , & ! N 5 , 1 , 2 , 1 , 4 , 1 , 5 , 1 , 1 , 1 , 1 , 0 , 0 , 0 , 0 , & ! O 4 , 2 , 4 , 2 , 2 , 2 , 2 , 3 , 1 , 1 , 0 , 0 , 0 , 0 , 0 , & ! F 6 , 2 , 3 , 1 , 2 , 8 , 2 , 2 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , & ! Na 5 , 2 , 2 , 2 , 2 , 1 , 2 , 4 , 1 , 1 , 2 , 1 , 1 , 0 , 0 , & ! Mg 6 , 2 , 1 , 2 , 2 , 1 , 1 , 2 , 2 , 2 , 1 , 1 , 1 , 1 , 1 , & ! Al 5 , 4 , 4 , 3 , 1 , 2 , 1 , 3 , 1 , 1 , 1 , 0 , 0 , 0 , 0 , & ! Si 5 , 4 , 4 , 3 , 1 , 2 , 1 , 3 , 1 , 1 , 1 , 0 , 0 , 0 , 0 , & ! P 4 , 1 , 8 , 2 , 1 , 2 , 1 , 3 , 1 , 1 , 1 , 1 , 0 , 0 , 0 , & ! S 4 , 7 , 2 , 2 , 1 , 1 , 2 , 3 , 1 , 1 , 1 , 1 , 0 , 0 , 0 ], & ! Cl shape ( sg0_cnt )) !  Lebedev order of each sector (18 -> 26 and 74 -> 86 substitutions !  applied, see above) integer , parameter :: sg0_leb ( SG0_MAXSEC , SG_NELEM ) = reshape ([ & 6 , 26 , 26 , 38 , 86 , 110 , 146 , 86 , 50 , 38 , 26 , 0 , 0 , 0 , 0 , & ! H 6 , 26 , 26 , 38 , 86 , 110 , 146 , 86 , 50 , 38 , 26 , 0 , 0 , 0 , 0 , & ! Li 6 , 26 , 26 , 38 , 86 , 86 , 110 , 146 , 50 , 38 , 26 , 6 , 0 , 0 , 0 , & ! Be 6 , 26 , 38 , 86 , 146 , 38 , 6 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , & ! B 6 , 26 , 26 , 38 , 50 , 86 , 110 , 146 , 170 , 146 , 86 , 38 , 26 , 0 , 0 , & ! C 6 , 26 , 26 , 38 , 86 , 110 , 170 , 146 , 86 , 50 , 0 , 0 , 0 , 0 , 0 , & ! N 6 , 26 , 26 , 38 , 50 , 86 , 110 , 86 , 50 , 38 , 6 , 0 , 0 , 0 , 0 , & ! O 6 , 38 , 50 , 86 , 110 , 146 , 110 , 86 , 50 , 6 , 0 , 0 , 0 , 0 , 0 , & ! F 6 , 26 , 26 , 38 , 50 , 110 , 86 , 6 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , & ! Na 6 , 26 , 26 , 38 , 50 , 86 , 110 , 146 , 110 , 86 , 38 , 26 , 6 , 0 , 0 , & ! Mg 6 , 26 , 26 , 38 , 50 , 86 , 86 , 146 , 170 , 110 , 86 , 86 , 26 , 26 , 6 , & ! Al 6 , 26 , 38 , 50 , 86 , 110 , 146 , 170 , 86 , 50 , 6 , 0 , 0 , 0 , 0 , & ! Si 6 , 26 , 38 , 50 , 86 , 110 , 146 , 170 , 86 , 50 , 6 , 0 , 0 , 0 , 0 , & ! P 6 , 26 , 26 , 38 , 50 , 86 , 110 , 170 , 146 , 110 , 50 , 6 , 0 , 0 , 0 , & ! S 6 , 26 , 26 , 38 , 50 , 86 , 110 , 170 , 146 , 110 , 86 , 6 , 0 , 0 , 0 ], & ! Cl shape ( sg0_leb )) !  Gauss nodes/weights on (0,1) for the weight ln&#94;2 x (moments !  m_k = 2/(k+1)&#94;3), used by the SG-0 MultiExp radial grid.  Generated !  at 200-digit precision via Golub-Welsch (scripts/ !  sg0_multiexp_nodes.py); moments reproduced to ~1e-194.  Sorted by !  ascending radius r = -ln x (descending x). real ( kind = dp ), parameter :: me23_x ( 23 ) = [ & 0.98868121412417917d0 , 0.96979055758591744d0 , 0.94296495577173701d0 , & 0.90865042304171716d0 , 0.86743287798275914d0 , 0.82001826057974256d0 , & 0.76721868628476330d0 , 0.70993783394310550d0 , 0.64915496391179920d0 , & 0.58590767062942112d0 , 0.52127362052638902d0 , 0.45635157223202704d0 , & 0.39224199352412352d0 , 0.33002759271630692d0 , 0.27075407329850232d0 , & 0.21541139722601381d0 , 0.16491579716600480d0 , 0.12009269427713703d0 , & 0.081660512821455929d0 , 0.050215014094683999d0 , 0.026212787562513862d0 , & 0.0099491128468611853d0 , 0.0015058924745840717d0 ] real ( kind = dp ), parameter :: me23_w ( 23 ) = [ & 1.9205788879728201d-6 , 2.1565953939261300d-5 , 0.00010572868056731378d0 , & 0.00034755788975770020d0 , 0.00089889253062980984d0 , 0.0019785635068497310d0 , & 0.0038757714610574311d0 , 0.0069477499303844705d0 , 0.011611019656801442d0 , & 0.018325604666401505d0 , 0.027571576765107484d0 , 0.039817159733692048d0 , & 0.055477247414684803d0 , 0.074860364849398577d0 , 0.098100418872550932d0 , & 0.12506617470764026d0 , 0.15523427291530433d0 , 0.18749582392684797d0 , & 0.21982849560935217d0 , 0.24866202472840894d0 , 0.26742812676397013d0 , & 0.26236396365964760d0 , 0.19397997519811811d0 ] real ( kind = dp ), parameter :: me26_x ( 26 ) = [ & 0.99104255389177476d0 , 0.97606029628496512d0 , 0.95471297844715660d0 , & 0.92727872393893840d0 , 0.89412727813918990d0 , 0.85570731112497829d0 , & 0.81253906250257684d0 , 0.76520686385149628d0 , 0.71435096447486728d0 , & 0.66065863649024736d0 , 0.60485464446878273d0 , 0.54769119749545300d0 , & 0.48993751506621983d0 , 0.43236914470191774d0 , 0.37575717144832967d0 , & 0.32085745807052075d0 , 0.26840004931968460d0 , 0.21907886291165968d0 , & 0.17354177117918734d0 , 0.13238114512422221d0 , 0.096124873966380717d0 , & 0.065227756094948038d0 , 0.040062890303615981d0 , 0.020911970701014455d0 , & 0.0079508350834211655d0 , 0.0012118959531442052d0 ] real ( kind = dp ), parameter :: me26_w ( 26 ) = [ & 9.5039183893267110d-7 , 1.0687185195322948d-5 , 5.2504259615681300d-5 , & 0.00017307202304493877d0 , 0.00044916603235275513d0 , 0.00099280471150256854d0 , & 0.0019544295871422983d0 , 0.0035237959667716519d0 , 0.0059282775235989670d0 , & 0.0094283196275203881d0 , 0.014309796296644065d0 , 0.020873023457481862d0 , & 0.029418139625084388d0 , 0.040226455838504916d0 , 0.053537150852983894d0 , & 0.069518256800206744d0 , 0.088230076743000778d0 , 0.10957766175447101d0 , & 0.13324603342450455d0 , 0.15860582735470473d0 , 0.18456387321242483d0 , & 0.20930163443099709d0 , 0.22975862025927898d0 , 0.24044079379163951d0 , & 0.22996905094874790d0 , 0.16590959790074127d0 ] type :: saved_HF_info !< keeps HF exchange from input logical :: alpha = . false . logical :: beta = . false . logical :: mu = . false . logical :: hfscale = . false . logical :: do = . false . real ( kind = dp ) :: saved_alpha = - 1.0_dp real ( kind = dp ) :: saved_beta = - 1.0_dp real ( kind = dp ) :: saved_mu = - 1.0_dp real ( kind = dp ) :: saved_hfscale = - 1.0_dp contains procedure :: save_HF => save_dft_HF_exchange_from_input procedure :: update_HF => update_dft_HF_exchange_from_input end type contains subroutine save_dft_HF_exchange_from_input ( this , infos ) use types , only : information implicit none class ( saved_HF_info ), intent ( inout ) :: this type ( information ), intent ( inout ) :: infos if ( infos % dft % cam_flag ) then if ( infos % dft % cam_alpha /= - 1.0_dp ) then this % saved_alpha = infos % dft % cam_alpha this % alpha = . true . end if if ( infos % dft % cam_beta /= - 1.0_dp ) then this % saved_beta = infos % dft % cam_beta this % beta = . true . end if if ( infos % dft % cam_mu /= - 1.0_dp ) then this % saved_mu = infos % dft % cam_mu this % mu = . true . end if if ( this % alpha . or . this % beta . or . this % mu ) & this % do = . true . else if ( infos % dft % hfscale /= - 1.0_dp ) then this % saved_hfscale = infos % dft % hfscale this % hfscale = . true . this % do = . true . end if end if end subroutine save_dft_HF_exchange_from_input subroutine update_dft_HF_exchange_from_input ( this , infos ) use types , only : information implicit none class ( saved_HF_info ), intent ( inout ) :: this type ( information ), intent ( inout ) :: infos real ( kind = dp ) :: scale character ( len = 80 ), parameter :: format = & '(11x,a,\":\",t22,\"|\", t24, e12.5, t37, \"-|>\", t41, e12.5, t54, \"|\")' if ( infos % dft % cam_flag ) then write ( * , '(2x,a)' ) \"CAM-B3LYP with tuned Hartree-Fock exchange from the input.\" write ( * , '(5x,\"CAM parametres: |   It was     |   It become    |\")' ) if ( this % alpha ) then scale = this % saved_alpha else scale = infos % dft % cam_alpha end if write ( * , fmt = format ) \"Alpha\" , 0.19_dp , scale if ( this % alpha ) infos % dft % cam_alpha = this % saved_alpha if ( this % beta ) then scale = this % saved_beta else scale = infos % dft % cam_beta end if write ( * , fmt = format ) \"Beta\" , 0.46_dp , scale if ( this % beta ) infos % dft % cam_beta = this % saved_beta if ( this % mu ) then scale = this % saved_mu else scale = infos % dft % cam_mu end if write ( * , fmt = format ) \"mu\" , 0.33_dp , scale if ( this % mu ) infos % dft % cam_mu = this % saved_mu else write ( * , '(2x,a)' ) \"Tuned Hartree-Fock exchange from the input.\" write ( * , '(10x,\"Exact HF exchange:\")' ) if ( this % hfscale ) then scale = this % saved_hfscale else scale = infos % dft % hfscale end if write ( * , fmt = format ) \"HF scale\" , infos % dft % hfscale , scale if ( this % hfscale ) infos % dft % hfscale = this % saved_hfscale write ( * , '(2x,a)' ) \"Please cite the following works when using this option:\" write ( * , fmt = '(3a)' ) \"[1] W. Park, A. Lashkaripour, K. Komarov, S. Lee, M. Huix-Rotllant, \" , & \"and C. H. Choi, J. Chem. Theory Comput., ??, ?? (2024); \" , & \"DOI: 10.1021/acs.jctc.4c00640\" write ( * , fmt = '(3a)' ) \"[2] K. Komarov, W. Park, S. Lee, M. Huix-Rotllant, \" , & \"and C. H. Choi, J. Chem. Theory Comput., 19, 7671-7684 (2023); \" , & \"DOI: 10.1021/acs.jctc.3c00884\" end if write ( * , * ) end subroutine update_dft_HF_exchange_from_input subroutine dft_initialize ( infos , basis , molGrid , orbitals_cutoff , verbose , need_functional ) use basis_tools , only : basis_set use types , only : information implicit none type ( basis_set ), intent ( inout ) :: basis type ( information ), intent ( inout ) :: infos type ( dft_grid_t ), intent ( inout ) :: molGrid real ( kind = dp ), optional :: orbitals_cutoff logical , optional :: verbose logical , optional :: need_functional real ( kind = dp ) :: logtol type ( dft_grid_pruned_t ) :: pruned !   Setup sreening parameters logtol = - log ( 1.0e-10_dp ) if ( present ( orbitals_cutoff )) logtol = - log ( orbitals_cutoff ) call basis % set_screening ( logtol ) !   Set grid DFT options call dft_set_options ( infos , pruned , need_functional ) !   Initialize grid call dft_prepare_grid ( infos , basis , molGrid , pruned , verbose ) end subroutine !>  @brief Build a DFT integration grid with an explicit, single (unpruned) !>         radial/angular size, WITHOUT touching the libxc functional setup. !> !>  @detail Used by the coarse-to-fine SCF grid schedule (see scf_driver): early !>          SCF cycles run on this cheaper grid and switch to the production grid !>          as DIIS approaches convergence. Every grid parameter other than the !>          point count (radial grid type, partition function, fuzzy-cell !>          algorithm, density cutoff, Bragg-Slater radii) is inherited from !>          infos%dft, so the coarse grid is consistent with the production grid !>          apart from being sparser. The production grid sizes held in infos%dft !>          are saved and restored, so infos is unchanged on return. !> !>  @param[inout] infos    System/control info (grid sizes restored on exit). !>  @param[in]    basis    Basis set (screening already set by dft_initialize). !>  @param[inout] molGrid  Grid object to (re)build at the requested size. !>  @param[in]    nrad     Number of radial points for the coarse grid. !>  @param[in]    nang     Number of angular (Lebedev) points for the coarse grid. subroutine dft_build_grid_sized ( infos , basis , molGrid , nrad , nang ) use basis_tools , only : basis_set use types , only : information implicit none type ( information ), intent ( inout ) :: infos type ( basis_set ), intent ( in ) :: basis type ( dft_grid_t ), intent ( inout ) :: molGrid integer , intent ( in ) :: nrad , nang type ( dft_grid_pruned_t ) :: pruned integer :: nat integer :: save_rad , save_ang logical :: save_pruned ! Save the production grid sizes save_rad = int ( infos % dft % grid_rad_size ) save_ang = int ( infos % dft % grid_ang_size ) save_pruned = infos % dft % grid_pruned ! Install the coarse sizes (dft_prepare_grid reads these from infos%dft) infos % dft % grid_rad_size = nrad infos % dft % grid_ang_size = nang infos % dft % grid_pruned = . false . ! Single, unpruned Lebedev grid of the requested size; mirrors the ! \".not. grid_pruned\" branch of dft_set_options, minus the libxc setup. nat = ubound ( infos % atoms % zn , 1 ) pruned % ngrids = 1 pruned % nrad = 0 ! 0 => use infos%dft%grid_rad_size (coarse) pruned % nrad_types = 1 allocate ( pruned % nang ( 1 , 1 ), pruned % radii ( 1 , 1 )) pruned % nang ( 1 , 1 ) = nang pruned % radii ( 1 , 1 ) = 1.0d+30 allocate ( pruned % rad_id ( nat ), source = 1 ) call dft_prepare_grid ( infos , basis , molGrid , pruned , verbose = . false .) ! Restore the production grid sizes infos % dft % grid_rad_size = save_rad infos % dft % grid_ang_size = save_ang infos % dft % grid_pruned = save_pruned end subroutine dft_build_grid_sized !>  @brief Decide (single unified policy) whether to build a coarse \"descent\" !>         grid for the coarse->fine SCF grid ramp, and build it if so. !> !>  @detail One entry point shared by both grid-ramp activation paths: !>            - progressive screening (scf_pscreen / OQP_PSCREEN) with !>              pscreen_grid_rad/ang > 0  -> use those sizes (opt-in, as in #238); or !>            - the coarse-to-fine schedule, ON by default unless OQP_XC_C2F=0 !>              -> default sizes (OQP_XC_C2F_RAD/ANG, 50x110), gated by the safety !>              guards in c2f_grid_eligible (DFT + pure-DIIS + non-Minnesota + !>              maxit>=2 + no level-shift-on-non-VDIIS). !>          In both cases the coarse grid is kept only if it is genuinely cheaper !>          than the production grid (by built point count). The grid ramp itself !>          (coarse during the descent, production pinned in the convergence tail) !>          lives in scf_driver; this routine only constructs the coarse grid. !> !>  @param[inout] infos    System/control info (grid sizes restored by the build). !>  @param[inout] basis    Basis set. !>  @param[in]    molGrid  Production grid (already built). !>  @param[inout] coarseGrid  Receives the coarse grid when have_coarse=.true. !>  @param[out]   have_coarse  .true. iff a useful coarse grid was built. subroutine dft_setup_descent_grid ( infos , basis , molGrid , coarseGrid , have_coarse ) use basis_tools , only : basis_set use types , only : information implicit none type ( information ), intent ( inout ) :: infos type ( basis_set ), intent ( inout ) :: basis type ( dft_grid_t ), intent ( in ) :: molGrid type ( dft_grid_t ), intent ( inout ) :: coarseGrid logical , intent ( out ) :: have_coarse logical :: ps_on , c2f_off , requested integer :: rad , ang , ps_grid_rad , ps_grid_ang character ( len = 64 ) :: ev integer :: el have_coarse = . false . if ( infos % control % hamilton < 20 ) return ! DFT only ! --- progressive-screening grid request (opt-in; sizes from input/env) --- ps_on = infos % control % scf_pscreen /= 0 call get_environment_variable ( \"OQP_PSCREEN\" , ev , el ) if ( el > 0 ) ps_on = ( ev ( 1 : 1 ) == '1' . or . ev ( 1 : 1 ) == 't' . or . ev ( 1 : 1 ) == 'T' & . or . ev ( 1 : 1 ) == 'y' . or . ev ( 1 : 1 ) == 'Y' ) ps_grid_rad = int ( infos % control % pscreen_grid_rad ) ps_grid_ang = int ( infos % control % pscreen_grid_ang ) call get_environment_variable ( \"OQP_PSCREEN_GRID_RAD\" , ev , el ) if ( el > 0 ) read ( ev , * , iostat = el ) ps_grid_rad call get_environment_variable ( \"OQP_PSCREEN_GRID_ANG\" , ev , el ) if ( el > 0 ) read ( ev , * , iostat = el ) ps_grid_ang requested = . false . if ( ps_on . and . ps_grid_rad > 0 . and . ps_grid_ang > 0 ) then rad = ps_grid_rad ; ang = ps_grid_ang requested = . true . else ! --- coarse-to-fine, controlled by [scf] xc_c2f (infos%control%xc_c2f, !     1=on default; opt out with xc_c2f=off). Coarse grid fixed at 50x110. --- c2f_off = ( infos % control % xc_c2f == 0 ) if (. not . c2f_off . and . c2f_grid_eligible ( infos )) then rad = 50 ; ang = 110 requested = ( rad > 0 . and . ang > 0 ) end if end if if (. not . requested ) return ! Build the coarse grid; keep it only if it is genuinely cheaper (by true ! built point count, so a sparse pruned production grid such as SG-0 -- which ! can be cheaper than the requested dense coarse grid -- correctly opts out). call dft_build_grid_sized ( infos , basis , coarseGrid , rad , ang ) if ( coarseGrid % nMolPts >= nint ( 0.9_dp * real ( molGrid % nMolPts , dp ))) then write ( iw , '(5x,a,i0,a,i0,a)' ) & 'Coarse-to-fine XC grid: disabled, coarse (' , coarseGrid % nMolPts , & ' pts) not cheaper than production (' , molGrid % nMolPts , ' pts)' return end if have_coarse = . true . write ( iw , '(5x,a,i0,a,i0,a,i0,a,i0,a)' ) & 'Coarse-to-fine XC grid: coarse ' , rad , ' x ' , ang , ' (' , coarseGrid % nMolPts , & ' pts) during descent, production (' , molGrid % nMolPts , ' pts) in the tail' end subroutine dft_setup_descent_grid !>  @brief Safety guards for the default-on coarse-to-fine grid ramp. !>  @detail Returns .true. only when the coarse stage is safe for an unattended, !>          default-on run: a pure-DIIS converger (converger_type==0=scf_diis), !>          at least two SCF iterations, no level shift on a non-VDIIS converger !>          (its shut-off is tied to the convergence test), and a non-Minnesota !>          functional. Explicit progressive-screening requests bypass this (the !>          user opted in) -- see dft_setup_descent_grid. logical function c2f_grid_eligible ( infos ) result ( ok ) use types , only : information implicit none type ( information ), intent ( in ) :: infos ok = . false . if ( infos % control % converger_type /= 0 ) return ! pure DIIS only (scf_diis=0) if ( infos % control % maxit < 2 ) return ! need a coarse + a production iter if ( infos % control % vshift /= 0.0_dp . and . infos % control % diis_type /= 5 ) return if ( xc_is_grid_sensitive ( infos )) return ! Minnesota family ok = . true . end function c2f_grid_eligible !>  @brief Detect grid-sensitive (Minnesota-family) functionals, for which a !>         coarse integration grid produces large errors and must be avoided. !>  @detail Matches the functional name (case- and separator-insensitive) against !>          the Minnesota families M05/M06/M08/M11/MN1x/SOGGA11 and revised (revM*) !>          variants. logical function xc_is_grid_sensitive ( infos ) result ( sensitive ) use types , only : information use strings , only : c_f_char implicit none type ( information ), intent ( in ) :: infos character ( len = :), allocatable :: nm character ( len = 40 ) :: u integer :: i , k character :: c nm = c_f_char ( infos % dft % xc_functional_name ) u = '' k = 0 do i = 1 , len_trim ( nm ) c = nm ( i : i ) if ( c == '-' . or . c == '_' . or . c == ' ' ) cycle if ( c >= 'a' . and . c <= 'z' ) c = achar ( iachar ( c ) - 32 ) k = k + 1 if ( k <= len ( u )) u ( k : k ) = c end do sensitive = index ( u , 'M05' ) == 1 . or . & index ( u , 'M06' ) == 1 . or . & index ( u , 'M08' ) == 1 . or . & index ( u , 'M11' ) == 1 . or . & index ( u , 'MN1' ) == 1 . or . & index ( u , 'SOGGA11' ) == 1 . or . & index ( u , 'REVM' ) == 1 end function xc_is_grid_sensitive !>  @brief Calculates atomic distances subroutine get_atomic_distances ( xyz , rij ) implicit none real ( kind = dp ), intent ( in ) :: xyz (:,:) real ( kind = dp ), intent ( out ) :: rij (:,:) integer :: i , j do i = 1 , ubound ( xyz , 2 ) rij ( i , i ) = 0.0d0 do j = 1 , i - 1 rij ( i , j ) = norm2 ( xyz (:, i ) - xyz (:, j )) rij ( j , i ) = rij ( i , j ) end do end do end subroutine subroutine emovlp ( nrad , rads , wts , lmn , zeta , bragg , s ) use constants , only : pi implicit none integer , intent ( in ) :: nrad , lmn real ( kind = dp ), intent ( in ) :: zeta , bragg real ( kind = dp ), intent ( in ) :: rads (:), wts (:) real ( kind = dp ), intent ( out ) :: s integer :: idf , i real ( kind = dp ) :: gnorm , r , w , gto idf = 1 do i = 0 , lmn idf = idf * ( 2 * i + 1 ) end do gnorm = zeta ** ( 2 * lmn + 3 ) * 2 ** ( 4 * lmn + 7 ) gnorm = gnorm / ( pi * idf ** 2 ) gnorm = gnorm ** ( 0.25d+00 ) s = 0 do i = 1 , nrad r = bragg * rads ( i ) w = ( bragg ** 3 ) * wts ( i ) gto = gnorm * r ** lmn * exp ( - zeta * r * r ) s = s + w * ( gto * gto ) end do end subroutine subroutine dftclean ( infos ) use types , only : information use libxc , only : libxc_destroy type ( information ), intent ( inout ) :: infos call libxc_destroy ( infos % functional ) end subroutine subroutine dft_set_options ( infos , pruned , need_functional ) use iso_c_binding , only : c_null_char use messages , only : show_message , WITH_ABORT use strings , only : c_f_char use types , only : information use libxc , only : libxc_input implicit none type ( information ), intent ( inout ) :: infos type ( dft_grid_pruned_t ), intent ( inout ) :: pruned logical , optional , intent ( in ) :: need_functional type ( saved_HF_info ) :: saved_hf logical :: need_func integer :: iatm , nrad character ( len = 20 ) :: xc_func_name integer :: nat , i , slen , ntyps character (:), allocatable :: pruned_name logical :: is_sg3 integer :: z , ie , nsec , maxsec , nang_fallback integer :: zmap ( SG_NELEM ) need_func = . true . if ( present ( need_functional )) need_func = need_functional !   Default radial/angular grid is 96/302 for LDA/GGA. nrad = infos % dft % grid_rad_size nat = ubound ( infos % atoms % zn , 1 ) allocate ( pruned % rad_id ( nat ), source = 1 ) xc_func_name = c_f_char ( infos % dft % xc_functional_name ) if (. not . infos % dft % grid_pruned ) then pruned % ngrids = 1 allocate ( pruned % nang ( 1 , 1 ), pruned % radii ( 1 , 1 )) pruned % nang ( 1 , 1 ) = infos % dft % grid_ang_size pruned % radii ( 1 , 1 ) = 1.0d+30 write ( iw , '(/5X,\"Lebedev grid-based DFT options\"/& &5X,30(\"-\")/& &5X,\"XC functional: \",A/& &5X,\"NRAD  =\",I8,5X,\"NLEB  =\",I8/& &5X,\"THRESH=\",1P,E12.2)' ) & trim ( xc_func_name ), & nrad , pruned % nang ( 1 , 1 ), & infos % dft % grid_density_cutoff else !     Set parameters for pruned grids slen = ubound ( infos % dft % grid_pruned_name , 1 ) allocate ( character ( len = slen ) :: pruned_name ) do i = 1 , slen if ( infos % dft % grid_pruned_name ( i ) == c_null_char ) exit pruned_name ( i : i ) = infos % dft % grid_pruned_name ( i ) end do select case ( trim ( pruned_name )) case ( \"SG1\" ) pruned % ngrids = 5 ntyps = 4 allocate ( pruned % nang ( pruned % ngrids , ntyps ), & pruned % radii ( pruned % ngrids , ntyps )) pruned % radii = sg1rads do i = 1 , ntyps pruned % nang (:, i ) = sg1grids end do do iatm = 1 , nat ! sg1atoms are inclusive upper bounds of the period: ! H-He (Z<=2), Li-Ne (Z<=10), Na-Ar (Z<=18), heavier do i = 1 , ntyps if ( int ( infos % atoms % zn ( iatm )) <= sg1atoms ( i )) exit end do pruned % rad_id ( iatm ) = min ( i , ntyps ) end do ! SG1 is undefined above Ar: heavy atoms (type 4) are truly ! unpruned, i.e. a single 194-point sphere at all radii allocate ( pruned % nang_override ( ntyps ), source = 0 ) pruned % nang_override ( 4 ) = 194 write ( iw , '(/5X,\"Standard Grid 1 (SG1)\"/& &5X,21(\"-\")/& &5X,\"XC functional: \",A/& &5X,\"THRESH=\",1P,E12.2)' ) & trim ( xc_func_name ), & infos % dft % grid_density_cutoff case ( \"SG2\" , \"SG3\" ) is_sg3 = trim ( pruned_name ) == \"SG3\" if ( is_sg3 ) then pruned % nrad = SG3_NRAD maxsec = SG3_MAXSEC nang_fallback = 590 else pruned % nrad = SG2_NRAD maxsec = SG2_MAXSEC nang_fallback = 302 end if !       One atom type per supported element present in the system; !       type 1 is the fallback (He, Ne, Ar, Z > 18, dummy atoms): !       unpruned nang_fallback-point grid on the standard radial grid. zmap = 0 ntyps = 1 do iatm = 1 , nat z = int ( abs ( infos % atoms % zn ( iatm )) + 1.0d-5 ) ie = 0 if ( abs ( abs ( infos % atoms % zn ( iatm )) - z ) <= 1.0d-5 . and . & z >= 1 . and . z <= 17 ) then do i = 1 , SG_NELEM if ( sg_elem_z ( i ) == z ) then ie = i exit end if end do end if if ( ie > 0 ) then if ( zmap ( ie ) == 0 ) then ntyps = ntyps + 1 zmap ( ie ) = ntyps end if pruned % rad_id ( iatm ) = zmap ( ie ) else pruned % rad_id ( iatm ) = 1 end if end do pruned % ngrids = maxsec pruned % nrad_types = ntyps allocate ( pruned % nang ( maxsec , ntyps ), source = 0 ) allocate ( pruned % nradPerRegion ( maxsec , ntyps ), source = 0 ) allocate ( pruned % radii ( maxsec , ntyps ), source = 1.0d30 ) allocate ( pruned % de2_alpha ( ntyps ), source = 0.0_dp ) allocate ( pruned % de2_rmax ( ntyps ), source = 0.0_dp ) pruned % radial_id = pruned % rad_id !       Fallback type: single unpruned region, standard radial grid pruned % nang ( 1 , 1 ) = nang_fallback !       Element types: index-based sectors on the per-element DE2 grid do ie = 1 , SG_NELEM i = zmap ( ie ) if ( i == 0 ) cycle if ( is_sg3 ) then nsec = sg3_nsec ( ie ) pruned % nang ( 1 : nsec , i ) = sg3_leb ( 1 : nsec , ie ) pruned % nradPerRegion ( 1 : nsec , i ) = sg3_cnt ( 1 : nsec , ie ) pruned % de2_alpha ( i ) = sg3_alpha ( ie ) else nsec = SG2_MAXSEC pruned % nang ( 1 : nsec , i ) = sg2_leb ( 1 : nsec , ie ) pruned % nradPerRegion ( 1 : nsec , i ) = sg2_cnt ( 1 : nsec , ie ) pruned % de2_alpha ( i ) = sg2_alpha ( ie ) end if pruned % de2_rmax ( i ) = sg_de2_rmax ( ie ) end do write ( iw , '(/5X,\"Standard Grid \",A,\" (\",A,\") of Dasgupta and Herbert\"/& &5X,40(\"-\")/& &5X,\"XC functional: \",A/& &5X,\"NRAD  =\",I8,\"   (Mitani DE2 radial grid)\"/& &5X,\"THRESH=\",1P,E12.2)' ) & pruned_name ( 3 : 3 ), trim ( pruned_name ), & trim ( xc_func_name ), pruned % nrad , & infos % dft % grid_density_cutoff case ( \"SG0\" ) maxsec = SG0_MAXSEC !       The radial storage must fit both the MultiExp grids (up to 26 !       nodes) and the standard radial grid of the fallback atoms pruned % nrad = max ( nrad , 26 ) !       One atom type per supported element present in the system; !       types 1-4 are the SG1 fallback (He, Ne, Z >= 18, non-integer !       nuclear charges), typed by period as in the SG1 case; element !       types are 5, 6, ...  Radial types: 1 is the standard grid !       (fallback); element type 4+k uses MultiExp radial column 1+k. zmap = 0 ntyps = 4 allocate ( pruned % radial_id ( nat ), source = 1 ) do iatm = 1 , nat z = int ( abs ( infos % atoms % zn ( iatm )) + 1.0d-5 ) ie = 0 if ( abs ( abs ( infos % atoms % zn ( iatm )) - z ) <= 1.0d-5 . and . & z >= 1 . and . z <= 17 ) then do i = 1 , SG_NELEM if ( sg_elem_z ( i ) == z ) then ie = i exit end if end do end if if ( ie > 0 ) then if ( zmap ( ie ) == 0 ) then ntyps = ntyps + 1 zmap ( ie ) = ntyps end if pruned % rad_id ( iatm ) = zmap ( ie ) pruned % radial_id ( iatm ) = zmap ( ie ) - 3 else ! SG1 fallback type by period (see the SG1 case) do i = 1 , 4 if ( int ( infos % atoms % zn ( iatm )) <= sg1atoms ( i )) exit end do pruned % rad_id ( iatm ) = min ( i , 4 ) pruned % radial_id ( iatm ) = 1 end if end do pruned % ngrids = maxsec pruned % nrad_types = ntyps - 3 allocate ( pruned % nang ( maxsec , ntyps ), source = 0 ) allocate ( pruned % nradPerRegion ( maxsec , ntyps ), source = 0 ) allocate ( pruned % radii ( maxsec , ntyps ), source = 1.0d30 ) allocate ( pruned % nang_override ( ntyps ), source = 0 ) allocate ( pruned % de2_alpha ( pruned % nrad_types ), source = 0.0_dp ) allocate ( pruned % de2_rmax ( pruned % nrad_types ), source = 0.0_dp ) allocate ( pruned % rad_npts ( pruned % nrad_types ), source = 0 ) allocate ( pruned % me_rscale ( pruned % nrad_types ), source = 0.0_dp ) !       Fallback types 1-4: the SG1 scheme (radius-based regions) on !       the standard radial grid; heavy atoms (type 4) are truly !       unpruned, i.e. a single 194-point sphere at all radii do i = 1 , 4 pruned % nang ( 1 : 5 , i ) = sg1grids pruned % radii ( 1 : 5 , i ) = sg1rads (:, i ) end do pruned % nang_override ( 4 ) = 194 !       Element types: index-based sectors on the per-element MultiExp !       radial grid do ie = 1 , SG_NELEM i = zmap ( ie ) if ( i == 0 ) cycle nsec = sg0_nsec ( ie ) pruned % nang ( 1 : nsec , i ) = sg0_leb ( 1 : nsec , ie ) pruned % nradPerRegion ( 1 : nsec , i ) = sg0_cnt ( 1 : nsec , ie ) pruned % rad_npts ( i - 3 ) = sg0_nrad ( ie ) pruned % me_rscale ( i - 3 ) = sg0_rscale ( ie ) end do write ( iw , '(/5X,\"Standard Grid 0 (SG0) of Chien and Gill\"/& &5X,39(\"-\")/& &5X,\"XC functional: \",A/& &5X,\"NRAD  =   23/26   (MultiExp radial grid)\"/& &5X,\"THRESH=\",1P,E12.2)' ) & trim ( xc_func_name ), & infos % dft % grid_density_cutoff case default call show_message ( 'Unknown pruned grid name' , WITH_ABORT ) end select end if !   New we set the DFT XC functionals... if ( trim ( xc_func_name ) /= \"\" ) then ! save HFscale, or cam_alpha,beta,mu from input call saved_HF % save_HF ( infos ) call libxc_input ( functional_name = trim ( xc_func_name ), & dft_params = infos % dft , & tddft_params = infos % tddft , & functional = infos % functional ) ! update HFscale, or cam_alpha,beta,mu from input if ( saved_HF % do ) call saved_HF % update_HF ( infos ) else if ( need_func ) then call show_message ( 'Please, specify functional in the input file' , WITH_ABORT ) end if end subroutine subroutine dft_prepare_grid ( infos , basis , molGrid , pruned , verbose ) use basis_tools , only : basis_set use dft_radial_grid_types , only : get_radial_grid use mod_dft_fuzzycell , only : dft_fc_blk use mod_grid_storage , only : atomic_grid_t use bragg_slater_radii , only : set_bragg_slater , & BRSL_NUM_ELEMENTS , & BRSL_TYPE_GILL , & BRSL_TYPE_TA , & BRSL_TYPE_BECKE use types , only : information implicit none type ( basis_set ), intent ( in ) :: basis type ( information ), intent ( in ) :: infos type ( dft_grid_t ), intent ( inout ) :: molGrid type ( dft_grid_pruned_t ), intent ( in ) :: pruned logical , optional :: verbose integer :: i , igrid , nat , iat , maxpt_per_atom , nrad integer :: bstype integer :: grid_id integer :: max_ang_pts integer :: ngr , rtid , nrad_at , override integer :: rad_grid_type , dft_partfun , dft_bfc_algo real ( kind = dp ) :: dftthr0 real ( KIND = dp ) :: brsl_radii ( BRSL_NUM_ELEMENTS ) logical :: verbose_ real ( kind = dp ), allocatable :: txyz (:), twght (:) real ( kind = dp ), allocatable :: wtab (:,:,:) real ( kind = dp ), allocatable :: rij (:,:), aij (:,:) real ( kind = dp ), allocatable :: bsrad (:) real ( KIND = dp ) :: brsl_becke ( BRSL_NUM_ELEMENTS ) real ( kind = dp ), allocatable :: bsrad_becke (:) type ( atomic_grid_t ) :: atomic_grid verbose_ = . false . if ( present ( verbose )) verbose_ = verbose nat = ubound ( infos % atoms % zn , 1 ) rad_grid_type = int ( infos % dft % rad_grid_type ) dft_partfun = int ( infos % dft % dft_partfun ) dft_bfc_algo = int ( infos % dft % dft_bfc_algo ) max_ang_pts = maxval ( pruned % nang ) if ( allocated ( pruned % nang_override )) & max_ang_pts = max ( max_ang_pts , maxval ( pruned % nang_override )) nrad = int ( infos % dft % grid_rad_size ) ! A pruned grid may prescribe its own radial grid size if ( pruned % nrad > 0 ) nrad = pruned % nrad maxpt_per_atom = nrad * max_ang_pts allocate (& txyz ( max_ang_pts * 3 ), & twght ( max_ang_pts ), & rij ( nat , nat ), & aij ( nat , nat ), & bsrad ( nat ), & source = 0.0d0 ) !     Init storage for the grid call molGrid % reset ( nat , maxpt_per_atom , nRad , pruned % nrad_types ) !     Print out DFT info if ( verbose_ ) then dftthr0 = 1.0d-03 / ( maxpt_per_atom * nat ) if ( dftthr0 . lt . 1.1d-15 ) then write ( iw , '(5x, \"All DFT thresholds are turned off.\")' ) else write ( iw , '(5x, \"DFT Threshold         =\",e10.3)' ) dftthr0 end if end if !     Set up Bragg-Slater radii for atoms.  rad_grid_type: 0=mhl, 1=mk3, !     2=ta, 3=becke.  The Treutler-Ahlrichs grid (2) is defined with the !     Treutler-Ahlrichs Bragg-Slater radii; selecting only becke (3) here left !     rad_type='ta' on Gill radii (a TA-quadrature/Gill-radii hybrid), so !     include 2 as well. select case ( rad_grid_type ) case ( 2 , 3 ) bstype = BRSL_TYPE_TA case default bstype = BRSL_TYPE_GILL end select call set_bragg_slater ( brsl_radii , bstype ) do i = 1 , nat bsrad ( i ) = bragg_slater_radius ( brsl_radii , infos % atoms % zn ( i )) end do !     Set up radial grid (the standard grid is radial type 1) call get_radial_grid ( molGrid % rad_pts (:, 1 ), molGrid % rad_wts (:, 1 ), & nrad , rad_grid_type ) !     Element-specific radial grids, absolute radii. !     MultiExp (SG-0): per-element node count and scaling radius; !     DE2 (SG-2/SG-3): the innermost/outermost nodes are pinned to !     SG_DE2_RMIN and the element-specific R_max (cuEST convention). !     Unused trailing rows of a MultiExp column stay zero and are !     never referenced (per-atom grids are sliced to the per-type !     node count below). do i = 2 , pruned % nrad_types if ( allocated ( pruned % me_rscale )) then nrad_at = pruned % rad_npts ( i ) call multiexp_radial_grid ( nrad_at , pruned % me_rscale ( i ), & molGrid % rad_pts ( 1 : nrad_at , i ), molGrid % rad_wts ( 1 : nrad_at , i )) else call de2_radial_grid ( nrad , pruned % de2_alpha ( i ), & SG_DE2_RMIN , pruned % de2_rmax ( i ), & molGrid % rad_pts (:, i ), molGrid % rad_wts (:, i )) end if end do !     Per-atom radial grid types if ( allocated ( pruned % radial_id )) & molGrid % radTypeId ( 1 : nat ) = pruned % radial_id ( 1 : nat ) !     Pre-compute atomic distances call get_atomic_distances ( infos % atoms % xyz , rij ) !     Tag non-real atoms present in the system molGrid % dummyAtom (: nat ) = bsrad (: nat ) == 0.0_dp !     Find nearest neighbours for all atoms call molGrid % find_neighbours ( rij , partFunType = dft_partfun ) !     Compute atomic grids for each atom do iat = 1 , nat grid_id = pruned % rad_id ( iat ) rtid = molGrid % radTypeId ( iat ) override = 0 if ( allocated ( pruned % nang_override )) & override = pruned % nang_override ( grid_id ) if ( override > 0 ) then !         Unpruned atom type: a single angular grid at all radii !         (add_atomic_grid extends a single region to all radial shells) if ( allocated ( atomic_grid % sph_nrad )) & deallocate ( atomic_grid % sph_nrad ) atomic_grid % sph_npts = [ override ] atomic_grid % sph_radii = [ 999999 9.9d0 ] call molGrid % spherical_grids % add_grid ( override ) else !         Number of regions used by this atom type and the pruning mode: !         index-based sectors (nradPerRegion > 0) vs radius-based regions ngr = pruned % ngrids if ( allocated ( pruned % nradPerRegion )) then if ( any ( pruned % nradPerRegion (:, grid_id ) > 0 )) then ngr = count ( pruned % nradPerRegion (:, grid_id ) > 0 ) atomic_grid % sph_nrad = pruned % nradPerRegion ( 1 : ngr , grid_id ) else ngr = count ( pruned % nang (:, grid_id ) > 0 ) if ( allocated ( atomic_grid % sph_nrad )) & deallocate ( atomic_grid % sph_nrad ) end if end if atomic_grid % sph_npts = pruned % nang ( 1 : ngr , grid_id ) atomic_grid % sph_radii = pruned % radii ( 1 : ngr , grid_id ) !         Set angular Lebedev grid(s) do igrid = 1 , ngr !           get the unit lebedev sphere (no-op if already stored) call molGrid % spherical_grids % add_grid ( pruned % nang ( igrid , grid_id )) end do end if atomic_grid % idAtm = iat !       Set the radial grid of the atom.  Element-specific grids !       (types >= 2) store absolute radii: use a unit effective radius; !       the standard grid (type 1) is scaled by the Bragg-Slater !       radius.  The per-atom grid is sliced to the per-type node !       count when one is prescribed (MultiExp grids of SG-0). nrad_at = nrad if ( allocated ( pruned % rad_npts )) then if ( pruned % rad_npts ( rtid ) > 0 ) nrad_at = pruned % rad_npts ( rtid ) end if atomic_grid % rad_pts = molGrid % rad_pts ( 1 : nrad_at , rtid ) atomic_grid % rad_wts = molGrid % rad_wts ( 1 : nrad_at , rtid ) if ( rtid > 1 ) then atomic_grid % rAtm = 1.0_dp else atomic_grid % rAtm = bsrad ( iat ) end if call molGrid % add_atomic_grid ( atomic_grid ) end do !     Assemble molecular grid from atomic grids !     Do Becke's fuzzy cell select case ( dft_bfc_algo ) case ( 0 ) !       SSF algorithm: !       various partitioning functions, no surface shifting call dft_fc_blk ( molgrid , dft_partfun , & infos % atoms % xyz , basis % at_mx_dist2 , rij , nat , wtab ) case ( 1 ) !       Precompute surface shifting parameters call setaij ( aij , nat , bsrad ) !       Becke's algorithm: !       4th deg. Becke's polynomial and surface shifting call dft_fc_blk ( molgrid , dft_partfun , & infos % atoms % xyz , basis % at_mx_dist2 , rij , nat , wtab , aij ) case ( 2 ) !       Reference ddCOSMO/ddPCM-compatible Becke partition: !       surface shifting with the Treutler-Ahlrichs sqrt(chi) atomic-size !       adjustment (JCP 102, 346 (1995)) built from the Becke Bragg-Slater !       table (Slater radii, H = 0.35 A), independent of the radial-grid !       scaling radii selected above.  Combine with dft_partfun = !       PTYPE_BECKE3 to reproduce the standard Becke-original molecular !       partition used by the ddPCM literature source projection. allocate ( bsrad_becke ( nat ), source = 0.0d0 ) call set_bragg_slater ( brsl_becke , BRSL_TYPE_BECKE ) do i = 1 , nat bsrad_becke ( i ) = bragg_slater_radius ( brsl_becke , infos % atoms % zn ( i )) end do call setaij_treutler ( aij , nat , bsrad_becke ) call dft_fc_blk ( molgrid , dft_partfun , & infos % atoms % xyz , basis % at_mx_dist2 , rij , nat , wtab , aij ) end select call molGrid % compress if ( verbose_ ) then write ( iw , '(5X,\"Molecular grid: \",I0,\" points in \",I0,\" slices\")' ) & sum ( molGrid % nTotPts ( 1 : molGrid % nSlices )), molGrid % nSlices end if end subroutine !> @brief Mitani double-exponential (DE2) radial quadrature !> @details M. Mitani, Theor. Chem. Acc. 130, 645 (2011); !>   M. Mitani, Y. Yoshioka, Theor. Chem. Acc. 131, 1169 (2012). !>   Nodes and weights (the weights include the r&#94;2 Jacobian): !>     x_i = x_start + (i-1)*h,  i = 1..nr !>     r_i = exp(alpha*x_i - exp(-x_i))                        [bohr] !>     w_i = h*(alpha + exp(-x_i))*exp(3*alpha*x_i - 3*exp(-x_i)) !>   x_start and x_end are pinned to the innermost/outermost radial !>   nodes:  alpha*x - exp(-x) = ln(rmin) resp. ln(rmax), solved by !>   Newton iteration (the left-hand side is strictly increasing), !>   and h = (x_end - x_start)/(nr - 1).  This matches the SG-2/SG-3 !>   convention of NVIDIA cuEST (CUDALibrarySamples). !> @param[in]   nr     number of radial points !> @param[in]   alpha  DE2 alpha parameter (element-specific) !> @param[in]   rmin   innermost radial node, bohr !> @param[in]   rmax   outermost radial node, bohr !> @param[out]  r      radial nodes, absolute bohr !> @param[out]  w      radial weights including the r&#94;2 Jacobian pure subroutine de2_radial_grid ( nr , alpha , rmin , rmax , r , w ) implicit none integer , intent ( in ) :: nr real ( kind = dp ), intent ( in ) :: alpha , rmin , rmax real ( kind = dp ), intent ( out ) :: r (:), w (:) integer :: i real ( kind = dp ) :: h , x , x_start , x_end x_start = de2_solve_x ( alpha , log ( rmin ), - 2.3_dp ) x_end = de2_solve_x ( alpha , log ( rmax ), 1.25_dp ) h = ( x_end - x_start ) / ( nr - 1 ) do i = 1 , nr x = x_start + ( i - 1 ) * h r ( i ) = exp ( alpha * x - exp ( - x )) w ( i ) = h * ( alpha + exp ( - x )) * exp ( 3.0_dp * alpha * x - 3.0_dp * exp ( - x )) end do end subroutine de2_radial_grid !> @brief Solve alpha*x - exp(-x) = lnr for x by Newton iteration !> @details The left-hand side is strictly increasing in x for !>   alpha > 0, so the root is unique. pure function de2_solve_x ( alpha , lnr , x0 ) result ( x ) implicit none real ( kind = dp ), intent ( in ) :: alpha , lnr , x0 real ( kind = dp ) :: x integer :: iter real ( kind = dp ) :: f , xnew x = x0 do iter = 1 , 100 f = alpha * x - exp ( - x ) - lnr xnew = x - f / ( alpha + exp ( - x )) if ( abs ( xnew - x ) < 1.0d-14 ) then x = xnew exit end if x = xnew end do end function de2_solve_x !> @brief MultiExp radial quadrature (SG-0) !> @details P.M.W. Gill, S.-H. Chien, J. Comput. Chem. 24, 732 (2003). !>   Gauss quadrature on (0,1) for the weight function ln&#94;2 x !>   (moments m_k = 2/(k+1)&#94;3), mapped to (0,inf) by r = -R ln x: !>     r_i = -R ln(x_i)                                       [bohr] !>     w_i = R&#94;3 omega_i / x_i !>   The weights include the r&#94;2 Jacobian, matching the DE2 !>   convention (the consumer multiplies by rAtm&#94;3 = 1).  Nodes and !>   weights are tabulated for n = 23 and 26 (the SG-0 sizes), sorted !>   by ascending radius. !> @param[in]   nr      number of radial points (23 or 26) !> @param[in]   rscale  element-specific scaling radius R, bohr !> @param[out]  r       radial nodes, absolute bohr !> @param[out]  w       radial weights including the r&#94;2 Jacobian subroutine multiexp_radial_grid ( nr , rscale , r , w ) implicit none integer , intent ( in ) :: nr real ( kind = dp ), intent ( in ) :: rscale real ( kind = dp ), intent ( out ) :: r (:), w (:) integer :: i select case ( nr ) case ( 23 ) do i = 1 , nr r ( i ) = - rscale * log ( me23_x ( i )) w ( i ) = rscale ** 3 * me23_w ( i ) / me23_x ( i ) end do case ( 26 ) do i = 1 , nr r ( i ) = - rscale * log ( me26_x ( i )) w ( i ) = rscale ** 3 * me26_w ( i ) / me26_x ( i ) end do case default call show_message ( 'MultiExp radial grid: unsupported size' , & WITH_ABORT ) end select end subroutine multiexp_radial_grid subroutine dftexcor ( basis , molGrid , iscftyp , fa , fb , coeffa , coeffb , nbf , nbf_tri , eexc , totele , totkin , infos , sym_atom_weight ) use basis_tools , only : basis_set use mod_dft_gridint_energy , only : dmatd_blk use types , only : information !$  use omp_lib, only: omp_get_wtime implicit none type ( information ), intent ( in ) :: infos type ( basis_set ) :: basis type ( dft_grid_t ), intent ( in ) :: molGrid real ( kind = dp ), intent ( inout ) :: fa ( * ), fb ( * ), coeffa ( * ), coeffb ( * ) integer , intent ( in ) :: iscftyp , nbf , nbf_tri real ( kind = dp ), intent ( out ) :: eexc , totele , totkin !> Optional symmetry-reduction atom weights (orbit size or zero). real ( kind = dp ), intent ( in ), optional , contiguous , target :: sym_atom_weight (:) integer :: nang , maxl logical :: urohf real ( kind = dp ) :: t0 , t1 t0 = 0 ; t1 = 0 urohf = iscftyp /= 1 fa ( 1 : nbf_tri ) = 0.0d0 if ( iscftyp >= 2 ) fb ( 1 : nbf_tri ) = 0.0d0 maxl = maxval ( basis % am ) nang = maxl + 1 + 1 totele = 0.0d0 totkin = 0.0d0 eexc = 0.0d0 !$  t0 = omp_get_wtime() if ( present ( sym_atom_weight )) then call dmatd_blk ( basis , molGrid , coeffa , coeffb , fa , fb , & eexc , totele , totkin , & nang , nbf , infos % dft % grid_density_cutoff , urohf , infos , & sym_atom_weight ) else call dmatd_blk ( basis , molGrid , coeffa , coeffb , fa , fb , & eexc , totele , totkin , & nang , nbf , infos % dft % grid_density_cutoff , urohf , infos ) end if !$  t1 = omp_get_wtime() !$  write(iw,'(4X,\"DFT XC integration time:\",F10.3,\" s\")') t1-t0 end subroutine !> @brief Analytical DFT gradient subroutine dftder ( basis , infos , molGrid ) use mathlib , only : unpack_matrix use mod_dft_gridint_grad , only : derexc_blk use types , only : information use oqp_tagarray_driver implicit none character ( len =* ), parameter :: subroutine_name = \"dftder\" type ( basis_set ) :: basis type ( information ), intent ( inout ) :: infos type ( dft_grid_t ), intent ( inout ) :: molGrid integer :: iscftype , num , nat , nbf , nang , nder , maxl integer :: iok real ( kind = dp ) :: totele , totkin logical :: urohf real ( kind = dp ), allocatable :: tda (:,:), tdb (:,:), dedft (:,:) ! tagarray real ( kind = dp ), contiguous , pointer :: dmat_a (:), dmat_b (:) integer ( 4 ) :: status iscftype = infos % control % scftype num = basis % nbf urohf = iscftype /= 1 nat = infos % mol_prop % natom nbf = num maxl = maxval ( basis % am ) nang = maxl + 1 + 1 nder = 1 if (. not . allocated ( tda )) then allocate (& tda ( nbf , nbf ), & dedft ( 3 , nat ), & stat = iok ) if ( iok /= 0 ) call show_message ( 'Cannot allocate memory' , WITH_ABORT ) end if if ( urohf ) then iok = 0 if (. not . allocated ( tdb )) allocate ( tdb ( nbf , nbf ), stat = iok ) if ( iok /= 0 ) call show_message ( 'Cannot allocate memory' , WITH_ABORT ) end if !   RHF call tagarray_get_data ( infos % dat , OQP_DM_A , dmat_a , status ) call check_status ( status , module_name , subroutine_name , OQP_DM_A ) call unpack_matrix ( dmat_a , tda , nbf , 'U' ) !   UHF/ROHF if ( urohf ) then call tagarray_get_data ( infos % dat , OQP_DM_B , dmat_b , status ) call check_status ( status , module_name , subroutine_name , OQP_DM_B ) call unpack_matrix ( dmat_b , tdb , nbf , 'U' ) end if dedft = 0 totele = 0 call derexc_blk ( basis , molGrid , tda , tdb , dedft , & totele , totkin , & nang , nbf , infos % dft % grid_density_cutoff , urohf , infos ) infos % atoms % grad (:,: nat ) = infos % atoms % grad (:,: nat ) + dedft (:,: nat ) end subroutine !> @brief Calculate surface shifting parameters !> @author Vladimir Mironov !> @date  : Jan, 2019 !> @param[out]  aij   surface shifting parameters !> @param[in]   nat   number of atoms subroutine setaij ( aij , nat , bsrad ) implicit none real ( kind = dp ), intent ( out ) :: aij ( nat , * ) integer , intent ( in ) :: nat real ( kind = dp ), intent ( in ) :: bsrad (:) integer :: iatm , jatm real ( kind = dp ) :: radi , radj , chi , chi2 do iatm = 1 , nat aij ( iatm , iatm ) = 0.0d0 radi = bsrad ( iatm ) if ( radi < 0.001 ) then aij ( 1 , iatm ) = - 1 cycle end if do jatm = 1 , nat if ( iatm == jatm ) cycle radj = bsrad ( jatm ) if ( radj < 0.001 ) then aij ( jatm , iatm ) = 1 cycle end if chi = radi / radj chi2 = ( chi - 1 ) / ( chi + 1 ) aij ( jatm , iatm ) = chi2 / ( chi2 * chi2 - 1 ) aij ( jatm , iatm ) = min ( aij ( jatm , iatm ), 0.5 ) aij ( jatm , iatm ) = max ( aij ( jatm , iatm ), - 0.5 ) end do end do end subroutine !> @brief Calculate surface shifting parameters with the Treutler-Ahlrichs !>        atomic-size adjustment, chi = sqrt(R_i/R_j) (JCP 102, 346 (1995)). !> @details Identical to setaij except that the radii ratio enters through !>  its square root, i.e. a_ij = u/(u&#94;2-1) with u = (chi-1)/(chi+1) and !>  chi = sqrt(R_i/R_j), clipped to |a| <= 0.5.  This is the adjustment used !>  by the reference ddCOSMO/ddPCM (and PySCF gen_grid default) Becke !>  partition that the PCM full-density source projection must reproduce. !> @param[out]  aij   surface shifting parameters !> @param[in]   nat   number of atoms !> @param[in]   bsrad Bragg-Slater radii of the atoms subroutine setaij_treutler ( aij , nat , bsrad ) implicit none real ( kind = dp ), intent ( out ) :: aij ( nat , * ) integer , intent ( in ) :: nat real ( kind = dp ), intent ( in ) :: bsrad (:) integer :: iatm , jatm real ( kind = dp ) :: radi , radj , chi , chi2 do iatm = 1 , nat aij ( iatm , iatm ) = 0.0d0 radi = bsrad ( iatm ) do jatm = 1 , nat if ( iatm == jatm ) cycle radj = bsrad ( jatm ) if ( radi < 0.001 . or . radj < 0.001 ) then ! Dummy/unknown atoms carry no surface shift; they are excluded ! from the fuzzy-cell partition via molGrid%dummyAtom anyway. aij ( jatm , iatm ) = 0.0d0 cycle end if chi = sqrt ( radi / radj ) chi2 = ( chi - 1 ) / ( chi + 1 ) aij ( jatm , iatm ) = chi2 / ( chi2 * chi2 - 1 ) aij ( jatm , iatm ) = min ( aij ( jatm , iatm ), 0.5 ) aij ( jatm , iatm ) = max ( aij ( jatm , iatm ), - 0.5 ) end do end do end subroutine pure function bragg_slater_radius ( element_radii , nuclear_charge ) result ( radius ) use physical_constants , only : angstrom_to_bohr implicit none real ( kind = dp ), intent ( in ) :: element_radii (:) real ( kind = dp ), intent ( in ) :: nuclear_charge real ( kind = dp ) :: radius integer :: atomic_number real ( kind = dp ), parameter :: tolerance = 1e-5_dp radius = 0.0_dp atomic_number = int ( abs ( nuclear_charge ) + tolerance ) if ( abs ( abs ( nuclear_charge ) - atomic_number ) <= tolerance ) then radius = element_radii ( atomic_number ) end if radius = radius * angstrom_to_bohr end function bragg_slater_radius end module dft","tags":"","url":"sourcefile/dft.f90.html"},{"title":"mp2_energy.F90 – OpenQP Fortran API","text":"Source Code !> @file mp2_energy.F90 !> !> @brief Driver for the standalone MP2 ground-state energy method. !> !> MP2 is a post-SCF ground-state correlation correction: the SCF reference !> (RHF/UHF/ROHF) is converged first by the usual PyOQP `reference` step, and !> this driver adds the second-order Moller-Plesset correlation energy on top, !> reusing the validated two-electron driver via `mp2_lib`.  It is dispatched !> from Python as `[input] method = mp2` (a ground-state post-SCF method that !> reports no excitations). module mp2_energy_mod implicit none private public :: mp2_energy character ( len =* ), parameter :: module_name = \"mp2_energy_mod\" contains !> C-bound entry point: `[input] method = mp2` dispatches here. subroutine mp2_energy_C ( c_handle ) bind ( C , name = \"mp2_energy\" ) use c_interop , only : oqp_handle_t , oqp_handle_get_info use types , only : information type ( oqp_handle_t ) :: c_handle type ( information ), pointer :: inf inf => oqp_handle_get_info ( c_handle ) call mp2_energy ( inf ) end subroutine mp2_energy_C !> MP2 ground-state correlation on the converged SCF reference. subroutine mp2_energy ( infos ) use precision , only : dp use io_constants , only : iw use types , only : information use printing , only : print_module_info use mp2_lib , only : mp2_correlation use messages , only : show_message , with_abort implicit none type ( information ), target , intent ( inout ) :: infos real ( kind = dp ) :: e_mp2 , e_aa , e_bb , e_ab , e_ref , e_ss logical :: computed open ( unit = iw , file = infos % log_filename , position = \"append\" ) call print_module_info ( 'MP2_Energy' , 'Computing MP2 ground-state correlation' ) e_ref = infos % mol_energy % energy call mp2_correlation ( infos , e_mp2 , e_aa , e_bb , e_ab , computed ) write ( iw , '(/,2X,60(\"=\"))' ) write ( iw , '(2X,A)' ) 'MP2  (Moller-Plesset second order, ground state)' write ( iw , '(2X,60(\"=\"))' ) if ( computed ) then e_ss = e_aa + e_bb write ( iw , '(2X,A,F20.10)' ) 'E(reference, SCF)      = ' , e_ref write ( iw , '(2X,A,F20.10)' ) 'E(MP2, same-spin aa)   = ' , e_aa write ( iw , '(2X,A,F20.10)' ) 'E(MP2, same-spin bb)   = ' , e_bb write ( iw , '(2X,A,F20.10)' ) 'E(MP2, same-spin total)= ' , e_ss write ( iw , '(2X,A,F20.10)' ) 'E(MP2, opp-spin  ab)   = ' , e_ab write ( iw , '(2X,A,F20.10)' ) 'MP2 same-spin scale    = ' , infos % dft % MP2SS_Scale write ( iw , '(2X,A,F20.10)' ) 'MP2 opp-spin scale     = ' , infos % dft % MP2OS_Scale write ( iw , '(2X,A,F20.10)' ) 'E(MP2, correlation)    = ' , e_mp2 write ( iw , '(2X,A,F20.10)' ) 'E(MP2, total)          = ' , e_ref + e_mp2 ! Report the MP2 total as the molecular energy for downstream consumers. infos % mol_energy % energy = e_ref + e_mp2 infos % mol_energy % etot = e_ref + e_mp2 else write ( iw , '(2X,A)' ) 'MP2 not computed: the system exceeds the per-MO-pair' write ( iw , '(2X,A)' ) 'Coulomb-build size guard (raise OQP_MP2_MAX_JBUILDS,' write ( iw , '(2X,A)' ) 'or use a smaller basis).' write ( iw , '(2X,60(\"=\"),/)' ) close ( iw ) call show_message ( 'MP2 aborted: OQP_MP2_MAX_JBUILDS guard was exceeded' , with_abort ) return end if write ( iw , '(2X,60(\"=\"),/)' ) close ( iw ) end subroutine mp2_energy end module mp2_energy_mod","tags":"","url":"sourcefile/mp2_energy.f90.html"},{"title":"ecpint.F90 – OpenQP Fortran API","text":"Source Code module libecp_result use iso_c_binding implicit none type , bind ( c ) :: ecp_result type ( c_ptr ) :: data ! 64-bit: the second-derivative payload is 3N(3N+1)/2 * nbf&#94;2 doubles, ! which overflows a 32-bit count already around ~50 atoms / 500 basis ! functions. (Mirrors int64_t in source/wrapper/libecpint_wrapper.cpp.) integer ( c_int64_t ) :: size end type ecp_result end module libecp_result module libecpint_wrapper use iso_c_binding , only : c_int , c_double , c_ptr implicit none interface function init_integrator ( num_gaussians , g_coords , g_exps , g_coefs , & g_ams , g_lengths ) bind ( c , name = \"init_integrator\" ) use iso_c_binding , only : c_int , c_double , c_ptr type ( c_ptr ) :: init_integrator integer ( c_int ), value :: num_gaussians real ( c_double ), dimension ( * ), intent ( in ) :: g_coords real ( c_double ), dimension ( * ), intent ( in ) :: g_exps real ( c_double ), dimension ( * ), intent ( in ) :: g_coefs !            real(c_double), dimension(*) :: g_coords, g_exps, g_coefs integer ( c_int ), dimension ( * ) :: g_ams , g_lengths end function init_integrator subroutine set_ecp_basis ( integrator , num_ecps , u_coords , u_exps , & u_coefs , u_ams , u_ns , u_lengths ) & bind ( c , name = \"set_ecp_basis\" ) use iso_c_binding , only : c_int , c_double , c_ptr type ( c_ptr ), value :: integrator integer ( c_int ), value :: num_ecps real ( c_double ), dimension ( * ) :: u_coords , u_exps , u_coefs integer ( c_int ), dimension ( * ) :: u_ams , u_ns , u_lengths end subroutine set_ecp_basis subroutine init_integrator_instance ( integrator , deriv_order ) & bind ( c , name = \"init_integrator_instance\" ) use iso_c_binding , only : c_int , c_ptr type ( c_ptr ), value :: integrator integer ( c_int ), value :: deriv_order end subroutine init_integrator_instance function compute_integrals ( integrator ) bind ( c , name = \"compute_integrals\" ) use iso_c_binding , only : c_ptr use libecp_result type ( ecp_result ) :: compute_integrals type ( c_ptr ), value :: integrator end function compute_integrals function compute_first_derivs ( integrator ) bind ( c , name = \"compute_first_derivs\" ) use iso_c_binding , only : c_ptr use libecp_result type ( ecp_result ) :: compute_first_derivs type ( c_ptr ), value :: integrator end function compute_first_derivs function compute_second_derivs ( integrator ) bind ( c , name = \"compute_second_derivs\" ) use iso_c_binding , only : c_ptr use libecp_result type ( ecp_result ) :: compute_second_derivs type ( c_ptr ), value :: integrator end function compute_second_derivs subroutine free_integrator ( integrator ) bind ( c , name = \"free_integrator\" ) use iso_c_binding , only : c_ptr type ( c_ptr ), value :: integrator end subroutine free_integrator subroutine free_result ( result ) bind ( c , name = \"free_result\" ) use libecp_result type ( ecp_result ), value :: result end subroutine free_result end interface end module libecpint_wrapper","tags":"","url":"sourcefile/ecpint.f90.html"},{"title":"int1e.F90 – OpenQP Fortran API","text":"Source Code module int1e_mod implicit none character ( len =* ), parameter :: module_name = \"int1e_mod\" private public int1e contains subroutine int1e_C ( c_handle ) bind ( C , name = \"int1e\" ) use c_interop , only : oqp_handle_t , oqp_handle_get_info use types , only : information type ( oqp_handle_t ) :: c_handle type ( information ), pointer :: inf inf => oqp_handle_get_info ( c_handle ) call int1e ( inf ) end subroutine int1e_C !> @brief Calculate the basic H, S, and T 1e-integrals subroutine int1e ( infos ) use types , only : information use oqp_tagarray_driver use precision , only : dp use io_constants , only : iw use constants , only : tol_int use int1 , only : omp_hst use basis_tools , only : basis_set use printing , only : print_sym_labeled use messages , only : show_message , WITH_ABORT use strings , only : Cstring , fstring use physical_constants , only : BOHR_TO_ANGSTROM use printing , only : print_module_info use qmmm_mod , only : oqp_esp_qmmm use dk_scalar_mod , only : dk_scalar implicit none character ( len =* ), parameter :: subroutine_name = \"int1e\" type ( information ), target , intent ( inout ) :: infos type ( basis_set ), pointer :: basis real ( kind = dp ) :: tol integer :: i , nbf , nat , nbf2 , dk ! tagarray real ( kind = dp ), contiguous , pointer :: & hcore (:), tmat (:), smat (:), Hqmmm (:), mm_potential (:) character ( len =* ), parameter :: tags_general ( 3 ) = ( / character ( len = 80 ) :: & OQP_SM , OQP_TM , OQP_Hcore / ) character ( len =* ), parameter :: tags_stale ( 1 ) = ( / character ( len = 80 ) :: & OQP_QMAT / ) character ( len =* ), parameter :: tags_qmmm ( 2 ) = ( / character ( len = 80 ) :: & OQP_mm_potential , OQP_Hqmmm / ) logical dbg dbg = . false . dk = infos % control % scal_rel !   Files open: !   LOG: Read and Write: Main output file open ( unit = iw , file = infos % log_filename , position = \"append\" ) !   Load basis set basis => infos % basis basis % atoms => infos % atoms ! call print_module_info ( 'int1e' , 'Computing H, S and T Matrices' ) !   Print out the Cartesian Coordinates. write ( iw , fmt = \"(& &/21X,32('=')& &/21X,a& &/21X,32('=')& &/8X,'ATOM     ZNUC',11X,'X',14X,'Y',14X,'Z'& &/6X,62('-'))\" ) \"Cartesian Coordinate in Angstrom\" do i = 1 , size ( basis % atoms % zn (:)) write ( iw , '(7x,i4,5x,f4.1,3(x,f15.9))' ) & i , basis % atoms % zn ( i ), basis % atoms % xyz ( 1 : 3 , i ) * BOHR_TO_ANGSTROM end do !   Allocate H, S and T matrices nbf2 = basis % nbf * ( basis % nbf + 1 ) / 2 nat = ubound ( infos % atoms % zn , 1 ) !   The overlap matrix changes, so the cached Q = S&#94;(-1/2) is stale call infos % dat % erase ( tags_stale ) !   Allocate H, S and T and bind typed pointers (one call each). alloc_or_die !   allocates or reuses in place, so the Python-set OQP_mm_potential tagarray is !   preserved (only the stale SM/TM/Hcore/Q records are refreshed here). call infos % dat % alloc_or_die ( OQP_SM , ( / nbf2 / ), smat , description = OQP_SM_comment ) call infos % dat % alloc_or_die ( OQP_TM , ( / nbf2 / ), tmat , description = OQP_TM_comment ) call infos % dat % alloc_or_die ( OQP_Hcore , ( / nbf2 / ), hcore , description = OQP_Hcore_comment ) !   Create arrays of atomic coordinates and charges for one-electron code nbf = basis % nbf nat = ubound ( infos % atoms % zn , 1 ) !   Compute conventional H, S, and T integrals tol = log ( 1 0.0d0 ) * tol_int call omp_hst ( basis , infos % atoms % xyz , infos % atoms % zn - infos % basis % ecp_zn_num , hcore , smat , tmat ,& logtol = tol , comm = infos % mpiinfo % comm , usempi = infos % mpiinfo % usempi ) !   Compute QM/MM interaction !    if(infos%control%qmmm_flag) then !       call infos%dat%reserve_data(OQP_Hqmmm, TA_TYPE_REAL64, nbf2, comment=OQP_Hqmmm_comment) !       call data_has_tags(infos%dat, tags_qmmm, module_name, subroutine_name, WITH_ABORT) !       call tagarray_get_data(infos%dat, OQP_Hqmmm, Hqmmm) !       call tagarray_get_data(infos%dat, OQP_mm_potential, mm_potential) ! !       write(iw,\"(/1X,'  Computing ESP One Electron Integrals (QM/MM) '/)\") !       write(iw,\"('External MM potential:'/)\") !       do i=1,nat !          write(iw,\"(i4,1X,f12.8)\") i, mm_potential(i) !       end do !!   Compute QM/MM contribution to core Hamiltonian !!       call oqp_esp_qmmm(infos, Hqmmm, mm_potential, smat, logtol=tol) !!   Add QM/MM contribution to core Hamiltonian !       hcore = hcore + hqmmm !       write(iw,\"(/1X,'  ... End of ESP One Electron Integrals ... '/)\") !    endif !   Douglas-Kroll scalar-relativistic correction to the core Hamiltonian (SOC) if ( dk . gt . 0 ) call dk_scalar ( infos ) if ( dbg ) then if ( infos % control % qmmm_flag ) then write ( iw , '(/\"BARE NUCLEUS HAMILTONIAN INTEGRALS (H=T+V+QM/MM)\")' ) else write ( iw , '(/\"BARE NUCLEUS HAMILTONIAN INTEGRALS (H=T+V)\")' ) end if call print_sym_labeled ( hcore , nbf , basis ) write ( iw , '(/\"OVERLAP MATRIX\")' ) call print_sym_labeled ( Smat , nbf , basis ) write ( iw , '(/\"KINETIC ENERGY INTEGRALS\")' ) call print_sym_labeled ( tmat , nbf , basis ) if ( infos % control % qmmm_flag ) then write ( iw , '(/\"QM/MM HAMILTONIAN INTEGRALS\")' ) call print_sym_labeled ( Hqmmm , nbf , basis ) end if end if write ( iw , \"(/1X,'...... End Of One Electron Integrals ......'/)\" ) close ( iw ) end subroutine int1e end module int1e_mod","tags":"","url":"sourcefile/int1e.f90.html"},{"title":"nmr_shielding.F90 – OpenQP Fortran API","text":"Source Code module nmr_shielding_mod implicit none character ( len =* ), parameter :: module_name = \"nmr_shielding_mod\" private public nmr_shielding contains subroutine nmr_shielding_C ( c_handle ) bind ( C , name = \"nmr_shielding\" ) use c_interop , only : oqp_handle_t , oqp_handle_get_info use types , only : information type ( oqp_handle_t ) :: c_handle type ( information ), pointer :: inf inf => oqp_handle_get_info ( c_handle ) call nmr_shielding ( inf ) end subroutine nmr_shielding_C !> @brief NMR nuclear magnetic shielding tensors. !> @details Current validated scope: RHF and closed-shell DFT, common gauge !>  origin (CGO). The user-facing Python layer recognizes `properties.nmr_gauge` !>  with CGO as the default and GIAO as a gated development option; GIAO NMR !>  shielding is not yet validated and does not enter this Fortran CGO pathway. !>  the uncoupled and the coupled (CPHF/CPKS) paramagnetic responses are reported. !>  The coupled response includes the exact-exchange response of the imaginary !>  antisymmetric first-order magnetic density (Phase 0); the Coulomb and !>  semi-local XC-kernel responses vanish by symmetry, so the coupling is exact !>  exchange scaled by the exchange fraction c_x (zero for pure functionals, where !>  coupled == uncoupled). The isotropic shielding is sigma = sigma_dia + !>  sigma_para per nucleus. !> !> Phase-0 validation (H2O/STO-3G, CGO at COM; common-gauge reference values in !> tests/fixtures/nmr/cgo_reference.json): !>   - HF coupled para matches the oracle exactly (O -230.63, H 3.506 ppm). !>   - Coulomb response of P&#94;B ~0; exact-exchange response nonzero (gates 1-2). !>   - Pure PBE: coupled == uncoupled (gate 3). HF/hybrid coupled != uncoupled, !>     with the coupling scaling with c_x (gates 4, 6). !> !> Validation (H2O/STO-3G, RHF, CGO at the center of mass; reference values): !>   - Diamagnetic term matches the standard common-gauge diamagnetic to ~6 significant !>     figures (O 411.418, H 28.062 ppm). !>   - Paramagnetic term (MO transform of the orbital-Zeeman and PSO operators, !>     occupied-virtual sum-over-states, 2*alpha&#94;2 prefactor) matches the reference !>     uncoupled reference for BOTH atoms (O para -113.63, H para 1.785 ppm; !>     totals 297.79 / 29.85 ppm). !>   - The PSO operator is anti-Hermitian; `pso_integrals` returns it exactly !>     antisymmetric (max|diag| and max|A+A&#94;T| are reported below as a check). subroutine nmr_shielding ( infos ) use io_constants , only : iw use oqp_tagarray_driver use basis_tools , only : basis_set use messages , only : show_message , with_abort use types , only : information use int1 , only : angular_momentum_integrals , nmr_dia_shielding , pso_integrals implicit none character ( len =* ), parameter :: subroutine_name = \"nmr_shielding\" ! CODATA fine-structure constant and derived prefactors real ( kind = 8 ), parameter :: ALPHA = 1.0d0 / 13 7.035999084d0 real ( kind = 8 ), parameter :: halfa2 = 0.5d0 * ALPHA * ALPHA real ( kind = 8 ), parameter :: twoa2 = 2.0d0 * ALPHA * ALPHA real ( kind = 8 ), parameter :: PPM = 1.0d6 type ( information ), target , intent ( inout ) :: infos integer :: nbf , nbf2 , ok logical :: urohf type ( basis_set ), pointer :: basis real ( kind = 8 ), allocatable :: amom (:,:) ! packed Lx,Ly,Lz (lower triangle) real ( kind = 8 ), allocatable :: lfull (:,:,:) ! full antisymmetric (nbf,nbf,3) real ( kind = 8 ), allocatable :: gdia (:,:,:) ! diamagnetic contracted integrals (3,3,nat) real ( kind = 8 ), allocatable :: sig_dia (:,:,:) ! diamagnetic shielding tensor (3,3,nat) real ( kind = 8 ), allocatable :: coords (:,:) ! nuclear coordinates (3,nat) real ( kind = 8 ), allocatable :: siso_dia (:) ! isotropic diamagnetic shielding (ppm) real ( kind = 8 ), allocatable :: pso_full (:,:,:) ! full antisymmetric PSO (nbf,nbf,3) real ( kind = 8 ), allocatable :: moL (:,:,:) ! orbital Zeeman in MO basis (nmo,nmo,3) real ( kind = 8 ), allocatable :: moP (:,:,:) ! PSO in MO basis (nmo,nmo,3) real ( kind = 8 ), allocatable :: sig_para (:,:,:) ! paramagnetic shielding tensor (3,3,nat) real ( kind = 8 ), allocatable :: siso_para (:), siso_tot (:) ! Phase 0: coupled (CPHF/CPKS) magnetic response real ( kind = 8 ), allocatable :: rcoup (:,:) ! coupled response vectors (lvir,3) real ( kind = 8 ), allocatable :: sig_para_c (:,:,:), siso_para_c (:), siso_tot_c (:) real ( kind = 8 ) :: scale_exch , pb_asym , jnorm , knorm integer :: nvir , lvir logical :: is_dft real ( kind = 8 ) :: o ( 3 ), com ( 3 ), trg , pso_diag_max , pso_asym_max integer :: nat , i , c , t , s , nocc , nmo real ( kind = 8 ), contiguous , pointer :: dmat_a (:) real ( kind = 8 ), contiguous , pointer :: mo_a (:,:) real ( kind = 8 ), contiguous , pointer :: mo_e_a (:) integer ( 4 ) :: status urohf = infos % control % scftype == 2 . or . infos % control % scftype == 3 open ( unit = IW , file = infos % log_filename , position = \"append\" ) basis => infos % basis basis % atoms => infos % atoms nbf = basis % nbf nbf2 = nbf * ( nbf + 1 ) / 2 write ( iw , '(2/)' ) write ( iw , '(4x,a)' ) '======================================' write ( iw , '(4x,a)' ) 'NMR nuclear magnetic shielding (CGO)' write ( iw , '(4x,a)' ) '======================================' write ( iw , '(4x,a)' ) 'Gauge formulation: CGO (common gauge origin). For gauge-origin-' // & 'independent results use properties.nmr_gauge=giao.' call flush ( iw ) if ( urohf ) then call show_message ( 'NMR shielding currently supports closed-shell & &(RHF / pure-DFT) references only' , with_abort ) end if ! Not-implemented classes must abort instead of silently producing wrong ! shieldings: !  - CAM/range-separated hybrids: the coupled magnetic response and the !    two-electron derivative use the global exchange fraction only; the !    range-separation attenuation (alpha/beta/mu) is not wired in. !  - meta-GGAs: the tau channel of the XC response is not implemented. !  - ECP: no effective-core magnetic-derivative term is implemented. if ( infos % control % hamilton == 20 ) then if ( infos % dft % cam_flag ) then call show_message ( 'NMR shielding with range-separated (CAM) functionals & &is not implemented' , with_abort ) end if if ( infos % functional % needtau ) then call show_message ( 'NMR shielding with meta-GGA (tau-dependent) functionals & &is not implemented' , with_abort ) end if end if if ( allocated ( infos % basis % ecp_zn_num )) then if ( any ( infos % basis % ecp_zn_num /= 0 )) then call show_message ( 'NMR shielding with ECP basis sets is not implemented' , & with_abort ) end if end if ! Confirm the SCF density is present (used by later stages) call tagarray_get_data ( infos % dat , OQP_DM_A , dmat_a , status ) call check_status ( status , module_name , subroutine_name , OQP_DM_A ) ! Gauge origin: center of mass (default) nat = ubound ( basis % atoms % zn , 1 ) com = 0 do i = 1 , nat com = com + basis % atoms % xyz (:, i ) * basis % atoms % mass ( i ) end do com = com / sum ( basis % atoms % mass ) o = com write ( iw , '(/4x,a)' ) 'Gauge origin (Bohr):' write ( iw , '(4x,a,3f15.8)' ) 'O = ' , o ! Angular momentum integrals about the gauge origin (packed, antisymmetric) allocate ( amom ( nbf2 , 3 ), source = 0.0d0 , stat = ok ) if ( ok /= 0 ) call show_message ( 'Cannot allocate memory' , WITH_ABORT ) call angular_momentum_integrals ( basis , amom , o ) ! Expand each component to a full antisymmetric nbf x nbf matrix (the ! orbital-Zeeman / magnetic-field perturbation used by the paramagnetic term). allocate ( lfull ( nbf , nbf , 3 ), source = 0.0d0 , stat = ok ) if ( ok /= 0 ) call show_message ( 'Cannot allocate memory' , WITH_ABORT ) do c = 1 , 3 call expand_antisym ( amom (:, c ), lfull (:,:, c ), nbf ) end do !------------------------------------------------------------------------- ! Diamagnetic term !   sigma&#94;dia_{ts}(N) = (alpha&#94;2/2) [ delta_ts*Tr(g&#94;N) - g&#94;N_{s,t} ] ! where g&#94;N_{ab} = sum_{mu,nu} P_{mu,nu} <mu|(r-O)_a (r-R_N)_b/|r-R_N|&#94;3|nu> !------------------------------------------------------------------------- allocate ( gdia ( 3 , 3 , nat ), coords ( 3 , nat ), source = 0.0d0 , stat = ok ) if ( ok /= 0 ) call show_message ( 'Cannot allocate memory' , WITH_ABORT ) do i = 1 , nat coords (:, i ) = basis % atoms % xyz (:, i ) end do call nmr_dia_shielding ( basis , dmat_a , o , coords , nat , gdia ) allocate ( sig_dia ( 3 , 3 , nat ), siso_dia ( nat ), source = 0.0d0 ) do i = 1 , nat trg = gdia ( 1 , 1 , i ) + gdia ( 2 , 2 , i ) + gdia ( 3 , 3 , i ) do t = 1 , 3 do s = 1 , 3 sig_dia ( t , s , i ) = halfa2 * ( merge ( trg , 0.0d0 , t == s ) - gdia ( s , t , i )) end do end do siso_dia ( i ) = ( sig_dia ( 1 , 1 , i ) + sig_dia ( 2 , 2 , i ) + sig_dia ( 3 , 3 , i )) / 3.0d0 * PPM end do !------------------------------------------------------------------------- ! Paramagnetic term (uncoupled; exact CPKS for pure functionals/HF-uncoupled) !   sigma&#94;para_{xy}(N) = 2 alpha&#94;2 sum_{i occ, a vir} !                          MO_x(a,i) * PSO&#94;N_y(i,a) / (eps_a - eps_i) ! MO_x = C&#94;T A_O[x] C  (orbital Zeeman, angular momentum about O) ! PSO&#94;N_y = C&#94;T A_PSO&#94;N[y] C !------------------------------------------------------------------------- call tagarray_get_data ( infos % dat , OQP_VEC_MO_A , mo_a , status ) call check_status ( status , module_name , subroutine_name , OQP_VEC_MO_A ) call tagarray_get_data ( infos % dat , OQP_E_MO_A , mo_e_a , status ) call check_status ( status , module_name , subroutine_name , OQP_E_MO_A ) nocc = int ( infos % mol_prop % nocc ) nmo = size ( mo_e_a ) ! Orbital-Zeeman operator in MO basis (3 components) allocate ( moL ( nmo , nmo , 3 ), source = 0.0d0 ) do c = 1 , 3 call ao_to_mo ( lfull (:,:, c ), mo_a , moL (:,:, c ), nbf , nmo ) end do ! ---------------------------------------------------------------------- ! Phase 0: coupled magnetic response (CPHF/CPKS). ! The first-order magnetic density is imaginary/antisymmetric, so the ! Coulomb and (semi-local) XC-kernel responses vanish; only the exact ! exchange response survives, scaled by the exchange fraction c_x. For ! pure functionals (c_x = 0) the coupled response equals the uncoupled one. ! ---------------------------------------------------------------------- nvir = nmo - nocc lvir = nocc * nvir is_dft = infos % control % hamilton == 20 scale_exch = 1.0d0 if ( is_dft ) scale_exch = infos % dft % HFscale allocate ( rcoup ( lvir , 3 ), source = 0.0d0 ) call compute_coupled_para ( infos , basis , mo_a , mo_e_a , nocc , nbf , nvir , & moL , scale_exch , rcoup , pb_asym , jnorm , knorm ) allocate ( pso_full ( nbf , nbf , 3 ), moP ( nmo , nmo , 3 ), source = 0.0d0 ) allocate ( sig_para ( 3 , 3 , nat ), siso_para ( nat ), siso_tot ( nat ), source = 0.0d0 ) allocate ( sig_para_c ( 3 , 3 , nat ), siso_para_c ( nat ), siso_tot_c ( nat ), source = 0.0d0 ) pso_diag_max = 0.0d0 pso_asym_max = 0.0d0 do i = 1 , nat ! Full antisymmetric PSO matrices A_a = [(r-R_N) x grad]_a/|r-R_N|&#94;3 call pso_integrals ( basis , coords (:, i ), pso_full ) do c = 1 , 3 ! Diagnostics: the PSO operator is anti-Hermitian, so the diagonal and ! the symmetric part must vanish. do t = 1 , nbf pso_diag_max = max ( pso_diag_max , abs ( pso_full ( t , t , c ))) do s = 1 , nbf pso_asym_max = max ( pso_asym_max , abs ( pso_full ( t , s , c ) + pso_full ( s , t , c ))) end do end do call ao_to_mo ( pso_full (:,:, c ), mo_a , moP (:,:, c ), nbf , nmo ) end do do t = 1 , 3 do s = 1 , 3 sig_para ( t , s , i ) = twoa2 * sum_ov ( moL (:,:, t ), moP (:,:, s ), mo_e_a , nocc , nmo ) sig_para_c ( t , s , i ) = - twoa2 * sum_resp ( rcoup (:, t ), moP (:,:, s ), nocc , nvir ) end do end do siso_para ( i ) = ( sig_para ( 1 , 1 , i ) + sig_para ( 2 , 2 , i ) + sig_para ( 3 , 3 , i )) / 3.0d0 * PPM siso_tot ( i ) = siso_dia ( i ) + siso_para ( i ) siso_para_c ( i ) = ( sig_para_c ( 1 , 1 , i ) + sig_para_c ( 2 , 2 , i ) + sig_para_c ( 3 , 3 , i )) / 3.0d0 * PPM siso_tot_c ( i ) = siso_dia ( i ) + siso_para_c ( i ) end do write ( iw , '(/4x,a,f8.4,a)' ) 'Isotropic shielding (CGO, ppm)   [exact-exchange c_x =' , & scale_exch , ']' write ( iw , '(4x,a)' ) '   Atom    Z   sigma_dia   para_uncoupled   para_coupled' // & '   total_uncoupled   total_coupled' do i = 1 , nat write ( iw , '(4x,i6,f6.1,5f16.6)' ) i , basis % atoms % zn ( i ), & siso_dia ( i ), siso_para ( i ), siso_para_c ( i ), siso_tot ( i ), siso_tot_c ( i ) end do ! ---- Store isotropic shielding (ppm) to a tagarray for JSON output ---- block real ( kind = 8 ), contiguous , pointer :: nmrout (:) call infos % dat % alloc_or_die ( OQP_nmr_shielding , ( / 5 * nat / ), nmrout , & description = OQP_nmr_shielding_comment ) do i = 1 , nat nmrout ( 5 * ( i - 1 ) + 1 ) = siso_dia ( i ) nmrout ( 5 * ( i - 1 ) + 2 ) = siso_para ( i ) nmrout ( 5 * ( i - 1 ) + 3 ) = siso_para_c ( i ) nmrout ( 5 * ( i - 1 ) + 4 ) = siso_tot ( i ) nmrout ( 5 * ( i - 1 ) + 5 ) = siso_tot_c ( i ) end do end block ! ---- Phase-0 validation gates (reported as diagnostics) ---- write ( iw , '(/4x,a)' ) 'Phase-0 magnetic-response gates:' write ( iw , '(4x,a,es12.3)' ) '  gate0  max|P&#94;B + (P&#94;B)&#94;T|        = ' , pb_asym write ( iw , '(4x,a,es12.3)' ) '  gate1  ||J(P&#94;B)|| (Coulomb)      = ' , jnorm write ( iw , '(4x,a,es12.3)' ) '  gate2  ||K(P&#94;B)|| (exact exch.)  = ' , knorm write ( iw , '(4x,a,2es12.3)' ) '  PSO    max|diag|, max|A+A&#94;T|    = ' , & pso_diag_max , pso_asym_max call flush ( iw ) deallocate ( amom , lfull , gdia , coords , sig_dia , siso_dia ) deallocate ( pso_full , moL , moP , sig_para , siso_para , siso_tot ) deallocate ( rcoup , sig_para_c , siso_para_c , siso_tot_c ) close ( iw ) end subroutine nmr_shielding !> @brief Expand a packed lower-triangular antisymmetric matrix to full form. !> @details Packed storage holds the bra>=ket elements A(p,q) (p>=q) at index !>  q + p*(p-1)/2. The full matrix satisfies A(q,p) = -A(p,q), zero diagonal. subroutine expand_antisym ( packed , full , n ) real ( kind = 8 ), intent ( in ) :: packed (:) real ( kind = 8 ), intent ( out ) :: full (:,:) integer , intent ( in ) :: n integer :: p , q , idx full = 0.0d0 do p = 1 , n do q = 1 , p idx = q + p * ( p - 1 ) / 2 full ( p , q ) = packed ( idx ) full ( q , p ) = - packed ( idx ) end do end do end subroutine expand_antisym !> @brief Transform a full AO matrix to the MO basis: M = C&#94;T A C. subroutine ao_to_mo ( a_ao , c , m_mo , nbf , nmo ) real ( kind = 8 ), intent ( in ) :: a_ao (:,:) ! (nbf,nbf) real ( kind = 8 ), intent ( in ) :: c (:,:) ! (nbf,nmo) real ( kind = 8 ), intent ( out ) :: m_mo (:,:) ! (nmo,nmo) integer , intent ( in ) :: nbf , nmo real ( kind = 8 ), allocatable :: tmp (:,:) allocate ( tmp ( nbf , nmo )) tmp = matmul ( a_ao , c (:, 1 : nmo )) m_mo = matmul ( transpose ( c (:, 1 : nmo )), tmp ) deallocate ( tmp ) end subroutine ao_to_mo !> @brief Occupied-virtual sum-over-states contraction !>   sum_{i occ, a vir} L(a,i) * P(i,a) / (eps_a - eps_i) function sum_ov ( lmo , pmo , e , nocc , nmo ) result ( val ) real ( kind = 8 ), intent ( in ) :: lmo (:,:), pmo (:,:), e (:) integer , intent ( in ) :: nocc , nmo real ( kind = 8 ) :: val integer :: i , a val = 0.0d0 do i = 1 , nocc do a = nocc + 1 , nmo val = val + lmo ( a , i ) * pmo ( i , a ) / ( e ( a ) - e ( i )) end do end do end function sum_ov !> @brief Contract a coupled response vector (occ-vir, length nocc*nvir, packed !>  as k=(a-1)*nocc+i to match iatogen) with the PSO occ-vir block. function sum_resp ( rt , pmo , nocc , nvir ) result ( val ) real ( kind = 8 ), intent ( in ) :: rt (:) ! (nocc*nvir) real ( kind = 8 ), intent ( in ) :: pmo (:,:) ! PSO[s] in MO basis (nmo,nmo) integer , intent ( in ) :: nocc , nvir real ( kind = 8 ) :: val integer :: i , a , k val = 0.0d0 k = 0 do a = 1 , nvir do i = 1 , nocc k = k + 1 val = val + rt ( k ) * pmo ( i , nocc + a ) end do end do end function sum_resp !> @brief Build the antisymmetric AO first-order magnetic density from an !>  occ-vir response vector: pa = C * (av - av&#94;T) * C&#94;T, av(occ,vir) = rin. subroutine magnetic_pb_density ( mo , pa , av , nbf , nocc , rin ) use tdhf_lib , only : iatogen use mathlib , only : orthogonal_transform real ( kind = 8 ), intent ( in ) :: mo (:,:) real ( kind = 8 ), intent ( inout ), target :: pa (:,:,:) real ( kind = 8 ), intent ( inout ) :: av (:,:) integer , intent ( in ) :: nbf , nocc real ( kind = 8 ), intent ( in ) :: rin (:) call iatogen ( rin , av , nocc , nocc ) av = av - transpose ( av ) call orthogonal_transform ( 't' , nbf , mo , av , pa (:,:, 1 )) end subroutine magnetic_pb_density !> @brief Solve the coupled (CPHF/CPKS) magnetic response for the three field !>  components and report the Phase-0 gate diagnostics. !> @details Fixed-point solve of  (eps_a-eps_i) R + c_x*K[P&#94;B(R)] = b, !>  with b = orbital-Zeeman occ-vir block and K the exact-exchange image of the !>  antisymmetric first-order density. Coulomb (J) and the semi-local XC kernel !>  do not contribute (imaginary antisymmetric density). For c_x = 0 the loop is !>  skipped and R = b/(eps_a-eps_i) (uncoupled). subroutine compute_coupled_para ( infos , basis , mo , mo_e , nocc , nbf , nvir , & moL , scale_exch , rcoup , pb_asym , jnorm , knorm ) use int2_compute , only : int2_compute_t use tdhf_lib , only : int2_td_data_t , mntoia use types , only : information use basis_tools , only : basis_set use messages , only : show_message implicit none type ( information ), target , intent ( inout ) :: infos type ( basis_set ), intent ( in ) :: basis real ( kind = 8 ), intent ( in ) :: mo (:,:), mo_e (:), moL (:,:,:) integer , intent ( in ) :: nocc , nbf , nvir real ( kind = 8 ), intent ( in ) :: scale_exch real ( kind = 8 ), intent ( out ) :: rcoup (:,:) ! (lvir,3) real ( kind = 8 ), intent ( out ) :: pb_asym , jnorm , knorm integer , parameter :: maxit = 100 real ( kind = 8 ), parameter :: tol = 1.0d-9 , half = 0.5d0 real ( kind = 8 ), parameter :: kappa = 1.0d0 ! coupling sign (validated vs the reference) type ( int2_compute_t ) :: int2_driver type ( int2_td_data_t ), target :: kdat , kdat1 , jdat real ( kind = 8 ), allocatable , target :: pa (:,:,:) real ( kind = 8 ), allocatable :: av (:,:), bb (:,:), dd (:), gx (:), rprev (:), gao (:,:) integer :: lvir , t , i , a , k , it logical :: conv lvir = nocc * nvir allocate ( pa ( nbf , nbf , 1 ), av ( nbf , nbf ), gao ( nbf , nbf ), & bb ( lvir , 3 ), dd ( lvir ), gx ( lvir ), rprev ( lvir ), source = 0.0d0 ) ! RHS (orbital-Zeeman occ-vir block) and orbital-energy denominators do t = 1 , 3 k = 0 do a = 1 , nvir do i = 1 , nocc k = k + 1 bb ( k , t ) = moL ( i , nocc + a , t ) end do end do end do k = 0 do a = 1 , nvir do i = 1 , nocc k = k + 1 dd ( k ) = mo_e ( nocc + a ) - mo_e ( i ) end do end do do t = 1 , 3 rcoup (:, t ) = bb (:, t ) / dd ! uncoupled start end do call int2_driver % init ( basis , infos ) ! NMR uses the native Rys ERI path only; never route through libint. int2_driver % rys_only = . true . call int2_driver % set_screening () ! Coupled iteration (skipped for pure functionals, c_x = 0) if ( abs ( scale_exch ) > 1.0d-12 ) then kdat = int2_td_data_t ( d2 = pa , int_apb = . false ., int_amb = . true ., & tamm_dancoff = . false ., scale_exchange = scale_exch ) do t = 1 , 3 conv = . false . do it = 1 , maxit rprev = rcoup (:, t ) call magnetic_pb_density ( mo , pa , av , nbf , nocc , rcoup (:, t )) call int2_driver % run ( kdat ) gao = half * kdat % amb (:,:, 1 , 1 ) call mntoia ( gao , gx , mo , mo , nocc , nocc ) rcoup (:, t ) = ( bb (:, t ) - kappa * gx ) / dd if ( maxval ( abs ( rcoup (:, t ) - rprev )) < tol ) then conv = . true . exit end if end do if (. not . conv ) then call show_message ( 'WARNING: NMR coupled magnetic response (CPHF) did & &not converge within the iteration limit; shieldings may be inaccurate' ) end if end do end if ! ---- Gate diagnostics on the converged z-component first-order density ---- call magnetic_pb_density ( mo , pa , av , nbf , nocc , rcoup (:, 3 )) pb_asym = maxval ( abs ( pa (:,:, 1 ) + transpose ( pa (:,:, 1 )))) ! gate 0 jdat = int2_td_data_t ( d2 = pa , int_apb = . true ., int_amb = . false ., & tamm_dancoff = . false ., scale_exchange = 0.0d0 ) call int2_driver % run ( jdat ) jnorm = sqrt ( sum (( half * jdat % apb (:,:, 1 , 1 )) ** 2 )) ! gate 1 (Coulomb) kdat1 = int2_td_data_t ( d2 = pa , int_apb = . false ., int_amb = . true ., & tamm_dancoff = . false ., scale_exchange = 1.0d0 ) call int2_driver % run ( kdat1 ) knorm = sqrt ( sum (( half * kdat1 % amb (:,:, 1 , 1 )) ** 2 )) ! gate 2 (exchange) deallocate ( pa , av , gao , bb , dd , gx , rprev ) end subroutine compute_coupled_para end module nmr_shielding_mod","tags":"","url":"sourcefile/nmr_shielding.f90.html"},{"title":"get_states_overlap.F90 – OpenQP Fortran API","text":"Source Code !> @brief Module for calculating state overlaps !>        and derivative coupling matrix elements !> !> @date Aug 2024 !> !> @author Konstantin Komarov !> module get_state_overlap_mod implicit none character ( len =* ), parameter :: module_name = \"get_state_overlap_mod\" public get_states_overlap contains !> @brief C-interoperable wrapper for get_states_overlap !> !> @param[in] c_handle   C handle for the information structure !> subroutine get_state_overlap_C ( c_handle ) bind ( C , name = \"get_states_overlap\" ) use c_interop , only : oqp_handle_t , oqp_handle_get_info use types , only : information type ( oqp_handle_t ) :: c_handle type ( information ), pointer :: inf inf => oqp_handle_get_info ( c_handle ) call get_states_overlap ( inf ) end subroutine get_state_overlap_c !> @brief Main subroutine for calculating state overlaps !>        and derivative coupling matrix elements !> !> @param[in,out] infos   Information class containing molecule parameters !> subroutine get_states_overlap ( infos ) use precision , only : dp use io_constants , only : iw use oqp_tagarray_driver use types , only : information use strings , only : Cstring , fstring use basis_tools , only : basis_set use atomic_structure_m , only : atomic_structure use messages , only : show_message , with_abort use tdhf_mrsf_lib , only : mrsfxvec use util , only : measure_time implicit none character ( len =* ), parameter :: subroutine_name = \"get_states_overlap\" type ( information ), target , intent ( inout ) :: infos type ( basis_set ), pointer :: basis integer :: nstates , mrst , xvec_dim , nbf , ok , j integer :: noca , nocb , ndtlf real ( kind = dp ), allocatable , target :: bvec (:,:), bvec_old (:,:) ! Tagarray character ( len =* ), parameter :: tags_general ( * ) = ( / character ( len = 80 ) :: & OQP_td_bvec_mo_old , OQP_td_bvec_mo , OQP_overlap_mo / ) character ( len =* ), parameter :: tags_alloc ( * ) = ( / character ( len = 80 ) :: & OQP_nac / ) real ( kind = dp ), contiguous , pointer :: bvec_mo (:,:), bvec_mo_old (:,:), & nac_out (:,:), overlap_mo (:,:), td_states_phase (:), td_states_overlap (:,:) ! Files open open ( unit = IW , file = infos % log_filename , position = \"append\" ) ! Load basis set basis => infos % basis basis % atoms => infos % atoms nstates = infos % tddft % nstate mrst = infos % tddft % mult nbf = basis % nbf xvec_dim = infos % mol_prop % nelec_a * ( nbf - infos % mol_prop % nelec_b ) !   ndtlf = 0          less accurate !   ndtlf = 1 : tlf(1) !   ndtlf = 2 : tlf(2) most accurate ndtlf = infos % tddft % tlf ! Allocate data for outputing in python level call infos % dat % alloc_or_die ( OQP_td_states_phase , ( / nstates / ), td_states_phase , description = OQP_td_states_phase_comment ) call infos % dat % alloc_or_die ( OQP_td_states_overlap , ( / nstates , nstates / ), td_states_overlap , description = OQP_td_states_overlap_comment ) call infos % dat % alloc_or_die ( OQP_nac , ( / nstates , nstates / ), nac_out , description = OQP_nac_comment ) ! Load data from python level call data_has_tags ( infos % dat , tags_general , module_name , subroutine_name , with_abort ) call tagarray_get_data ( infos % dat , OQP_td_bvec_mo , bvec_mo ) call tagarray_get_data ( infos % dat , OQP_overlap_mo , overlap_mo ) call tagarray_get_data ( infos % dat , OQP_td_bvec_mo_old , bvec_mo_old ) allocate ( bvec ( xvec_dim , nstates ), & bvec_old ( xvec_dim , nstates ), & source = 0.0_dp , stat = ok ) if ( ok /= 0 ) call show_message ( 'Cannot allocate memory' , with_abort ) noca = infos % mol_prop % nelec_a nocb = infos % mol_prop % nelec_b do j = 1 , nstates call mrsfxvec ( infos , bvec_mo_old (:, j ), bvec_old (:, j )) call mrsfxvec ( infos , bvec_mo (:, j ), bvec (:, j )) end do call check_states_phase ( bvec , bvec_old , td_states_phase ) call compute_states_overlap ( & infos , overlap_mo , td_states_overlap , bvec , & bvec_old , nbf , noca , nocb , nstates , ndtlf ) call get_dcv ( nac_out , td_states_overlap , nstates ) !   call print_nac(infos, td_states_overlap, nac_out) !   Print timings call measure_time ( print_total = 1 , log_unit = iw ) call flush ( iw ) close ( iw ) end subroutine get_states_overlap subroutine check_states_phase ( Bvec , Bvec_old , td_states_phase ) use precision , only : dp use io_constants , only : iw implicit none real ( kind = dp ), dimension (:,:) :: Bvec real ( kind = dp ), dimension (:,:) :: Bvec_old real ( kind = dp ), dimension (:) :: td_states_phase integer :: i ! Get overlap and correct the sign of X amplitude before state tracking write ( iw , fmt = '(/x,a,/x,a,/7x,\"State  Overlap\")' ) & 'Check the sign of X amplitude' , & 'with respect to previous geometry' do i = 1 , ubound ( Bvec , 2 ) td_states_phase ( i ) = dot_product ( Bvec_old (:, i ), Bvec (:, i )) !     if (td_states_phase < 0.0d0) then !       Bvec(:,i) = -1.0d0*Bvec(:,i) !       td_states_phase = -1.0d0*td_states_phase !     endif write ( iw , fmt = '(6x,i4,x,f12.8)' ) i , td_states_phase ( i ) end do end subroutine !> @brief Compute overlap integrals between MRSF response states !>        at different MD time steps !> !> @details Fast overlap evaluations using the TLF approximation !>          introduced in JCTC 15 882 (2019) !> !> @author Seunghoon Lee, Konstantin Komarov !> !> @param[in] infos     Information structure !> @param[in] s_mo      Overlap matrix in MO basis !> @param[out] s_st     State overlap matrix !> @param[in] mo_a      MO coefficients at current time step !> @param[in] mo_a_old  MO coefficients at previous time step !> @param[in] nbf       Number of basis functions !> @param[in] noca      Number of occupied alpha orbitals !> @param[in] nocb      Number of occupied beta orbitals !> @param[in] nstates   Number of states !> @param[in] ndtlf     TLF approximation order !> subroutine compute_states_overlap (& infos , s_mo , s_st , mo_a , mo_a_old , & nbf , noca , nocb , nstates , ndtlf ) use precision , only : dp use types , only : information !$  use omp_lib implicit none type ( information ) :: infos real ( kind = dp ), intent ( inout ), dimension (:,:) :: s_st real ( kind = dp ), dimension ( noca , nbf - nocb , * ) :: mo_a , mo_a_old real ( kind = dp ), dimension (:,:) :: s_mo integer :: nbf , nstates , noca , nocb , ndtlf integer :: ni , oi , pi , qi , ri , si , i , & ioc , ioc1 , ioc2 , & ivir , joc , jvir , nvirb real ( kind = dp ), parameter :: sqrt2 = 1 / sqrt ( 2.0_dp ) real ( kind = dp ), allocatable , dimension (:,:,:) :: & alpham , betam , deltam , gammam real ( kind = dp ), allocatable , dimension (:,:) :: & s_ij , s_ab , s_ia nvirb = nbf - nocb allocate ( alpham ( nstates , noca , nvirb ), & betam ( nstates , noca , nvirb ), & deltam ( nstates , noca , noca ), & gammam ( nstates , noca , noca ), & s_ij ( noca , noca ), & s_ab ( nvirb , nvirb ), & s_ia ( noca , nvirb ), & source = 0.0_dp ) !   get S_ij, S_ab, S_ia call mrsf_tlf ( infos , s_mo , s_ij , s_ab , s_ia , ndtlf ) !$OMP PARALLEL DEFAULT(SHARED) PRIVATE(oi, ioc, ivir, jvir, ni, ioc1, ioc2, pi, qi, ri, si) !$OMP DO SCHEDULE(GUIDED) COLLAPSE(3) do oi = 1 , nstates do ioc = 1 , noca do ivir = 1 , nvirb alpham ( oi , ioc , ivir ) = 0.0_dp do jvir = 1 , nvirb if (( ioc > nocb ) . and . ( jvir <= 2 )) cycle alpham ( oi , ioc , ivir ) = alpham ( oi , ioc , ivir ) & + mo_a_old ( ioc , jvir , oi ) * s_ab ( jvir , ivir ) end do end do end do end do !$OMP END DO !$OMP DO SCHEDULE(GUIDED) COLLAPSE(3) do ni = 1 , nstates do ioc = 1 , noca do ivir = 1 , nvirb betam ( ni , ioc , ivir ) = 0.0_dp do joc = 1 , noca if (( joc > nocb ) . and . ( ivir <= 2 )) cycle betam ( ni , ioc , ivir ) = betam ( ni , ioc , ivir ) & + mo_a ( joc , ivir , ni ) * s_ij ( ioc , joc ) end do end do end do end do !$OMP END DO !$OMP DO SCHEDULE(GUIDED) COLLAPSE(3) do oi = 1 , nstates do ioc1 = 1 , noca do ioc2 = 1 , noca gammam ( oi , ioc1 , ioc2 ) = 0.0_dp do jvir = 1 , nvirb if (( ioc1 > nocb ) . and . ( jvir <= 2 )) cycle gammam ( oi , ioc1 , ioc2 ) = gammam ( oi , ioc1 , ioc2 ) & + mo_a_old ( ioc1 , jvir , oi ) * s_ia ( ioc2 , jvir ) end do end do end do end do !$OMP END DO !$OMP DO SCHEDULE(GUIDED) COLLAPSE(3) do ni = 1 , nstates do ioc1 = 1 , noca do ioc2 = 1 , noca deltam ( ni , ioc1 , ioc2 ) = 0.0_dp do jvir = 1 , nvirb if (( ioc2 > nocb ) . and . ( jvir <= 2 )) cycle deltam ( ni , ioc1 , ioc2 ) = deltam ( ni , ioc1 , ioc2 ) & + mo_a ( ioc2 , jvir , ni ) * s_ia ( ioc1 , jvir ) end do end do end do end do !$OMP END DO !$OMP DO SCHEDULE(GUIDED) COLLAPSE(3) REDUCTION(+:s_st) ! 4 index summation do oi = 1 , nstates do ni = 1 , nstates do pi = nocb + 1 , noca do qi = nocb + 1 , noca do ri = nocb + 1 , noca do si = nocb + 1 , noca s_st ( oi , ni ) = s_st ( oi , ni ) & + mo_a_old ( pi , qi - nocb , oi ) * s_ij ( pi , ri ) & * mo_a ( ri , si - nocb , ni ) * s_ab ( qi - nocb , si - nocb ) end do end do end do end do end do end do !$OMP END DO !$OMP DO SCHEDULE(GUIDED) COLLAPSE(3) REDUCTION(+:s_st) do oi = 1 , nstates do ni = 1 , nstates do pi = nocb + 1 , noca do qi = nocb + 1 , noca do ri = 1 , noca do si = nocb + 1 , nbf if (( ri >= nocb + 1 ) . and . ( si <= noca )) cycle s_st ( oi , ni ) = s_st ( oi , ni ) & + mo_a_old ( pi , qi - nocb , oi ) * mo_a ( ri , si - nocb , ni ) & * ( s_ij ( pi , ri ) * s_ab ( qi - nocb , si - nocb ) & + s_ia ( pi , si - nocb ) * s_ia ( ri , qi - nocb ) ) * sqrt2 end do end do end do end do end do end do !$OMP END DO !$OMP DO SCHEDULE(GUIDED) COLLAPSE(3) REDUCTION(+:s_st) do oi = 1 , nstates do ni = 1 , nstates do pi = 1 , noca do qi = nocb + 1 , nbf if (( pi >= nocb + 1 ) . and . ( qi <= noca )) cycle do ri = nocb + 1 , noca do si = nocb + 1 , noca s_st ( oi , ni ) = s_st ( oi , ni ) & + mo_a_old ( pi , qi - nocb , oi ) * mo_a ( ri , si - nocb , ni ) & * ( s_ij ( pi , ri ) * s_ab ( qi - nocb , si - nocb ) & + s_ia ( pi , si - nocb ) * s_ia ( ri , qi - nocb ) ) * sqrt2 end do end do end do end do end do end do !$OMP END DO !$OMP DO SCHEDULE(GUIDED) COLLAPSE(3) REDUCTION(+:s_st) do oi = 1 , nstates do ni = 1 , nstates do ioc = 1 , noca do ivir = 1 , nvirb s_st ( oi , ni ) = s_st ( oi , ni ) & + alpham ( oi , ioc , ivir ) * betam ( ni , ioc , ivir ) end do end do end do end do !$OMP END DO !$OMP DO SCHEDULE(GUIDED) COLLAPSE(3) REDUCTION(+:s_st) do oi = 1 , nstates do ni = 1 , nstates do ioc1 = 1 , noca do ioc2 = 1 , noca s_st ( oi , ni ) = s_st ( oi , ni ) & + gammam ( oi , ioc1 , ioc2 ) * deltam ( ni , ioc1 , ioc2 ) end do end do end do end do !$OMP END DO !$OMP END PARALLEL do i = 1 , nstates s_st (:, i ) = s_st (:, i ) / norm2 ( s_st (:, i )) end do end subroutine compute_states_overlap !> !>     @brief Compute overlap integrals between CSFs !>            of MRSF-TDDFT using TLF approximation !> !>     @details TLF approximation for SF- and LR-TDDFT !>              is introduced in JCTC 15 882 (2019) !> !>     @author Seunghoon Lee, Kostantin Komarov !> subroutine mrsf_tlf ( infos , s_mo , s_ij , s_ab , s_ia , ndtlf ) use precision , only : dp use types , only : information implicit none type ( information ), intent ( in ) :: infos real ( kind = dp ), intent ( in ), dimension (:,:) :: s_mo real ( kind = dp ), intent ( out ), dimension (:,:) :: s_ij real ( kind = dp ), intent ( out ), dimension (:,:) :: s_ab real ( kind = dp ), intent ( out ), dimension (:,:) :: s_ia integer , intent ( in ) :: ndtlf integer :: nbf , noca , nocb , nvirb , noc integer :: i , i1 , i2 , ia1 , ia2 , j1 , j2 real ( kind = dp ) :: precomp , temp1 , temp2 , tmp , tmp1 , tmp2 nbf = infos % basis % nbf noca = infos % mol_prop % nelec_a nocb = infos % mol_prop % nelec_b nvirb = nbf - nocb noc = noca - 1 i1 = 0 i2 = 0 ia1 = 0 ia2 = 0 select case ( ndtlf ) case ( 0 ) !     alpha determinant do i1 = 1 , noca do i2 = 1 , noca call ov_exact ( temp1 , i1 , i2 , ia1 , ia2 , s_mo , 1 , noc , 1 ) s_ij ( i1 , i2 ) = temp1 end do end do !     1-2 det do j1 = 1 , nvirb ia1 = nocb + j1 do j2 = 1 , nvirb ia2 = nocb + j2 call ov_exact ( temp2 , i1 , i2 , ia1 , ia2 , s_mo , 1 , noc , 2 ) s_ab ( j1 , j2 ) = temp2 end do end do case ( 1 ) precomp = 1.0_dp do i = 1 , noca precomp = precomp * s_mo ( i , i ) end do !     alpha determinant do i1 = 1 , noca do i2 = 1 , noca call tlf_exp ( tmp , 11 , i1 , i2 , s_mo , precomp , noca , nbf ) if ( i1 /= i2 ) then tmp = - 1.0_dp * tmp end if s_ij ( i1 , i2 ) = tmp end do end do precomp = 1.0_dp do i = 1 , noca - 2 precomp = precomp * s_mo ( i , i ) end do !     1-2 det do j1 = 1 , nvirb ia1 = nocb + j1 do j2 = 1 , nvirb ia2 = nocb + j2 call tlf_exp ( tmp , 21 , ia1 , ia2 , s_mo , precomp , noca , nbf ) s_ab ( j1 , j2 ) = tmp end do end do case ( 2 ) precomp = 1.0_dp do i = 1 , noca precomp = precomp * s_mo ( i , i ) enddo !     alpha determinant do i1 = 1 , noca do i2 = 1 , noca call tlf_exp ( tmp1 , 11 , i1 , i2 , s_mo , precomp , noca , nbf ) call tlf_exp ( tmp2 , 12 , i1 , i2 , s_mo , precomp , noca , nbf ) tmp = tmp1 + tmp2 if ( i1 /= i2 ) then tmp = - 1.0_dp * tmp end if s_ij ( i1 , i2 ) = tmp end do end do precomp = 1.d+00 do i = 1 , noca - 2 precomp = precomp * s_mo ( i , i ) end do !     1-2 det do j1 = 1 , nvirb ia1 = nocb + j1 do j2 = 1 , nvirb ia2 = nocb + j2 call tlf_exp ( tmp1 , 21 , ia1 , ia2 , s_mo , precomp , noca , nbf ) call tlf_exp ( tmp2 , 22 , ia1 , ia2 , s_mo , precomp , noca , nbf ) s_ab ( j1 , j2 ) = tmp1 + tmp2 end do end do case default error stop \"Unknown TLF value (0,1,2)\" end select !   alpha determinant do i1 = 1 , noca do j1 = 1 , nvirb ia1 = nocb + j1 call ov_exact ( temp1 , i1 , i2 , ia1 , ia2 , s_mo , 1 , noc , 3 ) s_ia ( i1 , j1 ) = temp1 end do end do end subroutine mrsf_tlf subroutine ov_exact ( temp1 , i1 , i2 , ia1 , ia2 , s_mo , ilow , noc , itype ) use precision , only : dp implicit none real ( kind = dp ), intent ( out ) :: temp1 integer , intent ( in ) :: i1 , i2 , ia1 , ia2 real ( kind = dp ), intent ( in ), dimension (:,:) :: s_mo integer , intent ( in ) :: ilow , noc , itype real ( kind = dp ), dimension ( noc * noc ) :: ddet integer :: i , iipp , imax , imin , ipp select case ( itype ) case ( 1 ) if ( i1 == i2 ) then !     Diagonal element: principal minor with occupied orbital i1 deleted from !     both determinants. The off-diagonal block layout below assumes imin < imax !     and degenerates for i1 == i2: for i1 == 1 the (3,*)/(*,3) blocks start at !     index 0 (out-of-bounds ddet writes), and for i1 >= 2 the overlapping block !     writes delete orbital i1-1 instead of i1. do i = 1 , i1 - 1 do ipp = 1 , i1 - 1 iipp = ( ipp - 1 ) * noc + i ddet ( iipp ) = s_mo ( i + ilow - 1 , ipp + ilow - 1 ) end do do ipp = i1 , noc iipp = ( ipp - 1 ) * noc + i ddet ( iipp ) = s_mo ( i + ilow - 1 , ipp + 1 + ilow - 1 ) end do end do do i = i1 , noc do ipp = 1 , i1 - 1 iipp = ( ipp - 1 ) * noc + i ddet ( iipp ) = s_mo ( i + 1 + ilow - 1 , ipp + ilow - 1 ) end do do ipp = i1 , noc iipp = ( ipp - 1 ) * noc + i ddet ( iipp ) = s_mo ( i + 1 + ilow - 1 , ipp + 1 + ilow - 1 ) end do end do temp1 = comp_det ( ddet , noc ) return end if imin = min ( i1 , i2 ) imax = max ( i1 , i2 ) !  (1,1) block do i = 1 , imin - 1 do ipp = 1 , imin - 1 iipp = ( ipp - 1 ) * noc + i ddet ( iipp ) = s_mo ( i + ilow - 1 , ipp + ilow - 1 ) end do end do !  (1,2) block do i = 1 , imin - 1 do ipp = imin , imax - 2 iipp = ( ipp - 1 ) * noc + i ddet ( iipp ) = s_mo ( i + ilow - 1 , ipp + 1 + ilow - 1 ) end do end do !  (1,3) block do i = 1 , imin - 1 do ipp = imax - 1 , noc - 1 iipp = ( ipp - 1 ) * noc + i ddet ( iipp ) = s_mo ( i + ilow - 1 , ipp + 2 + ilow - 1 ) end do end do !  (2,1) block do i = imin , imax - 2 do ipp = 1 , imin - 1 iipp = ( ipp - 1 ) * noc + i ddet ( iipp ) = s_mo ( i + 1 + ilow - 1 , ipp + ilow - 1 ) end do end do !  (2,2) block do i = imin , imax - 2 do ipp = imin , imax - 2 iipp = ( ipp - 1 ) * noc + i ddet ( iipp ) = s_mo ( i + 1 + ilow - 1 , ipp + 1 + ilow - 1 ) end do end do !  (2,3) block do i = imin , imax - 2 do ipp = imax - 1 , noc - 1 iipp = ( ipp - 1 ) * noc + i ddet ( iipp ) = s_mo ( i + 1 + ilow - 1 , ipp + 2 + ilow - 1 ) end do end do !  (3,1) block do i = imax - 1 , noc - 1 do ipp = 1 , imin - 1 iipp = ( ipp - 1 ) * noc + i ddet ( iipp ) = s_mo ( i + 2 + ilow - 1 , ipp + ilow - 1 ) end do end do !  (3,2) block do i = imax - 1 , noc - 1 do ipp = imin , imax - 2 iipp = ( ipp - 1 ) * noc + i ddet ( iipp ) = s_mo ( i + 2 + ilow - 1 , ipp + 1 + ilow - 1 ) end do end do !  (3,3) block do i = imax - 1 , noc - 1 do ipp = imax - 1 , noc - 1 iipp = ( ipp - 1 ) * noc + i ddet ( iipp ) = s_mo ( i + 2 + ilow - 1 , ipp + 2 + ilow - 1 ) end do end do !  (1,4) block do i = 1 , imin - 1 do ipp = noc , noc iipp = ( ipp - 1 ) * noc + i ddet ( iipp ) = s_mo ( i + ilow - 1 , i1 + ilow - 1 ) end do end do !  (2,4) block do i = imin , imax - 2 do ipp = noc , noc iipp = ( ipp - 1 ) * noc + i ddet ( iipp ) = s_mo ( i + 1 + ilow - 1 , i1 + ilow - 1 ) end do end do !  (3,4) block do i = imax - 1 , noc - 1 do ipp = noc , noc iipp = ( ipp - 1 ) * noc + i ddet ( iipp ) = s_mo ( i + 2 + ilow - 1 , i1 + ilow - 1 ) end do end do !  (4,1) block do i = noc , noc do ipp = 1 , imin - 1 iipp = ( ipp - 1 ) * noc + i ddet ( iipp ) = s_mo ( i2 + ilow - 1 , ipp + ilow - 1 ) end do end do !  (4,2) block do i = noc , noc do ipp = imin , imax - 2 iipp = ( ipp - 1 ) * noc + i ddet ( iipp ) = s_mo ( i2 + ilow - 1 , ipp + 1 + ilow - 1 ) end do end do !  (4,3) block do i = noc , noc do ipp = imax - 1 , noc - 1 iipp = ( ipp - 1 ) * noc + i ddet ( iipp ) = s_mo ( i2 + ilow - 1 , ipp + 2 + ilow - 1 ) end do end do !  (4,4) block do i = noc , noc do ipp = noc , noc iipp = ( ipp - 1 ) * noc + i ddet ( iipp ) = s_mo ( i2 + ilow - 1 , i1 + ilow - 1 ) end do end do !  Calculate alpha determinant temp1 = comp_det ( ddet , noc ) if ( i1 == i2 ) then return else if ( i1 /= i2 ) then temp1 = - 1.0_dp * temp1 return endif case ( 2 ) !  (1,1) block do i = 1 , noc - 1 do ipp = 1 , noc - 1 iipp = ( ipp - 1 ) * noc + i ddet ( iipp ) = s_mo ( i + ilow - 1 , ipp + ilow - 1 ) end do end do !  (1,2) block ipp = noc do i = 1 , noc - 1 iipp = ( ipp - 1 ) * noc + i ddet ( iipp ) = s_mo ( i + ilow - 1 , ia2 ) end do !  (2,1) block i = noc do ipp = 1 , noc - 1 iipp = ( ipp - 1 ) * noc + i ddet ( iipp ) = s_mo ( ia1 , ipp + ilow - 1 ) end do !  (2,2) block i = noc ipp = noc iipp = ( ipp - 1 ) * noc + i ddet ( iipp ) = s_mo ( ia1 , ia2 ) !  Calculate 2 det temp1 = comp_det ( ddet , noc ) return case ( 3 ) !  (1,1) block do i = 1 , i1 - 1 do ipp = 1 , i1 - 1 iipp = ( ipp - 1 ) * noc + i ddet ( iipp ) = s_mo ( i , ipp ) end do end do !  (1,2) block do i = 1 , i1 - 1 do ipp = i1 , noc - 2 iipp = ( ipp - 1 ) * noc + i ddet ( iipp ) = s_mo ( i , ipp + 1 ) end do end do !  (1,3) block do i = 1 , i1 - 1 ipp = noc - 1 iipp = ( ipp - 1 ) * noc + i ddet ( iipp ) = s_mo ( i , i1 ) end do !  (1,4) block do i = 1 , i1 - 1 ipp = noc iipp = ( ipp - 1 ) * noc + i ddet ( iipp ) = s_mo ( i , ia1 ) end do !  (2,1) block do i = i1 , noc - 2 do ipp = 1 , i1 - 1 iipp = ( ipp - 1 ) * noc + i ddet ( iipp ) = s_mo ( i + 1 , ipp ) end do end do !  (2,2) block do i = i1 , noc - 2 do ipp = i1 , noc - 2 iipp = ( ipp - 1 ) * noc + i ddet ( iipp ) = s_mo ( i + 1 , ipp + 1 ) end do end do !  (2,3) block do i = i1 , noc - 2 ipp = noc - 1 iipp = ( ipp - 1 ) * noc + i ddet ( iipp ) = s_mo ( i + 1 , i1 ) end do !  (2,4) block do i = i1 , noc - 2 ipp = noc iipp = ( ipp - 1 ) * noc + i ddet ( iipp ) = s_mo ( i + 1 , ia1 ) end do !  (3,1) block i = noc - 1 do ipp = 1 , i1 - 1 iipp = ( ipp - 1 ) * noc + i ddet ( iipp ) = s_mo ( i + 1 , ipp ) end do !  (3,2) block i = noc - 1 do ipp = i1 , noc - 2 iipp = ( ipp - 1 ) * noc + i ddet ( iipp ) = s_mo ( i + 1 , ipp + 1 ) end do !  (3,3) block i = noc - 1 ipp = noc - 1 iipp = ( ipp - 1 ) * noc + i ddet ( iipp ) = s_mo ( i + 1 , i1 ) !  (3,4) block i = noc - 1 ipp = noc iipp = ( ipp - 1 ) * noc + i ddet ( iipp ) = s_mo ( i + 1 , ia1 ) !  (4,1) block i = noc do ipp = 1 , i1 - 1 iipp = ( ipp - 1 ) * noc + i ddet ( iipp ) = s_mo ( i + 1 , ipp ) end do !  (4,2) block i = noc do ipp = i1 , noc - 2 iipp = ( ipp - 1 ) * noc + i ddet ( iipp ) = s_mo ( i + 1 , ipp + 1 ) end do !  (4,3) block i = noc ipp = noc - 1 iipp = ( ipp - 1 ) * noc + i ddet ( iipp ) = s_mo ( i + 1 , i1 ) !  (4,4) block i = noc ipp = noc iipp = ( ipp - 1 ) * noc + i ddet ( iipp ) = s_mo ( i + 1 , ia1 ) !  Calculate alpha determinant temp1 = comp_det ( ddet , noc ) end select end subroutine ov_exact subroutine tlf_exp ( ov , itype , i1 , i2 , s_mo , precomp , noca , nbf ) use precision , only : dp implicit none real ( kind = dp ) :: ov , precomp integer :: i1 , i2 , itype , nbf , noca real ( kind = dp ), dimension ( nbf , nbf ) :: s_mo real ( kind = dp ) :: ov1 , ov2 integer :: ia1 , ia2 , l , lp !   itype=11 : alpha 1st order !   itype=21 : beta  1st order !   itype=12 : alpha 2nd order !   itype=22 : beta  2nd order select case ( itype ) case ( 11 ) ov = precomp * s_mo ( i2 , i1 ) / ( s_mo ( i1 , i1 ) * s_mo ( i2 , i2 )) return case ( 21 ) ia1 = i1 ia2 = i2 ov = precomp * s_mo ( ia1 , ia2 ) return case ( 12 ) if ( i1 /= i2 ) then ov = 0.0_dp do l = 1 , noca if ( l /= i1 . and . l /= i2 ) then ov = ov + s_mo ( i2 , l ) * s_mo ( l , i1 ) / s_mo ( l , l ) end if end do ov = - 1.0_dp * precomp * ov / ( s_mo ( i1 , i1 ) * s_mo ( i2 , i2 )) return else ov = 0.0_dp do l = 1 , noca - 1 if ( l /= i1 ) then do lp = l + 1 , noca if ( lp /= i1 ) then ov = ov + s_mo ( l , lp ) * s_mo ( lp , l ) / ( s_mo ( l , l ) * s_mo ( lp , lp )) end if end do end if end do ov = - 1.0_dp * precomp * ov / s_mo ( i1 , i1 ) return end if case ( 22 ) ia1 = i1 ia2 = i2 if ( ia1 /= ia2 ) then ov = 0.0_dp do l = 1 , noca - 2 ov = ov + s_mo ( ia1 , l ) * s_mo ( l , ia2 ) / s_mo ( l , l ) end do ov = - 1.0_dp * precomp * ov return else ov1 = 0.d+00 do l = 1 , noca - 2 ov1 = ov1 + s_mo ( ia1 , l ) * s_mo ( l , ia2 ) / s_mo ( l , l ) end do ov2 = 0.0_dp do l = 1 , noca - 3 do lp = l + 1 , noca - 2 ov2 = ov2 + s_mo ( l , lp ) * s_mo ( lp , l ) / ( s_mo ( l , l ) * s_mo ( lp , lp )) end do end do ov2 = ov2 * s_mo ( ia1 , ia1 ) ov = - 1.0_dp * precomp * ( ov1 + ov2 ) return end if case default error stop \"Unknown itype for tlf_exp\" end select end subroutine tlf_exp !> !> @brief Compute derivative coupling vectors (DCV) using the finite difference method, !>        typically denoted as d_IJ between states I and J. !> !>        d_IJ = <I| d/dR |J> = h_IJ / (E_I - E_J), !>        where h_IJ is the nonadiabatic coupling, defined as !>        h_IJ = <I| dH/dR |J>. !> !>        Note that R is an entire vector, and so is d_IJ. !> !>        This routine computes d_IJ&#94;a = <I| d/da |J>, which is a single component of d_IJ by TLF. !>        The component a can be either a geometric or a time derivative. !>        The geometric derivative is used to construct the DCV, while !>        the time derivative is used as NACME for nonadiabatic MD. !> !>        The d_IJ&#94;a is computed by numerical differentiation using !>        a first or second-order formula. In the case of first-order, !> !>        O_IJ = <I(a)|J(a+da)> = F, !>        O_IJ = <I(a+da)|J(a)> = B, !>        d_IJ&#94;a = (F - B) / a, !>        where O_IJ_F and O_IJ_B are the state overlaps. !> !>        This routine returns d_IJ&#94;a * a = F - B. !>        The denominator MUST be provided in subsequent calculations !>        because it can be 2 * a in the case of second-order !>        numerical differentiation formula. Also, a can be either a time !>        or geometric parameter. !> !>        https://pubs.acs.org/doi/full/10.1021/acs.jctc.8b01049, !> !>     @author Seunghoon Lee, Konstantin Komarov !> subroutine get_dcv ( nact , s_st , nstates ) use precision , only : dp use io_constants , only : iw implicit none integer :: nstates real ( kind = dp ), dimension ( nstates , * ) :: nact , s_st integer :: i , j logical :: debug = . true . if ( debug ) write ( iw , & fmt = '(/x/,a,/29x,\" F              B          F - B\")' ) & '  F = <I(a)|J(a+da)>,  B = <I(a+da)|J(a)>, where a is variable.' do i = 1 , nstates do j = 1 , nstates nact ( i , j ) = ( s_st ( i , j ) - s_st ( j , i )) if ( debug ) write ( iw , & fmt = '(x,a,i0,a,i0,a,i0,a,i0,a,f12.8,a,f12.8,f12.8)' ) & \"<S\" , i , \"|S\" , j , \"> and <S\" , j , \"|S\" , i , \"> = \" , s_st ( I , J ), & \" and\" , s_st ( J , I ), nact ( i , j ) end do end do end subroutine get_dcv !>  This routine calculates the determinate of a square matrix. !>  Gauss Elimination Method ! !>  array    the matrix of order norder which is to be evaluated. !>           this subprogram destroys the matrix array !>  norder   the order of the square matrix to be evaluated. function comp_det ( array , n ) result ( det ) use precision , only : dp implicit none real ( kind = dp ) :: det real ( kind = dp ), intent ( inout ), dimension ( n , n ) :: array integer , intent ( in ) :: n real ( kind = dp ), dimension ( n , n ) :: work integer , dimension ( n ) :: num real ( kind = dp ) :: tmp , max integer i , k , l , m det = 1.0_dp do k = 1 , n max = array ( k , k ) num ( k ) = k do i = k + 1 , n if ( abs ( max ) < abs ( array ( i , k ))) then max = array ( i , k ) num ( k ) = i end if end do if ( num ( k ) /= k ) then do l = k , n tmp = array ( k , l ) array ( k , l ) = array ( num ( k ), l ) array ( num ( k ), l ) = tmp end do det = - 1.0_dp * det end if do m = k + 1 , n work ( m , k ) = array ( m , k ) / array ( k , k ) do l = k , n array ( m , l ) = array ( m , l ) - work ( m , k ) * array ( k , l ) end do end do !There we made matrix triangular! end do do i = 1 , n det = det * array ( i , i ) end do end function comp_det subroutine print_nac ( infos , state_overlap , nac ) use precision , only : dp use io_constants , only : iw use types , only : information implicit none type ( information ), intent ( in ) :: infos real ( kind = dp ), intent ( in ), dimension (:,:) :: state_overlap real ( kind = dp ), intent ( in ), dimension (:,:) :: nac integer :: ndtlf , max , imax , imin , i , j , nstates ndtlf = infos % tddft % tlf nstates = infos % tddft % nstate write ( iw , fmt = '(/5x,40(1h-)/& &5x,\"state overlap integral between different\"/ & &5x,\"   time steps by using TLF(\",i0,\") approx\"/ & &5x,\"     (<phi&#94;{i}(t-dt)|phi&#94;{j}(t)>)\"/ & &5x,40(1h-))' ) ndtlf max = 10 imax = 0 do imin = imax + 1 imax = imax + max if ( imax >= nstates ) imax = nstates write ( iw , fmt = '(5x,10(4x,i4,3x))' ) ( i , i = imin , imax ) do j = 1 , nstates write ( iw , fmt = '(i5,10f11.6)' ) j ,( state_overlap ( j , i ), i = imin , imax ) end do if ( imax > nstates ) then cycle else exit end if end do write ( iw , fmt = '(/,3(/5x,a),/9x,a/,5x,a/)' ) & \"---------------------------------\" , & \"Derivative Coupling Term (a.u.)\" , & \"by using finite difference approx\" , & \"(<phi&#94;{i}|d/dt|phi&#94;{j}> = F - B)\" , & \"---------------------------------\" do j = 1 , nstates write ( iw , fmt = '(i5,10f11.6)' ) j , ( nac ( j , i ), i = 1 , nstates ) end do write ( iw , * ) \" \" end subroutine end module get_state_overlap_mod","tags":"","url":"sourcefile/get_states_overlap.f90.html"},{"title":"constants.F90 – OpenQP Fortran API","text":"Source Code module constants use precision , only : dp use , intrinsic :: iso_c_binding , only : c_bool implicit none real ( kind = dp ), parameter :: pi = 4.0_dp * atan ( 1.0_dp ) integer , parameter :: tol_int = 20 !  atomic number integer , private :: i !  angular momentum labels character ( len = 7 ) :: angular_label = 'SPDFGHI' !  Boltzmann Constant real ( kind = dp ), parameter :: kB_HaK = 3.166811563e-6_dp !  number of cartesian bf for each shell kind integer , parameter :: BAS_MXANG = 6 integer , parameter :: BAS_MXCONTR = 30 integer , parameter :: BAS_MXCART = ( BAS_MXANG + 1 ) * ( BAS_MXANG + 2 ) / 2 integer , parameter :: NUM_CART_BF ( 0 : BAS_MXANG ) = [(( i + 1 ) * ( i + 2 ) / 2 , i = 0 , BAS_MXANG )] !< number of pure spherical-harmonic bf for each shell kind (2l+1) integer , parameter :: NUM_SPH_BF ( 0 : BAS_MXANG ) = [( 2 * i + 1 , i = 0 , BAS_MXANG )] !< Runtime gate for the spherical (5d/7f/9g) AO dimension. Python sets !< this from [input] ispher before basis construction; with this .false., !< num_ao() == NUM_CART_BF and behavior is Cartesian-only. logical :: HARMONIC_ACTIVE = . true . !< powers of X,Y,Z in Cartesian Gaussian basis functions integer , parameter :: & CART_X ( BAS_MXCART , 0 : BAS_MXANG ) = reshape ([ & [ 0 , ( 0 , i = NUM_CART_BF ( 0 ) + 1 , BAS_MXCART )], & [ 1 , 0 , 0 , ( 0 , i = NUM_CART_BF ( 1 ) + 1 , BAS_MXCART )], & [ 2 , 0 , 0 , 1 , 1 , 0 , ( 0 , i = NUM_CART_BF ( 2 ) + 1 , BAS_MXCART )], & [ 3 , 0 , 0 , 2 , 2 , 1 , 0 , 1 , 0 , 1 , ( 0 , i = NUM_CART_BF ( 3 ) + 1 , BAS_MXCART )], & [ 4 , 0 , 0 , 3 , 3 , 1 , 0 , 1 , 0 , 2 , 2 , 0 , 2 , 1 , 1 , ( 0 , i = NUM_CART_BF ( 4 ) + 1 , BAS_MXCART )], & [ 5 , 0 , 0 , 4 , 4 , 1 , 0 , 1 , 0 , 3 , 3 , 2 , 0 , 2 , 0 , 3 , 1 , 1 , 2 , 2 , 1 , ( 0 , i = NUM_CART_BF ( 5 ) + 1 , BAS_MXCART )], & [ 6 , 0 , 0 , 5 , 5 , 1 , 0 , 1 , 0 , 4 , 4 , 2 , 0 , 2 , 0 , 4 , 1 , 1 , 3 , 3 , 0 , 3 , 3 , 2 , 1 , 2 , 1 , 2 ] & ], shape ( CART_X )) integer , parameter :: & CART_Y ( BAS_MXCART , 0 : BAS_MXANG ) = reshape ([ & [ 0 , ( 0 , i = NUM_CART_BF ( 0 ) + 1 , BAS_MXCART )], & [ 0 , 1 , 0 , ( 0 , i = NUM_CART_BF ( 1 ) + 1 , BAS_MXCART )], & [ 0 , 2 , 0 , 1 , 0 , 1 , ( 0 , i = NUM_CART_BF ( 2 ) + 1 , BAS_MXCART )], & [ 0 , 3 , 0 , 1 , 0 , 2 , 2 , 0 , 1 , 1 , ( 0 , i = NUM_CART_BF ( 3 ) + 1 , BAS_MXCART )], & [ 0 , 4 , 0 , 1 , 0 , 3 , 3 , 0 , 1 , 2 , 0 , 2 , 1 , 2 , 1 , ( 0 , i = NUM_CART_BF ( 4 ) + 1 , BAS_MXCART )], & [ 0 , 5 , 0 , 1 , 0 , 4 , 4 , 0 , 1 , 2 , 0 , 3 , 3 , 0 , 2 , 1 , 3 , 1 , 2 , 1 , 2 , ( 0 , i = NUM_CART_BF ( 5 ) + 1 , BAS_MXCART )], & [ 0 , 6 , 0 , 1 , 0 , 5 , 5 , 0 , 1 , 2 , 0 , 4 , 4 , 0 , 2 , 1 , 4 , 1 , 3 , 0 , 3 , 2 , 1 , 3 , 3 , 1 , 2 , 2 ] & ], shape ( CART_Y )) integer , parameter :: & CART_Z ( BAS_MXCART , 0 : BAS_MXANG ) = reshape ([ & [ 0 , ( 0 , i = NUM_CART_BF ( 0 ) + 1 , BAS_MXCART )], & [ 0 , 0 , 1 , ( 0 , i = NUM_CART_BF ( 1 ) + 1 , BAS_MXCART )], & [ 0 , 0 , 2 , 0 , 1 , 1 , ( 0 , i = NUM_CART_BF ( 2 ) + 1 , BAS_MXCART )], & [ 0 , 0 , 3 , 0 , 1 , 0 , 1 , 2 , 2 , 1 , ( 0 , i = NUM_CART_BF ( 3 ) + 1 , BAS_MXCART )], & [ 0 , 0 , 4 , 0 , 1 , 0 , 1 , 3 , 3 , 0 , 2 , 2 , 1 , 1 , 2 , ( 0 , i = NUM_CART_BF ( 4 ) + 1 , BAS_MXCART )], & [ 0 , 0 , 5 , 0 , 1 , 0 , 1 , 4 , 4 , 0 , 2 , 0 , 2 , 3 , 3 , 1 , 1 , 3 , 1 , 2 , 2 , ( 0 , i = NUM_CART_BF ( 5 ) + 1 , BAS_MXCART )], & [ 0 , 0 , 6 , 0 , 1 , 0 , 1 , 5 , 5 , 0 , 2 , 0 , 2 , 4 , 4 , 1 , 1 , 4 , 0 , 3 , 3 , 1 , 2 , 1 , 2 , 3 , 3 , 2 ] & ], shape ( CART_Z )) !  ao symbol integer , private :: iii character ( len = 4 ), parameter :: bf_names ( 15 , 0 : 5 ) = reshape ([& [ '  S ' , & ( '    ' , iii = num_cart_bf ( 0 ) + 1 , 15 )], & [ '  X ' , '  Y ' , '  Z ' , & ( '    ' , iii = num_cart_bf ( 1 ) + 1 , 15 )], & [ ' XX ' , ' YY ' , ' ZZ ' , ' XY ' , ' XZ ' , ' YZ ' , & ( '    ' , iii = num_cart_bf ( 2 ) + 1 , 15 )], & [ ' XXX' , ' YYY' , ' ZZZ' , ' XXY' , ' XXZ' , & ' YYX' , ' YYZ' , ' ZZX' , ' ZZY' , ' XYZ' , & ( '    ' , iii = num_cart_bf ( 3 ) + 1 , 15 )], & [ 'XXXX' , 'YYYY' , 'ZZZZ' , 'XXXY' , 'XXXZ' , & 'YYYX' , 'YYYZ' , 'ZZZX' , 'ZZZY' , 'XXYY' , & 'XXZZ' , 'YYZZ' , 'XXYZ' , 'YYXZ' , 'ZZXY' , & ( '    ' , iii = num_cart_bf ( 4 ) + 1 , 15 )], & [ '????' , & ( '    ' , iii = 2 , 15 )] & ], shape ( bf_names )) !  canonical order is achieved by ordering angular momentum components (x,y,z) !  in descending order. For a given total angular momentum L, the components !  are generated as follows: !  Example for L = 2: !     do x = L, 0, -1          ! x descends from L to 0 !         do y = L-x, 0, -1    ! y descends from remaining momentum (L-x) to 0 !             z = L - x - y     ! z takes the remaining momentum !             ! This generates ordered triplets (x,y,z) where x >= y >= z !             ! and x + y + z = L !         end do !     end do !  Last Modified: 2025-02-03 06:00:22 UTC integer , parameter :: & map_canonical ( BAS_MXCART , 0 : BAS_MXANG ) = reshape ([ & [ 0 , ( 0 , i = NUM_CART_BF ( 0 ) + 1 , BAS_MXCART )], & ! l = 0 (S) [ 0 , 0 , 0 , ( 0 , i = NUM_CART_BF ( 1 ) + 1 , BAS_MXCART )], & ! l = 1 (P) [ 0 , 2 , 3 , - 2 , - 2 , - 1 , ( 0 , i = NUM_CART_BF ( 2 ) + 1 , BAS_MXCART )], & ! l = 2 (D) [ 0 , 5 , 7 , - 2 , - 2 , - 2 , 1 , - 2 , 0 , - 5 , ( 0 , i = NUM_CART_BF ( 3 ) + 1 , BAS_MXCART )], & ! l = 3 (F) [ 0 , 9 , 12 , - 2 , - 2 , 1 , 5 , 2 , 5 , - 6 , - 5 , 1 , - 8 , - 6 , - 6 , ( 0 , i = NUM_CART_BF ( 4 ) + 1 , BAS_MXCART )], & ! l = 4 (G) [ 0 , 14 , 18 , - 2 , - 2 , 5 , 10 , 7 , 11 , - 6 , - 5 , - 5 , 5 , - 4 , 4 , - 11 , - 5 , - 4 , - 11 , - 11 , - 8 , ( 0 , i = NUM_CART_BF ( 5 ) + 1 , BAS_MXCART )], & ! l = 4 (H) [ 0 , 20 , 25 , - 2 , - 2 , 10 , 16 , 13 , 18 , - 6 , - 5 , - 1 , 11 , 1 , 11 , - 11 , 0 , 2 , - 12 , - 10 , 4 , - 14 , - 14 , - 12 , - 7 , - 12 , - 8 , - 15 ] & ], shape ( map_canonical )) ! normalization constants real ( kind = dp ), target , save :: shells_pnrm2 ( 28 , 0 : 6 ) = reshape ([ & [ 1.0_dp , & 0.0d0 , 0.0d0 , 0.0d0 , 0.0d0 , 0.0d0 , 0.0d0 , 0.0d0 , 0.0d0 , 0.0d0 , 0.0d0 , 0.0d0 , 0.0d0 , 0.0d0 , 0.0d0 , 0.0d0 , & 0.0d0 , 0.0d0 , 0.0d0 , 0.0d0 , 0.0d0 , 0.0d0 , 0.0d0 , 0.0d0 , 0.0d0 , 0.0d0 , 0.0d0 , 0.0d0 ], & ! s-shell [ 1.0_dp , 1.0_dp , 1.0_dp , & 0.0d0 , 0.0d0 , 0.0d0 , 0.0d0 , 0.0d0 , 0.0d0 , 0.0d0 , 0.0d0 , 0.0d0 , 0.0d0 , 0.0d0 , 0.0d0 , 0.0d0 , 0.0d0 , 0.0d0 , & 0.0d0 , 0.0d0 , 0.0d0 , 0.0d0 , 0.0d0 , 0.0d0 , 0.0d0 , 0.0d0 , 0.0d0 , 0.0d0 ], & ! p-shell [ 1.0_dp , 1.0_dp , 1.0_dp , sqrt ( 3.0_dp ), sqrt ( 3.0_dp ), sqrt ( 3.0_dp ), & 0.0d0 , 0.0d0 , 0.0d0 , 0.0d0 , 0.0d0 , 0.0d0 , 0.0d0 , 0.0d0 , 0.0d0 , 0.0d0 , 0.0d0 , 0.0d0 , 0.0d0 , 0.0d0 , 0.0d0 , & 0.0d0 , 0.0d0 , 0.0d0 , 0.0d0 , 0.0d0 , 0.0d0 , 0.0d0 ], & ! d-shell [ 1.0_dp , 1.0_dp , 1.0_dp , sqrt ( 5.0_dp ), sqrt ( 5.0_dp ), sqrt ( 5.0_dp ), sqrt ( 5.0_dp ), sqrt ( 5.0_dp ), & sqrt ( 5.0_dp ), sqrt ( 5.0_dp ) * sqrt ( 3.0_dp ), & 0.0d0 , 0.0d0 , 0.0d0 , 0.0d0 , 0.0d0 , 0.0d0 , 0.0d0 , 0.0d0 , 0.0d0 , 0.0d0 , 0.0d0 , 0.0d0 , 0.0d0 , 0.0d0 , 0.0d0 , & 0.0d0 , 0.0d0 , 0.0d0 ], & ! f-shell [ 1.0_dp , 1.0_dp , 1.0_dp , sqrt ( 7.0_dp ), sqrt ( 7.0_dp ), sqrt ( 7.0_dp ), sqrt ( 7.0_dp ), & sqrt ( 7.0_dp ), sqrt ( 7.0_dp ), sqrt ( 7.0_dp ) * sqrt ( 5.0_dp ) / sqrt ( 3.0_dp ), & sqrt ( 7.0_dp ) * sqrt ( 5.0_dp ) / sqrt ( 3.0_dp ), sqrt ( 7.0_dp ) * sqrt ( 5.0_dp ) / sqrt ( 3.0_dp ), & sqrt ( 7.0_dp ) * sqrt ( 5.0_dp ), sqrt ( 7.0_dp ) * sqrt ( 5.0_dp ), sqrt ( 7.0_dp ) * sqrt ( 5.0_dp ), & 0.0d0 , 0.0d0 , 0.0d0 , 0.0d0 , 0.0d0 , 0.0d0 , 0.0d0 , 0.0d0 , 0.0d0 , 0.0d0 , 0.0d0 , 0.0d0 , 0.0d0 ], & ! g-shell [ 1.0_dp , 1.0_dp , 1.0_dp , 3.0_dp , 3.0_dp , 3.0_dp , 3.0_dp , 3.0_dp , 3.0_dp , sqrt ( 7.0_dp ) * sqrt ( 3.0_dp ), & sqrt ( 7.0_dp ) * sqrt ( 3.0_dp ), sqrt ( 7.0_dp ) * sqrt ( 3.0_dp ), sqrt ( 7.0_dp ) * sqrt ( 3.0_dp ), & sqrt ( 7.0_dp ) * sqrt ( 3.0_dp ), sqrt ( 7.0_dp ) * sqrt ( 3.0_dp ), sqrt ( 7.0_dp ) * 3.0_dp , & sqrt ( 7.0_dp ) * 3.0_dp , sqrt ( 7.0_dp ) * 3.0_dp , sqrt ( 3.0_dp ) * sqrt ( 5.0_dp ) * sqrt ( 7.0_dp ), & sqrt ( 3.0_dp ) * sqrt ( 5.0_dp ) * sqrt ( 7.0_dp ), sqrt ( 3.0_dp ) * sqrt ( 5.0_dp ) * sqrt ( 7.0_dp ), & 0.0d0 , 0.0d0 , 0.0d0 , 0.0d0 , 0.0d0 , 0.0d0 , 0.0d0 ], & ! h-shell [ 1.0_dp , 1.0_dp , 1.0_dp , sqrt ( 1 1.0_dp ), sqrt ( 1 1.0_dp ), sqrt ( 1 1.0_dp ), sqrt ( 1 1.0_dp ), & sqrt ( 1 1.0_dp ), sqrt ( 1 1.0_dp ), sqrt ( 3.0_dp ) * sqrt ( 1 1.0_dp ), & sqrt ( 3.0_dp ) * sqrt ( 1 1.0_dp ), sqrt ( 3.0_dp ) * sqrt ( 1 1.0_dp ), sqrt ( 3.0_dp ) * sqrt ( 1 1.0_dp ), & sqrt ( 3.0_dp ) * sqrt ( 1 1.0_dp ), sqrt ( 3.0_dp ) * sqrt ( 1 1.0_dp ), & 3.0_dp * sqrt ( 1 1.0_dp ), 3.0_dp * sqrt ( 1 1.0_dp ), 3.0_dp * sqrt ( 1 1.0_dp ), & sqrt ( 3.0_dp ) * sqrt ( 7.0_dp ) * sqrt ( 1 1.0_dp ) / sqrt ( 5.0_dp ), & sqrt ( 3.0_dp ) * sqrt ( 7.0_dp ) * sqrt ( 1 1.0_dp ) / sqrt ( 5.0_dp ), & sqrt ( 3.0_dp ) * sqrt ( 7.0_dp ) * sqrt ( 1 1.0_dp ) / sqrt ( 5.0_dp ), sqrt ( 3.0_dp ) * sqrt ( 7.0_dp ) * sqrt ( 1 1.0_dp ), & sqrt ( 3.0_dp ) * sqrt ( 7.0_dp ) * sqrt ( 1 1.0_dp ), sqrt ( 3.0_dp ) * sqrt ( 7.0_dp ) * sqrt ( 1 1.0_dp ), & sqrt ( 3.0_dp ) * sqrt ( 7.0_dp ) * sqrt ( 1 1.0_dp ), sqrt ( 3.0_dp ) * sqrt ( 7.0_dp ) * sqrt ( 1 1.0_dp ), & sqrt ( 3.0_dp ) * sqrt ( 7.0_dp ) * sqrt ( 1 1.0_dp ), sqrt ( 5.0_dp ) * sqrt ( 7.0_dp ) * sqrt ( 1 1.0_dp )] & ! i-shell ], shape = [ 28 , 7 ]) contains !> @brief Number of AO components for a shell of angular momentum l. !> @details Returns the Cartesian count (l+1)(l+2)/2 unless the shell is !>          flagged pure spherical (harmonic==1) AND the global !>          HARMONIC_ACTIVE gate is on, in which case it returns 2l+1. !>          While HARMONIC_ACTIVE is .false. this is identical to !>          NUM_CART_BF(l) for every shell, so the dimension is unchanged. subroutine set_harmonic_active ( flag ) bind ( C , name = \"oqp_set_harmonic_active\" ) logical ( c_bool ), value , intent ( in ) :: flag HARMONIC_ACTIVE = logical ( flag ) end subroutine set_harmonic_active integer function num_ao ( l , harmonic ) result ( n ) integer , intent ( in ) :: l , harmonic if ( HARMONIC_ACTIVE . and . harmonic == 1 ) then n = NUM_SPH_BF ( l ) else n = NUM_CART_BF ( l ) end if end function num_ao end module constants","tags":"","url":"sourcefile/constants.f90.html"},{"title":"dft_xc_libxc.F90 – OpenQP Fortran API","text":"Source Code module mod_dft_xc_libxc use precision , only : fp use mod_dft_xclib implicit none type , extends ( xc_lib_t ) :: xc_libxc_t integer :: nSpin real ( kind = fp ), contiguous , pointer :: lib_output (:) => null () contains procedure init procedure setPts procedure compute end type contains subroutine init ( self , reqSigma , reqTau , reqLapl , reqBeta , maxPts , nDer ) ! E_XC and E_CORR are separate class ( xc_libxc_t ) :: self logical , intent ( in ) :: reqSigma , reqTau , reqLapl , reqBeta integer , intent ( in ) :: maxPts , nDer integer :: ndens call self % clean () self % reqSigma = reqSigma self % reqTau = reqTau self % reqLapl = reqLapl self % reqBeta = reqBeta self % maxPts = maxPts self % nDer = nDer self % providesEXC = . TRUE . self % providesEX = . FALSE . self % providesEC = . FALSE . self % nSpin = 1 if ( self % reqBeta ) self % nSpin = 2 ndens = 2 + 6 + 3 + 2 + 2 & + 1 + 2 + 3 + 2 + 2 if ( nDer > 1 ) & ndens = ndens & + 3 + 6 + 4 + 4 + 6 + 6 + 6 + 3 + 4 + 3 if ( nDer > 2 ) & ndens = ndens & + 4 + 10 + 9 + 12 + 4 + 6 + 6 + 12 + 12 & + 9 + 6 + 6 + 12 + 8 + 12 + 9 + 12 + 6 & + 6 + 4 allocate ( self % memory_ ( 1 : maxPts * ndens )) call self % resetEnergy end subroutine subroutine setPts ( self , numPts ) class ( xc_libxc_t ), target :: self integer , intent ( in ) :: numPts integer :: i , i_out0 self % numPts = numPts i = 0 ! Input self % rho => addmem ( self % memory_ , i , 2 , numPts ) self % drho => addmem ( self % memory_ , i , 6 , numPts ) self % sig => addmem ( self % memory_ , i , 3 , numPts ) self % tau => addmem ( self % memory_ , i , 2 , numPts ) self % lapl => addmem ( self % memory_ , i , 2 , numPts ) ! Output i_out0 = i + 1 self % exc ( 1 : numPts ) => self % memory_ ( i + 1 :) i = i + numPts self % d1dr => addmem ( self % memory_ , i , 2 , numPts ) self % d1ds => addmem ( self % memory_ , i , 3 , numPts ) self % d1dt => addmem ( self % memory_ , i , 2 , numPts ) self % d1dl => addmem ( self % memory_ , i , 2 , numPts ) self % lib_output => self % memory_ ( i_out0 : i ) if ( self % nDer == 1 ) return self % d2r2 => addmem ( self % memory_ , i , 3 , numPts ) self % d2rs => addmem ( self % memory_ , i , 6 , numPts ) self % d2rt => addmem ( self % memory_ , i , 4 , numPts ) self % d2rl => addmem ( self % memory_ , i , 4 , numPts ) self % d2s2 => addmem ( self % memory_ , i , 6 , numPts ) self % d2st => addmem ( self % memory_ , i , 6 , numPts ) self % d2sl => addmem ( self % memory_ , i , 6 , numPts ) self % d2t2 => addmem ( self % memory_ , i , 3 , numPts ) self % d2tl => addmem ( self % memory_ , i , 4 , numPts ) self % d2l2 => addmem ( self % memory_ , i , 3 , numPts ) self % lib_output => self % memory_ ( i_out0 : i ) if ( self % nDer == 2 ) return self % d3r3 => addmem ( self % memory_ , i , 4 , numPts ) self % d3s3 => addmem ( self % memory_ , i , 10 , numPts ) self % d3r2s => addmem ( self % memory_ , i , 9 , numPts ) self % d3rs2 => addmem ( self % memory_ , i , 12 , numPts ) self % d3t3 => addmem ( self % memory_ , i , 4 , numPts ) self % d3r2t => addmem ( self % memory_ , i , 6 , numPts ) self % d3rt2 => addmem ( self % memory_ , i , 6 , numPts ) self % d3rst => addmem ( self % memory_ , i , 12 , numPts ) self % d3s2t => addmem ( self % memory_ , i , 12 , numPts ) self % d3st2 => addmem ( self % memory_ , i , 9 , numPts ) self % d3r2l => addmem ( self % memory_ , i , 6 , numPts ) self % d3rl2 => addmem ( self % memory_ , i , 6 , numPts ) self % d3rsl => addmem ( self % memory_ , i , 12 , numPts ) self % d3rtl => addmem ( self % memory_ , i , 8 , numPts ) self % d3s2l => addmem ( self % memory_ , i , 12 , numPts ) self % d3sl2 => addmem ( self % memory_ , i , 9 , numPts ) self % d3stl => addmem ( self % memory_ , i , 12 , numPts ) self % d3t2l => addmem ( self % memory_ , i , 6 , numPts ) self % d3tl2 => addmem ( self % memory_ , i , 6 , numPts ) self % d3l3 => addmem ( self % memory_ , i , 4 , numPts ) self % lib_output => self % memory_ ( i_out0 : i ) contains function addmem ( memory , pos , d1 , d2 ) result ( res ) real ( kind = fp ), contiguous , target :: memory (:) integer , intent ( inout ) :: pos integer , intent ( in ) :: d1 , d2 real ( kind = fp ), contiguous , pointer :: res (:,:) res ( 1 : d1 , 1 : d2 ) => memory ( pos + 1 : ) pos = pos + d1 * d2 end function end subroutine subroutine compute ( self , functional , wts ) use functionals , only : functional_t !    use xc_f03_lib_m class ( xc_libxc_t ) :: self class ( functional_t ) :: functional real ( kind = fp ), intent ( in ) :: wts (:) self % lib_output = 0 select case ( self % nDer ) case ( 1 ) call functional % calc_evxc ( self % numPts , & rho = self % rho , & sigma = self % sig , & tau = self % tau , & lapl = self % lapl , & energy = self % exc , & dedrho = self % d1dr , & dedsigma = self % d1ds , & dedtau = self % d1dt , & dedlapl = self % d1dl ) case ( 2 ) call functional % calc_evfxc ( self % numPts , & rho = self % rho , & sigma = self % sig , & tau = self % tau , & lapl = self % lapl , & energy = self % exc , & dedrho = self % d1dr , & dedsigma = self % d1ds , & dedtau = self % d1dt , & dedlapl = self % d1dl , & v2rho2 = self % d2r2 , & v2sigma2 = self % d2s2 , & v2tau2 = self % d2t2 , & v2lapl2 = self % d2l2 , & v2rhosigma = self % d2rs , & v2rhotau = self % d2rt , & v2rholapl = self % d2rl , & v2sigmatau = self % d2st , & v2sigmalapl = self % d2sl , & v2lapltau = self % d2tl ) case ( 3 ) call functional % calc_xc ( self % numPts , & rho = self % rho , & sigma = self % sig , & tau = self % tau , & lapl = self % lapl , & energy = self % exc , & dedrho = self % d1dr , & dedsigma = self % d1ds , & dedlapl = self % d1dl , & dedtau = self % d1dt , & v2rho2 = self % d2r2 , & v2rhosigma = self % d2rs , & v2rholapl = self % d2rl , & v2rhotau = self % d2rt , & v2sigma2 = self % d2s2 , & v2sigmalapl = self % d2sl , & v2sigmatau = self % d2st , & v2lapl2 = self % d2l2 , & v2lapltau = self % d2tl , & v2tau2 = self % d2t2 , & v3rho3 = self % d3r3 , & v3rho2sigma = self % d3r2s , & v3rho2lapl = self % d3r2l , & v3rho2tau = self % d3r2t , & v3rhosigma2 = self % d3rs2 , & v3rhosigmalapl = self % d3rsl , & v3rhosigmatau = self % d3rst , & v3rholapl2 = self % d3rl2 , & v3rholapltau = self % d3rtl , & v3rhotau2 = self % d3rt2 , & v3sigma3 = self % d3s3 , & v3sigma2lapl = self % d3s2l , & v3sigma2tau = self % d3s2t , & v3sigmalapl2 = self % d3sl2 , & v3sigmalapltau = self % d3stl , & v3sigmatau2 = self % d3st2 , & v3lapl3 = self % d3l3 , & v3lapl2tau = self % d3tl2 , & v3lapltau2 = self % d3t2l , & v3tau3 = self % d3t3 ) end select self % E_xc = self % E_xc + dot_product ( self % exc , wts ) call self % scaleXC ( wts ) end subroutine end module","tags":"","url":"sourcefile/dft_xc_libxc.f90.html"}]}